aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal1
-rw-r--r--haddock-api/resources/html/quick-jump.css1
-rw-r--r--haddock-api/src/Haddock.hs36
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs9
-rw-r--r--haddock-api/src/Haddock/Interface.hs22
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs2
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs43
-rw-r--r--haddock-api/src/Haddock/Types.hs3
16 files changed, 100 insertions, 56 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 52191e13..e6de8b81 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -190,6 +190,7 @@ test-suite spec
, containers
, deepseq
, directory
+ , exceptions
, filepath
, ghc-boot
, transformers
diff --git a/haddock-api/resources/html/quick-jump.css b/haddock-api/resources/html/quick-jump.css
index d656f51c..cf10eee4 100644
--- a/haddock-api/resources/html/quick-jump.css
+++ b/haddock-api/resources/html/quick-jump.css
@@ -15,7 +15,6 @@
left: calc(50% - 22em);
width: 44em;
z-index: 1000;
- pointer-events: none;
overflow-y: auto;
}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 2b6e2d57..49a63604 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -185,12 +185,13 @@ haddockWithGhc ghc args = handleTopExceptions $ do
ghc flags' $ withDir $ do
dflags <- getDynFlags
+ logger <- getLogger
unit_state <- hsc_units <$> getSession
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
- logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile))
+ putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -203,7 +204,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces
+ liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -213,7 +214,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags unit_state flags sinceQual qual packages []
+ liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -262,9 +263,9 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
+renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
-> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
@@ -273,12 +274,12 @@ renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
((_, Just path), ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
+render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
+render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -368,7 +369,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
let withQuickjump = Flag_QuickJumpIndex `elem` flags
when (Flag_GenIndex `elem` flags) $ do
- withTiming dflags' "ppHtmlIndex" (const ()) $ do
+ withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
_ <- {-# SCC ppHtmlIndex #-}
ppHtmlIndex odir title pkgStr
themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
@@ -378,7 +379,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
copyHtmlBits odir libDir themes withQuickjump
when (Flag_GenContents `elem` flags) $ do
- withTiming dflags' "ppHtmlContents" (const ()) $ do
+ withTiming logger dflags' "ppHtmlContents" (const ()) $ do
_ <- {-# SCC ppHtmlContents #-}
ppHtmlContents unit_state odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
@@ -388,7 +389,7 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
copyHtmlBits odir libDir themes withQuickjump
when (Flag_Html `elem` flags) $ do
- withTiming dflags' "ppHtml" (const ()) $ do
+ withTiming logger dflags' "ppHtml" (const ()) $ do
_ <- {-# SCC ppHtml #-}
ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
prologue
@@ -423,14 +424,14 @@ render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap =
]
when (Flag_LaTeX `elem` flags) $ do
- withTiming dflags' "ppLatex" (const ()) $ do
+ withTiming logger dflags' "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 dflags' "ppHyperlinkedSource" (const ()) $ do
+ withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do
_ <- {-# SCC ppHyperlinkedSource #-}
ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
return ()
@@ -469,7 +470,8 @@ readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
-- compilation and linking. Then run the given 'Ghc' action.
withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a
withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
- dynflags' <- parseGhcFlags =<< getSessionDynFlags
+ logger <- getLogger
+ dynflags' <- parseGhcFlags logger =<< getSessionDynFlags
-- We disable pattern match warnings because than can be very
-- expensive to check
@@ -493,8 +495,8 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
go arg func True = arg : func True
- parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
- parseGhcFlags dynflags = do
+ parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
+ parseGhcFlags logger dynflags = do
-- TODO: handle warnings?
let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
@@ -506,7 +508,7 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
}
flags' = filterRtsFlags flags
- (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags')
+ (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags')
if not (null rest)
then throwE ("Couldn't parse GHC options: " ++ unwords flags')
else return dynflags''
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 3bf12477..f7e1c77b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -35,7 +35,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import GHC.Unit.State
import Data.Char
-import Data.List
+import Data.List (intercalate, isPrefixOf)
import Data.Maybe
import Data.Version
@@ -343,7 +343,7 @@ markupTag dflags = Markup {
markupAppend = (++),
markupIdentifier = box (TagInline "a") . str . out dflags,
markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),
- markupModule = box (TagInline "a") . str,
+ markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label),
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
markupBold = box (TagInline "b"),
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 8ecc185b..d85a3970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -18,7 +18,7 @@ import Data.Maybe
import System.Directory
import System.FilePath
-import GHC.Iface.Ext.Types
+import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc )
import Data.Map as M
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 5b27847e..df1f94e6 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1241,7 +1241,12 @@ latexMarkup = Markup
, markupAppend = \l r v -> l v . r v
, markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i))
, markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i))
- , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl)))
+ , markupModule =
+ \(ModLink m mLabel) v ->
+ case mLabel of
+ Just lbl -> inlineElem . tt $ lbl v empty
+ Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m
+ in (tt (text mdl)))
, markupWarning = \p v -> p v
, markupEmphasis = \p v -> inlineElem (emph (p v empty))
, markupBold = \p v -> inlineElem (bold (p v empty))
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 378d0559..7670b193 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupAppend = (+++),
markupIdentifier = thecode . ppId insertAnchors,
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
- markupModule = \m -> let (mdl,ref) = break (=='#') m
- -- Accomodate for old style
- -- foo\#bar anchors
- mdl' = case reverse mdl of
- '\\':_ -> init mdl
- _ -> mdl
- in ppModuleRef (mkModuleName mdl') ref,
+ markupModule = \(ModLink m lbl) ->
+ let (mdl,ref) = break (=='#') m
+ -- Accomodate for old style
+ -- foo\#bar anchors
+ mdl' = case reverse mdl of
+ '\\':_ -> init mdl
+ _ -> mdl
+ in ppModuleRef lbl (mkModuleName mdl') ref,
markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupBold = strong,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 8553cdfb..b324fa38 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)]
<< toHtml (moduleString mdl)
-ppModuleRef :: ModuleName -> String -> Html
-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
- << toHtml (moduleNameString mdl)
+ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
+ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << toHtml (moduleNameString mdl)
+ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << lbl
+
-- NB: The ref parameter already includes the '#'.
-- This function is only called from markupModule expanding a
-- DocModule, which doesn't seem to be ever be used.
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index fa1f3ee5..b4c20b99 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -59,15 +59,15 @@ import GHC.Data.Graph.Directed
import GHC.Driver.Session hiding (verbosity)
import GHC hiding (verbosity)
import GHC.Driver.Env
-import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
+import GHC.Driver.Monad
import GHC.Data.FastString (unpackFS)
+import GHC.Utils.Error
import GHC.Tc.Types (TcM, TcGblEnv(..))
import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
import GHC.Tc.Utils.Env (tcLookupGlobal)
import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
-import GHC.Utils.Error (withTimingD)
import GHC.HsToCore.Docs
import GHC.Runtime.Loader (initializePlugins)
import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..),
@@ -113,7 +113,7 @@ processModules verbosity modules flags extIfaces = do
mods = Set.fromList $ map ifaceMod interfaces
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
- withTimingD "attachInstances" (const ()) $ do
+ withTimingM "attachInstances" (const ()) $ do
attachInstances (exportedNames, mods) interfaces instIfaceMap ms
out verbosity verbose "Building cross-linking environment..."
@@ -161,7 +161,7 @@ createIfaces verbosity modules flags instIfaceMap = do
targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
setTargets targets
- loadOk <- withTimingD "load" (const ()) $
+ loadOk <- withTimingM "load" (const ()) $
{-# SCC load #-} GHC.load LoadAllTargets
case loadOk of
@@ -212,7 +212,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do
| otherwise = do
hsc_env <- getTopEnv
ifaces <- liftIO $ readIORef ifaceMapRef
- (iface, modules) <- withTimingD "processModule" (const ()) $
+ (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)
+ "processModule" (const ()) $
processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
liftIO $ do
@@ -263,8 +264,11 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
unit_state = hsc_units hsc_env
- (!interface, messages) <- {-# SCC createInterface #-}
- withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+ (!interface, messages) <- do
+ logger <- getLogger
+ dflags <- getDynFlags
+ {-# SCC createInterface #-}
+ withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
createInterface1 flags unit_state mod_summary tc_gbl_env
ifaces inst_ifaces
@@ -291,8 +295,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
ifaceHaddockCoverage interface
percentage :: Int
- percentage =
- round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)
+ percentage = div (haddocked * 100) haddockable
modString :: String
modString = moduleString (ifaceMod interface)
@@ -365,4 +368,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
mdl = ifaceMod iface
keep_old env n = Map.insertWith (\_ old -> old) n mdl env
keep_new env n = Map.insert n mdl env
-
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 6ef0ed19..317258eb 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -127,9 +127,8 @@ attachToExportItem index expInfo getInstDoc getFixity export =
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]
in do
- dfs <- getDynFlags
let mkBug = (text "haddock-bug:" <+>) . text
- liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)
+ putMsgM (sep $ map mkBug famInstErrs)
return $ cls_insts ++ cleanFamInsts
return $ e { expItemInstances = insts }
e -> return e
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 72f1ab62..9a773b6c 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -727,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Just synifiedDecl -> pure synifiedDecl
Nothing -> pprPanic "availExportItem" (O.text err)
- availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
+ availExportDecl :: AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> IfM m [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 9b80d98f..92fb2e75 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -98,9 +98,9 @@ jsonDoc (DocIdentifierUnchecked modName) = jsonObject
, ("modName", jsonString (showModName modName))
]
-jsonDoc (DocModule s) = jsonObject
+jsonDoc (DocModule (ModLink m _l)) = jsonObject
[ ("tag", jsonString "DocModule")
- , ("string", jsonString s)
+ , ("string", jsonString m)
]
jsonDoc (DocWarning x) = jsonObject
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 2df2bbbf..6da89e7c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -150,7 +150,7 @@ rename dflags gre = rn
DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
- DocModule str -> pure (DocModule str)
+ DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l
DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index c6d61d05..f37e1da9 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -345,7 +345,7 @@ renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr fla
renameLBinder = located renameBinder
-- | Core renaming logic.
-renameName :: (Eq name, SetName name) => name -> Rename name name
+renameName :: SetName name => name -> Rename name name
renameName name = do
RenameEnv { .. } <- get
case Map.lookup (getName name) rneCtx of
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 9c34da54..95bfc903 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -46,7 +46,6 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique
-
data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv,
ifInstalledIfaces :: [InstalledInterface]
@@ -69,6 +68,18 @@ ifUnitId if_ =
binaryInterfaceMagic :: Word32
binaryInterfaceMagic = 0xD0Cface
+-- Note [The DocModule story]
+--
+-- Breaking changes to the DocH type result in Haddock being unable to read
+-- existing interfaces. This is especially painful for interfaces shipped
+-- with GHC distributions since there is no easy way to regenerate them!
+--
+-- PR #1315 introduced a breaking change to the DocModule constructor. To
+-- maintain backward compatibility we
+--
+-- Parse the old DocModule constructor format (tag 5) and parse the contained
+-- string into a proper ModLink structure. When writing interfaces we exclusively
+-- use the new DocModule format (tag 24)
-- IMPORTANT: Since datatypes in the GHC API might change between major
-- versions, and because we store GHC datatypes in our interface files, we need
@@ -87,7 +98,7 @@ binaryInterfaceVersion :: Word16
binaryInterfaceVersion = 38
binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
+binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion]
#else
#error Unsupported GHC version
#endif
@@ -159,7 +170,7 @@ writeInterfaceFile filename iface = do
type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m
+nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m
nameCacheFromGhc = ( read_from_session , write_to_session )
where
read_from_session = do
@@ -444,6 +455,15 @@ instance Binary a => Binary (Hyperlink a) where
label <- get bh
return (Hyperlink url label)
+instance Binary a => Binary (ModLink a) where
+ put_ bh (ModLink m label) = do
+ put_ bh m
+ put_ bh label
+ get bh = do
+ m <- get bh
+ label <- get bh
+ return (ModLink m label)
+
instance Binary Picture where
put_ bh (Picture uri title) = do
put_ bh uri
@@ -522,9 +542,6 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
put_ bh (DocIdentifier ae) = do
putByte bh 4
put_ bh ae
- put_ bh (DocModule af) = do
- putByte bh 5
- put_ bh af
put_ bh (DocEmphasis ag) = do
putByte bh 6
put_ bh ag
@@ -579,6 +596,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
put_ bh (DocTable x) = do
putByte bh 23
put_ bh x
+ -- See note [The DocModule story]
+ put_ bh (DocModule af) = do
+ putByte bh 24
+ put_ bh af
get bh = do
h <- getByte bh
@@ -598,9 +619,13 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
4 -> do
ae <- get bh
return (DocIdentifier ae)
+ -- See note [The DocModule story]
5 -> do
af <- get bh
- return (DocModule af)
+ return $ DocModule ModLink
+ { modLinkName = af
+ , modLinkLabel = Nothing
+ }
6 -> do
ag <- get bh
return (DocEmphasis ag)
@@ -655,6 +680,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
23 -> do
x <- get bh
return (DocTable x)
+ -- See note [The DocModule story]
+ 24 -> do
+ af <- get bh
+ return (DocModule af)
_ -> error "invalid binary data found in the interface file"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 7fd11d69..83c9dd72 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -510,6 +510,9 @@ instance NFData id => NFData (Header id) where
instance NFData id => NFData (Hyperlink id) where
rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
+instance NFData id => NFData (ModLink id) where
+ rnf (ModLink a b) = a `deepseq` b `deepseq` ()
+
instance NFData Picture where
rnf (Picture a b) = a `deepseq` b `deepseq` ()
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 23:15:31 +0000