aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.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/Json.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs41
-rw-r--r--haddock-api/src/Haddock/Types.hs3
8 files changed, 62 insertions, 21 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 58809f73..9a304030 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -325,7 +325,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/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df81fd6e..2371695f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1210,7 +1210,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/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 4e271602..95889a63 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 d1d6bb31..87210273 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -148,7 +148,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/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 35f21f6c..966901df 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -46,6 +46,8 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Types.Unique
+import Documentation.Haddock.Parser (parseModLink)
+
data InterfaceFile = InterfaceFile {
ifLinkEnv :: LinkEnv,
@@ -69,6 +71,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
@@ -84,10 +98,10 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0)
-binaryInterfaceVersion = 37
+binaryInterfaceVersion = 38
binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
+binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion]
#else
#error Unsupported GHC version
#endif
@@ -444,6 +458,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 +545,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 +599,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 +622,10 @@ 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 (parseModLink af)
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 aa76f8f6..53d01565 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -501,6 +501,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-11-11 20:07:41 +0000