hi haddock: Lex and store haddock docs in interface fileswip/hi-haddock2021

Names appearing in Haddock docstrings are lexed and renamed like any other names
appearing in the AST. We currently rename names irrespective of the namespace,
so both type and constructor names corresponding to an identifier will appear in
the docstring. Haddock will select a given name as the link destination based on
its own heuristics.

This patch also restricts the limitation of `-haddock` being incompatible with
`Opt_KeepRawTokenStream`.

The export and documenation structure is now computed in GHC and serialised in
.hi files. This can be used by haddock to directly generate doc pages without
reparsing or renaming the source. At the moment the operation of haddock
is not modified, that's left to a future patch.

Updates the haddock submodule with the minimum changes needed.

8 files changed, 111 insertions, 68 deletions

diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index 079bbd5df5..fcae57f975 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -73,14 +73,18 @@ import GHC.Tc.Solver.Monad ( runTcSEarlyAbort )
 import GHC.Tc.Utils.Unify ( tcSubTypeSigma )
 
 import GHC.HsToCore.Docs ( extractDocs )
-import qualified Data.Map as Map
-import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )
+import GHC.Hs.Doc
 import GHC.Unit.Module.ModIface ( ModIface_(..) )
-import GHC.Iface.Load  ( loadInterfaceForNameMaybe )
+import GHC.Iface.Load  ( loadInterfaceForName )
 
 import GHC.Builtin.Utils (knownKeyNames)
 
 import GHC.Tc.Errors.Hole.FitTypes
+import qualified Data.Set as Set
+import GHC.Types.SrcLoc
+import GHC.Utils.Trace (warnPprTrace)
+import GHC.Data.FastString (unpackFS)
+import GHC.Types.Unique.Map
 
 
 {-
@@ -456,21 +460,40 @@ addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]
 addHoleFitDocs fits =
   do { showDocs <- goptM Opt_ShowDocsOfHoleFits
      ; if showDocs
-       then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs
-               ; mapM (upd lclDocs) fits }
+       then do { dflags <- getDynFlags
+               ; mb_local_docs <- extractDocs dflags =<< getGblEnv
+               ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits
+               ; report mods_without_docs
+               ; return fits' }
        else return fits }
   where
    msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"
-   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
-     = Map.lookup name dmap
-   upd lclDocs fit@(HoleFit {hfCand = cand}) =
-        do { let name = getName cand
-           ; doc <- if hfIsLcl fit
-                    then pure (Map.lookup name lclDocs)
-                    else do { mbIface <- loadInterfaceForNameMaybe msg name
-                            ; return $ mbIface >>= lookupInIface name }
-           ; return $ fit {hfDoc = doc} }
-   upd _ fit = return fit
+   upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) =
+     let name = getName cand in
+     do { mb_docs <- if hfIsLcl fit
+                     then pure mb_local_docs
+                     else mi_docs <$> loadInterfaceForName msg name
+        ; case mb_docs of
+            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit)
+            ; Just docs -> do
+                { let doc = lookupUniqMap (docs_decls docs) name
+                ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}}
+   upd _ mods_without_docs fit = pure (mods_without_docs, fit)
+   nameOrigin name = case nameModule_maybe name of
+     Just m  -> Right m
+     Nothing ->
+       Left $ case nameSrcLoc name of
+         RealSrcLoc r _ -> unpackFS $ srcLocFile r
+         UnhelpfulLoc s -> unpackFS $ s
+   report mods = do
+     { let warning =
+             text "WARNING: Couldn't find any documentation for the following modules:" $+$
+             nest 2
+                  (fsep (punctuate comma
+                                   (either text ppr <$> Set.toList mods)) $+$
+                   text "Make sure the modules are compiled with '-haddock'.")
+     ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ())
+     }
 
 -- For pretty printing hole fits, we display the name and type of the fit,
 -- with added '_' to represent any extra arguments in case of a non-zero
@@ -517,9 +540,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
                                      then occDisp <+> tyApp
                                      else tyAppVars
        docs = case hfDoc of
