Merge remote-tracking branch 'upstream/ghc-head' into ghc-head

13 files changed, 80 insertions, 38 deletions

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