summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Errors/Hole.hs57
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs2
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot2
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs27
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs43
-rw-r--r--compiler/GHC/Tc/Module.hs40
-rw-r--r--compiler/GHC/Tc/Types.hs6
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs2
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
View Lorry Controller Status