-                Just d -> text "{-^" <>
-                          (vcat . map text . lines . unpackHDS) d
-                          <> text "-}"
+                Just d -> pprHsDocStrings d
                 _ -> empty
        funcInfo = ppWhen (has hfMatches && sTy) $
                     text "where" <+> occDisp <+> tyDisp
diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
index 077bdaab18..72cb54bec2 100644
--- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
+++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs
@@ -87,7 +87,7 @@ data HoleFit =
           , hfWrap :: [TcType] -- ^ The wrapper for the match.
           , hfMatches :: [TcType]
           -- ^ What the refinement variables got matched with, if anything
-          , hfDoc :: Maybe HsDocString
+          , hfDoc :: Maybe [HsDocString]
           -- ^ Documentation of this HoleFit, if available.
           }
  | RawHoleFit SDoc
diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot
index c6141d8897..8943c3f0a2 100644
--- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot
+++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot
@@ -25,6 +25,6 @@ data HoleFit =
           , hfRefLvl :: Int
           , hfWrap :: [TcType]
           , hfMatches :: [TcType]
-          , hfDoc :: Maybe HsDocString
+          , hfDoc :: Maybe [HsDocString]
           }
  | RawHoleFit SDoc
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 2055b3101c..26b765a9d1 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -44,6 +44,7 @@ import Control.Monad
 import GHC.Driver.Session
 import GHC.Parser.PostProcess ( setRdrNameSpace )
 import Data.Either            ( partitionEithers )
+import GHC.Rename.Doc
 
 {-
 ************************************************************************
@@ -316,12 +317,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                             , ( L loc (IEModuleContents noExtField lmod)
                               , new_exports))) }
 
-    exports_from_item acc@(ExportAccum occs mods) (L loc ie)
-        | Just new_ie <- lookup_doc_ie ie
-        = return (Just (acc, (L loc new_ie, [])))
-
-        | otherwise
-        = do (new_ie, avail) <- lookup_ie ie
+    exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do
+        m_new_ie <- lookup_doc_ie ie
+        case m_new_ie of
+          Just new_ie -> return (Just (acc, (L loc new_ie, [])))
+          Nothing -> do
+             (new_ie, avail) <- lookup_ie ie
              if isUnboundName (ieName new_ie)
                   then return Nothing    -- Avoid error cascade
                   else do
@@ -396,11 +397,15 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
              return (L (locA l) name, non_flds, flds)
 
     -------------
