Enable Haddock tests in GHC windows CI (#1428)

* testsuite: strip windows line endings for haddock

* hyperlinker: Work around double escaping (#19236)

* deterministic SCC

6 files changed, 76 insertions, 21 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 39be6762..68e03fd5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -22,7 +22,7 @@ import System.FilePath
 
 import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
 import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )
-import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc )
+import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile )
 import Data.Map as M
 import GHC.Data.FastString     ( mkFastString )
 import GHC.Unit.Module         ( Module, moduleName )
@@ -71,7 +71,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
         let fileFs = mkFastString file
             mast | M.size asts == 1 = snd <$> M.lookupMin asts
                  | otherwise        = M.lookup (HiePath (mkFastString file)) asts
-            tokens = parse df file rawSrc
+            tokens' = parse df file rawSrc
             ast = fromMaybe (emptyHieAst fileFs) mast
             fullAst = recoverFullIfaceTypes df types ast
 
@@ -81,6 +81,14 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
           else out verbosity verbose $ unwords [ "couldn't find ast for"
                                                , file, show (M.keys asts) ]
 
+        -- The C preprocessor can double the backslashes on tokens (see #19236),
+        -- which means the source spans will not be comparable and we will not
+        -- be able to associate the HieAST with the correct tokens.
+        --
+        -- We work around this by setting the source span of the tokens to the file
+        -- name from the HieAST
+        let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
+
         -- Produce and write out the hyperlinked sources
         writeUtf8File path . renderToString pretty . render' fullAst $ tokens
     Nothing -> return ()
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 2e9b2f7e..ba7d9d30 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -55,7 +55,7 @@ import qualified Data.Set as Set
 
 import GHC hiding (verbosity)
 import GHC.Data.FastString (unpackFS)
-import GHC.Data.Graph.Directed (flattenSCCs)
+import GHC.Data.Graph.Directed
 import GHC.Driver.Env (hscUpdateFlags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)
 import GHC.Driver.Monad (modifySession, withTimingM)
 import GHC.Driver.Session hiding (verbosity)
@@ -68,7 +68,7 @@ import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK)
 import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)
-import GHC.Unit.Module.Graph (ModuleGraphNode (..))
+import GHC.Unit.Module.Graph
 import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)
 import GHC.Unit.Types (IsBootInterface (..))
 import GHC.Utils.Error (withTiming)
@@ -170,13 +170,59 @@ createIfaces verbosity modules flags instIfaceMap = do
       moduleSet <- liftIO getModules
 
       let
+        -- We topologically sort the module graph including boot files,
+        -- so it should be acylic (hopefully we failed much earlier if this is not the case)
+        -- We then filter out boot modules from the resultant topological sort
+        --
+        -- We do it this way to make 'buildHomeLinks' a bit more stable
+        -- 'buildHomeLinks' depends on the topological order of its input in order
+        -- to construct its result. In particular, modules closer to the bottom of
+        -- the dependency chain are to be prefered for link destinations.
+        --
+        -- If there are cycles in the graph, then this order is indeterminate
+        -- (the nodes in the cycle can be ordered in any way).
+        -- While 'topSortModuleGraph' does guarantee stability for equivalent
+        -- module graphs, seemingly small changes in the ModuleGraph can have
+        -- big impacts on the `LinkEnv` constructed.
+        --
+        -- For example, suppose
+        --  G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
+        --
+        -- Then suppose C.hs is changed to have a cyclic dependency on A
+        --
+        --  G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
+        --
+        -- For G1, `C.hs` is preferred for link destinations. However, for G2,
+        -- the topologically sorted order not taking into account boot files (so
+        -- C -> A) is completely indeterminate.
+        -- Using boot files to resolve cycles, we end up with the original order
+        -- [C, B, A] (in decreasing order of preference for links)
+        --
+        -- This exact case came up in testing for the 'base' package, where there
+        -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
+        -- include 'Prelude' on non-windows platforms. This lead to drastically different
+        -- LinkEnv's (and failing haddockHtmlTests) across the platforms
+        --
+        -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
+        -- means that {-# SOURCE #-} imports no longer count towards re-ordering
+        -- the preference of modules for linking.
+        --
+        -- i.e. if module A imports B, then B is preferred over A,
+        -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
+        --
+        go (AcyclicSCC (ModuleNode ems))
+          | NotBoot <- isBootSummary (emsModSummary ems) = [ems]
+          | otherwise = []
+        go (AcyclicSCC _) = []
+        go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
+
         ifaces :: [Interface]
         ifaces =
           [ Map.findWithDefault
               (error "haddock:iface")
               (ms_mod (emsModSummary ems))
               ifaceMap
-          | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+          | ems <- concatMap go $ topSortModuleGraph False modGraph Nothing
           ]
 
       return (ifaces, moduleSet)
@@ -352,7 +398,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
 -- The interfaces are passed in in topologically sorted order, but we start
 -- by reversing the list so we can do a foldl.
 buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
+buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)
   where
     upd old_env iface
       | OptHide    `elem` ifaceOptions iface = old_env
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index bca2c4cc..74d8c4f7 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -23,8 +23,9 @@ import Data.Char ( isSpace )
 newtype Xml = Xml { unXml :: String }
 
 -- | Part of parsing involves dropping the @DOCTYPE@ line
