From 4c471b8ffc5dc59ce72128c1d74818a08c5743cc Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Tue, 2 Mar 2021 14:42:31 +0100 Subject: pprError changed name in GHC --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d9a2e0cd..e6748937 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -14,7 +14,7 @@ import GHC.Types.SourceText import GHC.Driver.Session import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString ) -import GHC.Parser.Errors.Ppr ( pprError ) +import GHC.Parser.Errors.Ppr ( mkParserErr ) import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) , initParserState, lexer, mkParserOpts, getErrorMessages) @@ -40,7 +40,7 @@ parse parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst -> - let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in + let err:_ = bagToList (fmap mkParserErr (getErrorMessages pst)) in panic $ showSDoc dflags $ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where -- cgit v1.2.3 From a1337c599ef7720b0482a25c55f11794112496dc Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Thu, 13 May 2021 08:21:56 +0200 Subject: Add Haddock support for the OPAQUE pragma (#1380) --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index e6748937..f4bc038c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -233,6 +233,7 @@ classify tok = ITrequires -> TkKeyword ITinline_prag {} -> TkPragma + ITopaque_prag {} -> TkPragma ITspec_prag {} -> TkPragma ITspec_inline_prag {} -> TkPragma ITsource_prag {} -> TkPragma @@ -374,6 +375,7 @@ inPragma True _ = True inPragma False tok = case tok of ITinline_prag {} -> True + ITopaque_prag {} -> True ITspec_prag {} -> True ITspec_inline_prag {} -> True ITsource_prag {} -> True -- cgit v1.2.3 From 40ba457f6436b7eb2c60e8824e1591526945df2a Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 26 Apr 2021 12:56:50 +0200 Subject: New Parser diagnostics interface --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index e6748937..94395218 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -12,9 +12,10 @@ import qualified Data.ByteString as BS import GHC.Types.SourceText import GHC.Driver.Session -import GHC.Utils.Error ( pprLocMsgEnvelope ) +import GHC.Utils.Error ( mkPlainMsgEnvelope, pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString ) -import GHC.Parser.Errors.Ppr ( mkParserErr ) +import GHC.Parser.Errors.Ppr () +import qualified GHC.Types.Error as E import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) , initParserState, lexer, mkParserOpts, getErrorMessages) @@ -40,7 +41,7 @@ parse parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst -> - let err:_ = bagToList (fmap mkParserErr (getErrorMessages pst)) in + let err:_ = bagToList (E.getMessages $ getErrorMessages pst) in panic $ showSDoc dflags $ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where @@ -50,6 +51,7 @@ parse dflags fpath bs = case unP (go False []) initState of start = mkRealSrcLoc (mkFastString fpath) 1 1 pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags) + (mkPlainMsgEnvelope dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens -- cgit v1.2.3 From 4f9088e4b04e52ca510b55a78048c9230537e449 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 24 May 2021 11:19:01 -0400 Subject: Revert "Add Haddock support for the OPAQUE pragma (#1380)" This reverts commit a1337c599ef7720b0482a25c55f11794112496dc. The GHC patch associated with this change is not yet ready to be merged. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 -- 1 file changed, 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d5ee7420..94395218 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -235,7 +235,6 @@ classify tok = ITrequires -> TkKeyword ITinline_prag {} -> TkPragma - ITopaque_prag {} -> TkPragma ITspec_prag {} -> TkPragma ITspec_inline_prag {} -> TkPragma ITsource_prag {} -> TkPragma @@ -377,7 +376,6 @@ inPragma True _ = True inPragma False tok = case tok of ITinline_prag {} -> True - ITopaque_prag {} -> True ITspec_prag {} -> True ITspec_inline_prag {} -> True ITsource_prag {} -> True -- cgit v1.2.3 From 1ceb34bf20ef4f226a4152264505826d3138957e Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Tue, 1 Jun 2021 10:02:06 +0200 Subject: Adapt Haddock to Logger and Parser changes (#1399) --- haddock-api/src/Haddock.hs | 17 ++++++++++------- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 3 +++ haddock-api/src/Haddock/Interface.hs | 14 +++++--------- haddock-api/src/Haddock/Parser.hs | 2 +- 4 files changed, 19 insertions(+), 17 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d955ae4f..9158d83c 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -69,8 +69,10 @@ import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity) +import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Env import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit import GHC.Utils.Panic (handleGhcException) @@ -192,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do name_cache <- freshNameCache mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) + putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -282,7 +284,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do +render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -298,6 +300,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags + logger = setLogFlags log' (initLogFlags dflags') visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -372,7 +375,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do - withTiming logger dflags' "ppHtmlIndex" (const ()) $ do + withTiming logger "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls @@ -382,7 +385,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - withTiming logger dflags' "ppHtmlContents" (const ()) $ do + withTiming logger "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls @@ -392,7 +395,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - withTiming logger dflags' "ppHtml" (const ()) $ do + withTiming logger "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue @@ -427,14 +430,14 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS ] when (Flag_LaTeX `elem` flags) $ do - withTiming logger dflags' "ppLatex" (const ()) $ do + withTiming logger "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do + withTiming logger "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 94395218..49e2c66f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -10,6 +10,7 @@ import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS +import GHC.Platform import GHC.Types.SourceText import GHC.Driver.Session import GHC.Utils.Error ( mkPlainMsgEnvelope, pprLocMsgEnvelope ) @@ -49,9 +50,11 @@ parse dflags fpath bs = case unP (go False []) initState of initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 + arch_os = platformArchOS (targetPlatform dflags) pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags) (mkPlainMsgEnvelope dflags) + (supportedLanguagesAndExtensions arch_os) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 2486c752..2e9b2f7e 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -56,7 +56,7 @@ import qualified Data.Set as Set import GHC hiding (verbosity) import GHC.Data.FastString (unpackFS) import GHC.Data.Graph.Directed (flattenSCCs) -import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units) +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) import GHC.HsToCore.Docs (getMainDeclBinder) @@ -145,11 +145,8 @@ createIfaces verbosity modules flags instIfaceMap = do let installHaddockPlugin :: HscEnv -> HscEnv - installHaddockPlugin hsc_env = hsc_env - { - hsc_dflags = - gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy - , hsc_static_plugins = + installHaddockPlugin hsc_env = hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) $ hsc_env + { hsc_static_plugins = haddockPlugin : hsc_static_plugins hsc_env } @@ -212,7 +209,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env) + (iface, modules) <- withTiming (hsc_logger hsc_env) "processModule" (const ()) $ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env @@ -266,9 +263,8 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env (!interface, messages) <- do logger <- getLogger - dflags <- getDynFlags {-# SCC createInterface #-} - withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index ab2fa549..53cf98ad 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -19,7 +19,7 @@ import Documentation.Haddock.Types import Haddock.Types import GHC.Driver.Session ( DynFlags ) -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Data.FastString ( fsLit ) import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) -- cgit v1.2.3 From f7059f84687a6aac37405c428a97190662de1dac Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 28 Jun 2021 19:21:17 +0200 Subject: Fix mkParserOpts (#1411) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index dfb167a3..29c64a2d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -31,7 +31,6 @@ import GHC import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.State import Data.Char diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 49e2c66f..4e9099d8 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -13,7 +13,8 @@ import qualified Data.ByteString as BS import GHC.Platform import GHC.Types.SourceText import GHC.Driver.Session -import GHC.Utils.Error ( mkPlainMsgEnvelope, pprLocMsgEnvelope ) +import GHC.Driver.Config.Diagnostic +import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString ) import GHC.Parser.Errors.Ppr () import qualified GHC.Types.Error as E @@ -51,9 +52,8 @@ parse dflags fpath bs = case unP (go False []) initState of buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 arch_os = platformArchOS (targetPlatform dflags) - pflags = mkParserOpts (warningFlags dflags) - (extensionFlags dflags) - (mkPlainMsgEnvelope dflags) + pflags = mkParserOpts (extensionFlags dflags) + (initDiagOpts dflags) (supportedLanguagesAndExtensions arch_os) (safeImportsOn dflags) False -- lex Haddocks as comment tokens -- cgit v1.2.3 From c3df9283872dbba1ac8c1ffd1b7e7ef4a54dee7b Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Wed, 30 Jun 2021 15:13:08 +0200 Subject: Rename getErrorMessages Lexer import This commit renames the Lexer import in `Hyperlinker.Parser` from `getErrorMessages` to `getPsErrorMessages` to eliminate the ambiguity with the `getErrorMessages` function defined in `GHC.Types.Error`. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4e9099d8..3929c286 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -20,7 +20,7 @@ import GHC.Parser.Errors.Ppr () import qualified GHC.Types.Error as E import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) - , initParserState, lexer, mkParserOpts, getErrorMessages) + , initParserState, lexer, mkParserOpts, getPsErrorMessages) import GHC.Data.Bag ( bagToList ) import GHC.Utils.Outputable ( text, ($$) ) import GHC.Utils.Panic ( panic ) @@ -43,7 +43,7 @@ parse parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst -> - let err:_ = bagToList (E.getMessages $ getErrorMessages pst) in + let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in panic $ showSDoc dflags $ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where -- cgit v1.2.3 From 746df785f7dfd2fcb54d76b00eb0ee71e2abdc30 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Mon, 19 Apr 2021 19:40:16 +0200 Subject: Add Haddock support for the OPAQUE pragma --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3929c286..0658d493 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -238,6 +238,7 @@ classify tok = ITrequires -> TkKeyword ITinline_prag {} -> TkPragma + ITopaque_prag {} -> TkPragma ITspec_prag {} -> TkPragma ITspec_inline_prag {} -> TkPragma ITsource_prag {} -> TkPragma @@ -379,6 +380,7 @@ inPragma True _ = True inPragma False tok = case tok of ITinline_prag {} -> True + ITopaque_prag {} -> True ITspec_prag {} -> True ITspec_inline_prag {} -> True ITsource_prag {} -> True -- cgit v1.2.3 From 02803910c1d040222f0bfc5b62411119c443f3a1 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 9 Mar 2022 17:23:11 +0000 Subject: Minimum changes needed for compilation with hi-haddock With hi-haddock, of course there is a much large refactoring of haddock which could be achieved but that is left for a future patch which can implemented at any time independently of GHC. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 5 +- haddock-api/src/Haddock/GhcUtils.hs | 4 +- haddock-api/src/Haddock/Interface.hs | 4 +- .../src/Haddock/Interface/AttachInstances.hs | 4 +- haddock-api/src/Haddock/Interface/Create.hs | 96 +++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 12 ++- haddock-api/src/Haddock/Interface/Rename.hs | 7 +- 7 files changed, 79 insertions(+), 53 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3929c286..a218b118 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -355,10 +355,7 @@ classify tok = ITeof -> TkUnknown ITlineComment {} -> TkComment - ITdocCommentNext {} -> TkComment - ITdocCommentPrev {} -> TkComment - ITdocCommentNamed {} -> TkComment - ITdocSection {} -> TkComment + ITdocComment {} -> TkComment ITdocOptions {} -> TkComment -- The lexer considers top-level pragmas as comments (see `pragState` in diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3f97236a..9f9120fa 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -96,7 +96,7 @@ ifTrueJust True = Just ifTrueJust False = const Nothing sigName :: LSig GhcRn -> [IdP GhcRn] -sigName (L _ sig) = sigNameNoLoc sig +sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig -- | Was this signature given by the user? isUserLSig :: forall p. UnXRec p => LSig p -> Bool @@ -193,7 +193,7 @@ getMainDeclBinderI (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinderI (SigD _ d) = sigNameNoLoc d +getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 804367c4..19113107 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -146,7 +146,7 @@ createIfaces verbosity modules flags instIfaceMap = do let installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = - let + let old_plugins = hsc_plugins hsc_env new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins } hsc_env' = hsc_env { hsc_plugins = new_plugins } @@ -362,7 +362,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env ] where formatName :: SrcSpan -> HsDecl GhcRn -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of + formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index e8a79b2b..dc8afa31 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -136,12 +136,12 @@ attachToExportItem index expInfo getInstDoc getFixity export = , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder d + [ (n',f) | n <- getMainDeclBinder emptyOccEnv d , n' <- n : (map fst subDocs ++ patsyn_names) , f <- maybeToList (getFixity n') ] } where - patsyn_names = concatMap (getMainDeclBinder . fst) patsyns + patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4d746405..dbd4a9b2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -35,7 +35,7 @@ import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, pretty, restrictTo, sigName, unL) -import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) +import Haddock.Interface.LexParseRn import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) @@ -57,7 +57,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS) import GHC.Driver.Ppr (showSDoc) -import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) @@ -65,7 +65,7 @@ import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import GHC.Types.Basic (PromotionFlag (..)) -import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) +import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) @@ -79,6 +79,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic) import GHC.Unit.Module.Warnings +import GHC.Types.Unique.Map newtype IfEnv m = IfEnv { @@ -255,7 +256,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name - tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr)) + tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) @@ -405,7 +406,7 @@ lookupModuleDyn state pkg_qual mdlName = case pkg_qual of -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap +mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> pure M.empty WarnAll _ -> pure M.empty @@ -416,18 +417,18 @@ mkWarningMap dflags warnings gre exps = case warnings of , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name)) moduleWarning _ _ NoWarnings = pure Nothing moduleWarning _ _ (WarnSome _) = pure Nothing moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x) - <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) + <$> processDocStringFromString dflags gre bs ------------------------------------------------------------------------------- @@ -479,7 +480,7 @@ mkMaps :: DynFlags -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] - -> [(LHsDecl GhcRn, [HsDocString])] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps mkMaps dflags pkgName gre instances decls thDocs = do @@ -512,36 +513,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do thMappings = do let ExtractedTHDocs _ - (DeclDocMap declDocs) - (ArgDocMap argDocs) - (DeclDocMap instDocs) = thDocs - ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name) - ds2mdoc = processDocStringParas dflags pkgName gre - - declDocs' <- mapM ds2mdoc declDocs - argDocs' <- mapM (mapM ds2mdoc) argDocs - instDocs' <- mapM ds2mdoc instDocs + declDocs + argDocs + instDocs = thDocs + ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name) + ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString + + let cvt = M.fromList . nonDetEltsUniqMap + + declDocs' <- mapM ds2mdoc (cvt declDocs) + argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs) + instDocs' <- mapM ds2mdoc (cvt instDocs) return (declDocs' <> instDocs', argDocs') - mappings :: (LHsDecl GhcRn, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do - let declDoc :: [HsDocString] -> IntMap HsDocString + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do + let docStrs = map hsDocString hs_docStrs + declDoc :: [HsDocString] -> IntMap HsDocString -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (declTypeDocs decl) + (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl)) let subs :: [(Name, [HsDocString], IntMap HsDocString)] - subs = subordinates instanceMap decl + subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im)) + $ subordinates emptyOccEnv instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs @@ -572,7 +577,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. - names _ decl = getMainDeclBinder decl + names _ decl = getMainDeclBinder emptyOccEnv decl + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. + +unionArgMaps :: forall b . Map Name (IntMap b) + -> Map Name (IntMap b) + -> Map Name (IntMap b) +unionArgMaps a b = M.foldrWithKey go b a + where + go :: Name -> IntMap b + -> Map Name (IntMap b) -> Map Name (IntMap b) + go n newArgMap acc + | Just oldArgMap <- M.lookup n acc = + M.insert n (newArgMap `IM.union` oldArgMap) acc + | otherwise = M.insert n newArgMap acc -- Note [2]: ------------ @@ -634,11 +655,11 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do - doc <- processDocString dflags gre docStr + doc <- processDocString dflags gre (hsDocString . unLoc $ docStr) return [ExportGroup lev "" doc] lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags pkgName gre docStr + doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ @@ -706,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) + let declNames = getMainDeclBinder emptyOccEnv (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its @@ -785,7 +806,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let patSynNames = - concatMap (getMainDeclBinder . fst) bundledPatSyns + concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns fixities = [ (n, f) @@ -1007,17 +1028,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam (concat . concat) `fmap` (for decls $ \decl -> do case decl of (L _ (DocD _ (DocGroup lev docStr))) -> do - doc <- liftErrMsg (processDocString dflags gre docStr) + doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr)) return [[ExportGroup lev "" doc]] (L _ (DocD _ (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) + doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> - for (getMainDeclBinder (unLoc decl)) $ \nm -> do + for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail -> availExportItem is_sig modMap thisMod @@ -1042,7 +1063,7 @@ extractDecl -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl - | name `elem` getMainDeclBinder (unLoc decl) = pure decl + | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl | otherwise = case unLoc decl of TyClD _ d@ClassDecl { tcdLName = L _ clsNm @@ -1197,10 +1218,10 @@ mkVisibleNames (_, _, _, instMap) exports opts where exportName e@ExportDecl {} = name ++ subs ++ patsyns where subs = map fst (expItemSubDocs e) - patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap - decl -> getMainDeclBinder decl + decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1217,6 +1238,7 @@ findNamedDoc name = search tell ["Cannot find documentation for: $" ++ name] return Nothing search (DocD _ (DocCommentNamed name' doc) : rest) - | name == name' = return (Just doc) + | name == name' = return (Just (hsDocString . unLoc $ doc)) + | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index a827cf66..f3b57792 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn ( processDocString + , processDocStringFromString , processDocStringParas , processDocStrings , processModuleHeader @@ -38,6 +39,7 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Trace processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags pkg gre hds = - overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds) + overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre hds = - rename dflags gre $ parseString dflags (unpackHDS hds) + processDocStringFromString dflags gre (renderHsDocString hds) + +processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name) +processDocStringFromString dflags gre hds = + rename dflags gre $ parseString dflags hds processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do case mayStr of Nothing -> return failure Just hds -> do - let str = unpackHDS hds + let str = renderHsDocString hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 98c39859..f2b3a9fa 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -renameLDocHsSyn = return +renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b)) +renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) @@ -317,6 +317,7 @@ renameType t = case t of HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy _ -> pure (HsWildCardTy noAnn) + renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do bndrs' <- renameOuterTyVarBndrs bndrs @@ -511,7 +512,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameH98Details details - mbldoc' <- mapM renameLDocHsSyn mbldoc + mbldoc' <- mapM (renameLDocHsSyn) mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_forall = forall_ -- Remove when #18311 is fixed -- cgit v1.2.3 From fb0e9bac0a5297f995b151f25aa1ce3e622e12ea Mon Sep 17 00:00:00 2001 From: Jakob Brünker Date: Sun, 27 Mar 2022 12:03:12 +0000 Subject: Add support for \cases See merge request ghc/ghc!7873 --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 76ae5be3..9f28d72a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -269,6 +269,7 @@ classify tok = ITequal -> TkGlyph ITlam -> TkGlyph ITlcase -> TkGlyph + ITlcases -> TkGlyph ITvbar -> TkGlyph ITlarrow {} -> TkGlyph ITrarrow {} -> TkGlyph -- cgit v1.2.3 From 2036454bf6a86e14d9da9da5a19ce49ff3975fd7 Mon Sep 17 00:00:00 2001 From: Jade Lovelace Date: Sat, 7 May 2022 08:42:08 -0700 Subject: Fix hyperlinks to external items and modules (#1482) Fixes #1481. There were two bugs in this: * We were assuming that we were always getting a relative path to the module in question, while Nix gives us file:// URLs sometimes. This change checks for those and stops prepending `..` to them. * We were not linking to the file under the module. This seems to have been a regression introduced by #977. That is, the URLs were going to something like file:///nix/store/3bwbsy0llxxn1pixx3ll02alln56ivxy-ghc-9.0.2-doc/share/doc/ghc/html/libraries/base-4.15.1.0/src which does not have the appropriate HTML file or fragment for the item in question at the end. There is a remaining instance of the latter bug, but not in the hyperlinker: the source links to items reexported from other modules are also not including the correct file name. e.g. the reexport of Entity in esqueleto, from persistent. NOTE: This needs to get tested with relative-path located modules. It seems correct for Nix based on my testing. Testing strategy: ``` nix-shell '' --pure -A haskell.packages.ghc922.aeson mkdir /tmp/aesonbuild && cd /tmp/aesonbuild export out=/tmp/aesonbuild/out genericBuild ln -sf $HOME/co/haddock/haddock-api/resources . ./Setup haddock --with-haddock=$HOME/path/to/haddock/exec --hyperlink-source ``` (cherry picked from commit ab53ccf089ea703b767581ac14be0f6c78a7678a) --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 12f37ced..d77990d1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -24,6 +24,7 @@ import System.FilePath.Posix (()) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.List as List import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html @@ -249,14 +250,20 @@ hyperlink (srcs, srcs') ident = case ident of Left name -> externalModHyperlink name where + -- In a Nix environment, we have file:// URLs with absolute paths + makeHyperlinkUrl url | List.isPrefixOf "file://" url = url + makeHyperlinkUrl url = ".." url + internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." path) ] + Just (SrcExternal path) -> + let hyperlinkUrl = makeHyperlinkUrl path hypSrcModuleNameUrl mdl name + in Html.anchor content ! + [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ] Nothing -> content where mdl = nameModule name @@ -265,8 +272,10 @@ hyperlink (srcs, srcs') ident = case ident of case Map.lookup moduleName srcs' of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleUrl' moduleName ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." path) ] + Just (SrcExternal path) -> + let hyperlinkUrl = makeHyperlinkUrl path hypSrcModuleUrl' moduleName + in Html.anchor content ! + [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ] Nothing -> content -- cgit v1.2.3