-    lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn)
-    lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc)
-    lookup_doc_ie (IEDoc _ doc)       = Just (IEDoc noExtField doc)
-    lookup_doc_ie (IEDocNamed _ str)  = Just (IEDocNamed noExtField str)
-    lookup_doc_ie _ = Nothing
+    lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))
+    lookup_doc_ie (IEGroup _ lev doc) = do
+      doc' <- rnLHsDoc doc
+      pure $ Just (IEGroup noExtField lev doc')
+    lookup_doc_ie (IEDoc _ doc)       = do
+      doc' <- rnLHsDoc doc
+      pure $ Just (IEDoc noExtField doc')
+    lookup_doc_ie (IEDocNamed _ str)  = pure $ Just (IEDocNamed noExtField str)
+    lookup_doc_ie _ = pure Nothing
 
     -- In an export item M.T(A,B,C), we want to treat the uses of
     -- A,B,C as if they were M.A, M.B, M.C
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index c42dd689fa..6860eba567 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -10,6 +10,7 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -110,6 +111,7 @@ import GHC.Types.Error
 import GHC.Types.Fixity as Hs
 import GHC.Types.Annotations
 import GHC.Types.Name
+import GHC.Types.Unique.Map
 import GHC.Serialized
 
 import GHC.Unit.Finder
@@ -154,6 +156,9 @@ import qualified Data.Map as Map
 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
 import Data.Data (Data)
 import Data.Proxy    ( Proxy (..) )
+import GHC.Parser.HaddockLex (lexHsDoc)
+import GHC.Parser (parseIdentifier)
+import GHC.Rename.Doc (rnHsDoc)
 
 {-
 ************************************************************************
@@ -1307,7 +1312,10 @@ instance TH.Quasi TcM where
     unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text
       "Can't add documentation to" <+> ppr_loc doc_loc <+>
       text "as it isn't inside the current module"
-    updTcRef th_doc_var (Map.insert resolved_doc_loc s)
+    let ds = mkGeneratedHsDocString s
+        hd = lexHsDoc parseIdentifier ds
+    hd' <- rnHsDoc hd
+    updTcRef th_doc_var (Map.insert resolved_doc_loc hd')
     where
       resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n
       resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i
@@ -1331,40 +1339,41 @@ instance TH.Quasi TcM where
   qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
   qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
   qGetDoc TH.ModuleDoc = do
-    (moduleDoc, _, _) <- getGblEnv >>= extractDocs
-    return (fmap unpackHDS moduleDoc)
+    df <- getDynFlags
+    docs <- getGblEnv >>= extractDocs df
+    return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
 
 -- | Looks up documentation for a declaration in first the current module,
 -- otherwise tries to find it in another module via 'hscGetModuleInterface'.
 lookupDeclDoc :: Name -> TcM (Maybe String)
 lookupDeclDoc nm = do
-  (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs
-  fam_insts <- tcg_fam_insts <$> getGblEnv
-  traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)
-  case Map.lookup nm declDocs of
-    Just doc -> pure $ Just (unpackHDS doc)
+  df <- getDynFlags
+  Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df
+  case lookupUniqMap docs_decls nm of
+    Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc)
     Nothing -> do
       -- Wasn't in the current module. Try searching other external ones!
       mIface <- getExternalModIface nm
       case mIface of
-        Nothing -> pure Nothing
-        Just ModIface { mi_decl_docs = DeclDocMap dmap } ->
-          pure $ unpackHDS <$> Map.lookup nm dmap
+        Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->
+          pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm
+        _ -> pure Nothing
 
 -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If
 -- it can't find any documentation for a function in this module, it tries to
 -- find it in another module.
 lookupArgDoc :: Int -> Name -> TcM (Maybe String)
 lookupArgDoc i nm = do
-  (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs
-  case Map.lookup nm argDocs of
-    Just m -> pure $ unpackHDS <$> IntMap.lookup i m
+  df <- getDynFlags
+  Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df
+  case lookupUniqMap argDocs nm of
+    Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m
     Nothing -> do
       mIface <- getExternalModIface nm
       case mIface of
-        Nothing -> pure Nothing
-        Just ModIface { mi_arg_docs = ArgDocMap amap } ->
-          pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)
+        Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->
+          pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)
+        _ -> pure Nothing
 
 -- | Returns the module a Name belongs to, if it is isn't local.
 getExternalModIface :: Name -> TcM (Maybe ModIface)
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index dca5bce99e..e690d1e5a2 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -95,6 +95,7 @@ import GHC.Rename.Fixity ( lookupFixityRn )
 import GHC.Rename.Names
 import GHC.Rename.Env
 import GHC.Rename.Module
+import GHC.Rename.Doc
 
 import GHC.Iface.Syntax   ( ShowSub(..), showToHeader )
 import GHC.Iface.Type     ( ShowForAllFlag(..) )
@@ -292,22 +293,23 @@ tcRnModuleTcRnM hsc_env mod_sum
           tcg_env <- {-# SCC "tcRnImports" #-}
                      tcRnImports hsc_env all_imports
 
-       ;  -- Don't need to rename the Haddock documentation,
-          -- it's not parsed by GHC anymore.
-          -- Make sure to do this before 'tcRnSrcDecls', because we need the
-          -- module header when we're splicing TH, since it can be accessed via
-          -- 'getDoc'.
-          tcg_env <- return (tcg_env
-                              { tcg_doc_hdr = maybe_doc_hdr })
-
+        -- Put a version of the header without identifier info into the tcg_env
+        -- Make sure to do this before 'tcRnSrcDecls', because we need the
+        -- module header when we're splicing TH, since it can be accessed via
+        -- 'getDoc'.
+        -- We will rename it properly after renaming everything else so that
+        -- haddock can link the identifiers
+        ; tcg_env <- return (tcg_env
+                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])
+                                                                                 <$> maybe_doc_hdr })
         ; -- If the whole module is warned about or deprecated
           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