+-- and windows newline endings
 parseXml :: String -> Maybe Xml
-parseXml = Just . Xml . dropDocTypeLine
+parseXml = Just . Xml . filter (/= '\r') . dropDocTypeLine
   where
   dropDocTypeLine bs
     | "<!DOCTYPE" `isPrefixOf` bs
diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html
index 3324fae1..9fe6f84e 100644
--- a/html-test/ref/Bug1004.html
+++ b/html-test/ref/Bug1004.html
@@ -1228,13 +1228,13 @@
 		  ><span class="inst-left"
 		    ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Data:15"
 		      ></span
-		      > (<a href="#" title="Data.Typeable"
+		      > (<a href="#" title="Type.Reflection"
 		      >Typeable</a
-		      > a, <a href="#" title="Data.Typeable"
+		      > a, <a href="#" title="Type.Reflection"
 		      >Typeable</a
-		      > f, <a href="#" title="Data.Typeable"
+		      > f, <a href="#" title="Type.Reflection"
 		      >Typeable</a
-		      > g, <a href="#" title="Data.Typeable"
+		      > g, <a href="#" title="Type.Reflection"
 		      >Typeable</a
 		      > k, <a href="#" title="Data.Data"
 		      >Data</a
@@ -1320,7 +1320,7 @@
 			><p class="src"
 			><a href="#"
 			  >dataCast1</a
-			  > :: <a href="#" title="Data.Typeable"
+			  > :: <a href="#" title="Type.Reflection"
 			  >Typeable</a
 			  > t =&gt; (<span class="keyword"
 			  >forall</span
@@ -1336,7 +1336,7 @@
 			><p class="src"
 			><a href="#"
 			  >dataCast2</a
-			  > :: <a href="#" title="Data.Typeable"
+			  > :: <a href="#" title="Type.Reflection"
 			  >Typeable</a
 			  > t =&gt; (<span class="keyword"
 			  >forall</span
diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html
index 8ac16a68..94a197c2 100644
--- a/html-test/ref/BundledPatterns.html
+++ b/html-test/ref/BundledPatterns.html
@@ -58,7 +58,7 @@
 	      >data</span
 	      > <a href="#"
 	      >Vec</a
-	      > :: <a href="#" title="GHC.TypeLits"
+	      > :: <a href="#" title="GHC.TypeNats"
 	      >Nat</a
 	      > -&gt; * -&gt; * <span class="keyword"
 	      >where</span
@@ -88,7 +88,7 @@
 	      >data</span
 	      > <a href="#"
 	      >RTree</a
-	      > :: <a href="#" title="GHC.TypeLits"
+	      > :: <a href="#" title="GHC.TypeNats"
 	      >Nat</a
 	      > -&gt; * -&gt; * <span class="keyword"
 	      >where</span
@@ -129,7 +129,7 @@
 	    >data</span
 	    > <a id="t:Vec" class="def"
 	    >Vec</a
-	    > :: <a href="#" title="GHC.TypeLits"
+	    > :: <a href="#" title="GHC.TypeNats"
 	    >Nat</a
 	    > -&gt; * -&gt; * <span class="keyword"
 	    >where</span
@@ -291,7 +291,7 @@
 	    >data</span
 	    > <a id="t:RTree" class="def"
 	    >RTree</a
-	    > :: <a href="#" title="GHC.TypeLits"
+	    > :: <a href="#" title="GHC.TypeNats"
 	    >Nat</a
 	    > -&gt; * -&gt; * <span class="keyword"
 	    >where</span
diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html
index fff9d572..3b192054 100644
--- a/html-test/ref/BundledPatterns2.html
+++ b/html-test/ref/BundledPatterns2.html
@@ -58,7 +58,7 @@
 	      >data</span
 	      > <a href="#"
 	      >Vec</a
-	      > :: <a href="#" title="GHC.TypeLits"
+	      > :: <a href="#" title="GHC.TypeNats"
 	      >Nat</a
 	      > -&gt; * -&gt; * <span class="keyword"
 	      >where</span
@@ -90,7 +90,7 @@
 	      >data</span
 	      > <a href="#"
 	      >RTree</a
-	      > :: <a href="#" title="GHC.TypeLits"
+	      > :: <a href="#" title="GHC.TypeNats"
 	      >Nat</a
 	      > -&gt; * -&gt; * <span class="keyword"
 	      >where</span
@@ -131,7 +131,7 @@
 	    >data</span
 	    > <a id="t:Vec" class="def"
 	    >Vec</a
-	    > :: <a href="#" title="GHC.TypeLits"
+	    > :: <a href="#" title="GHC.TypeNats"
 	    >Nat</a
 	    > -&gt; * -&gt; * <span class="keyword"
 	    >where</span
@@ -289,7 +289,7 @@
 	    >data</span
 	    > <a id="t:RTree" class="def"
 	    >RTree</a
-	    > :: <a href="#" title="GHC.TypeLits"
+	    > :: <a href="#" title="GHC.TypeNats"
 	    >Nat</a
 	    > -&gt; * -&gt; * <span class="keyword"
 	    >where</span