diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 12 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 54 | ||||
| -rw-r--r-- | haddock-test/src/Test/Haddock/Xhtml.hs | 3 | ||||
| -rw-r--r-- | html-test/ref/Bug1004.html | 12 | ||||
| -rw-r--r-- | html-test/ref/BundledPatterns.html | 8 | ||||
| -rw-r--r-- | html-test/ref/BundledPatterns2.html | 8 |
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 => (<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 => (<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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <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 > -> * -> * <span class="keyword" >where</span |