-          let { tcg_env1 = case mod_deprec of
-                             Just (L _ txt) ->
-                               tcg_env {tcg_warns = WarnAll txt}
-                             Nothing            -> tcg_env
-              }
+        ; tcg_env1 <- case mod_deprec of
+                             Just (L _ txt) -> do { txt' <- rnWarningTxt txt
+                                                  ; pure $ tcg_env {tcg_warns = WarnAll txt'}
+                                                  }
+                             Nothing            -> pure tcg_env
         ; setGblEnv tcg_env1
           $ do { -- Rename and type check the declarations
                  traceRn "rn1a" empty
@@ -337,11 +339,17 @@ tcRnModuleTcRnM hsc_env mod_sum
                         -- because the latter might add new bindings for
                         -- boot_dfuns, which may be mentioned in imported
                         -- unfoldings.
-                        -- Report unused names
+                      ; -- Report unused names
                         -- Do this /after/ typeinference, so that when reporting
                         -- a function with no type signature we can give the
                         -- inferred type
-                        reportUnusedNames tcg_env hsc_src
+                      ; reportUnusedNames tcg_env hsc_src
+
+                      -- Rename the module header properly after we have renamed everything else
+                      ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;
+                      ; tcg_env <- return (tcg_env
+                                            { tcg_doc_hdr = maybe_doc_hdr })
+
                       ; -- add extra source files to tcg_dependent_files
                         addDependentFiles src_files
                         -- Ensure plugins run with the same tcg_env that we pass in
@@ -3174,7 +3182,7 @@ runRenamerPlugin gbl_env hs_group = do
 -- exception/signal an error.
 type RenamedStuff =
         (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
-                Maybe LHsDocString))
+                Maybe (LHsDoc GhcRn)))
 
 -- | Extract the renamed information from TcGblEnv.
 getRenamedStuff :: TcGblEnv -> RenamedStuff
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 776d0f40fb..d837b629ec 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -591,7 +591,7 @@ data TcGblEnv
         tcg_binds     :: LHsBinds GhcTc,     -- Value bindings in this module
         tcg_sigs      :: NameSet,            -- ...Top-level names that *lack* a signature
         tcg_imp_specs :: [LTcSpecPrag],      -- ...SPECIALISE prags for imported Ids
-        tcg_warns     :: Warnings,           -- ...Warnings and deprecations
+        tcg_warns     :: (Warnings GhcRn), -- ...Warnings and deprecations
         tcg_anns      :: [Annotation],       -- ...Annotations
         tcg_tcs       :: [TyCon],            -- ...TyCons and Classes
         tcg_ksigs     :: NameSet,            -- ...Top-level TyCon names that *lack* a signature
@@ -601,7 +601,7 @@ data TcGblEnv
         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports
         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms
 
-        tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
+        tcg_doc_hdr   :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs
         tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the
                                              --  prog uses hpc instrumentation.
            -- NB. BangPattern is to fix a leak, see #15111
@@ -1873,4 +1873,4 @@ data DocLoc = DeclDoc Name
 
 -- | The current collection of docs that Template Haskell has built up via
 -- putDoc.
-type THDocs = Map DocLoc String
+type THDocs = Map DocLoc (HsDoc GhcRn)
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 7c270e39bd..993f458731 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -24,7 +24,7 @@ module GHC.Tc.Utils.Env(
         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupAxiom,
-        lookupGlobal, ioLookupDataCon,
+        lookupGlobal, lookupGlobal_maybe, ioLookupDataCon,
         addTypecheckedBinds,
 
         -- Local environment