Merge pull request #1319 from alexbiehl/alex/compat

Backward compat: Add support for labeled module references

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` ()