aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authoralexbiehl-gc <72160047+alexbiehl-gc@users.noreply.github.com>2021-02-07 18:39:59 +0100
committerGitHub <noreply@github.com>2021-02-07 18:39:59 +0100
commit786d3e69799398c3aac26fbd5017a127bc69cacc (patch)
tree883ee3f8c0e195299925b790cba6f88a537200f6 /haddock-api/src/Haddock
parente90e79815960823a749287968fb1c6d09559a67f (diff)
parent0f7ff041fb824653a7930e1292b81f34df1e967d (diff)
Merge branch 'ghc-head' into ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs126
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs22
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs109
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs5
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs141
-rw-r--r--haddock-api/src/Haddock/Convert.hs120
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs265
-rw-r--r--haddock-api/src/Haddock/Interface.hs315
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs684
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs23
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs100
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs97
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs4
-rw-r--r--haddock-api/src/Haddock/Options.hs21
-rw-r--r--haddock-api/src/Haddock/Parser.hs5
-rw-r--r--haddock-api/src/Haddock/Syb.hs17
-rw-r--r--haddock-api/src/Haddock/Types.hs99
-rw-r--r--haddock-api/src/Haddock/Utils.hs3
21 files changed, 1260 insertions, 904 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9a304030..f7e1c77b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,8 +18,9 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..)
- , PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),
+ PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.SourceText
import GHC.Core.InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
import Haddock.GhcUtils
@@ -27,8 +28,11 @@ import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
import GHC
+import GHC.Driver.Ppr
import GHC.Utils.Outputable as Outputable
+import GHC.Utils.Panic
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.State
import Data.Char
import Data.List (intercalate, isPrefixOf)
@@ -37,15 +41,14 @@ import Data.Version
import System.Directory
import System.FilePath
-
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
,"-- See Hoogle, http://www.haskell.org/hoogle/"
,""]
-ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
let -- Since Hoogle is line based, we want to avoid breaking long lines.
dflags' = dflags{ pprCols = maxBound }
filename = package ++ ".txt"
@@ -54,42 +57,46 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
["@package " ++ package] ++
["@version " ++ showVersion version
| not (null (versionBranch version)) ] ++
- concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
+ppModule :: DynFlags -> UnitState -> Interface -> [String]
+ppModule dflags unit_state iface =
"" : ppDocumentation dflags (ifaceDoc iface) ++
["module " ++ moduleString (ifaceMod iface)] ++
concatMap (ppExport dflags) (ifaceExportItems iface) ++
- concatMap (ppInstance dflags) (ifaceInstances iface)
+ concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
---------------------------------------------------------------------
-- Utility functions
-dropHsDocTy :: HsType a -> HsType a
-dropHsDocTy = f
+dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p)
+dropHsDocTy = drop_sig_ty
where
- g (L src x) = L src (f x)
- f (HsForAllTy x a e) = HsForAllTy x a (g e)
- f (HsQualTy x a e) = HsQualTy x a (g e)
- f (HsBangTy x a b) = HsBangTy x a (g b)
- f (HsAppTy x a b) = HsAppTy x (g a) (g b)
- f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
- f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
- f (HsListTy x a) = HsListTy x (g a)
- f (HsTupleTy x a b) = HsTupleTy x a (map g b)
- f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
- f (HsParTy x a) = HsParTy x (g a)
- f (HsKindSig x a b) = HsKindSig x (g a) b
- f (HsDocTy _ a _) = f $ unLoc a
- f x = x
-
-outHsType :: (OutputableBndrId p)
- => DynFlags -> HsType (GhcPass p) -> String
-outHsType dflags = out dflags . reparenType . dropHsDocTy
+ drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b)
+ drop_sig_ty x@XHsSigType{} = x
+
+ drop_lty (L src x) = L src (drop_ty x)
+
+ drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
+ drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
+ drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
+ drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
+ drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
+ drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
+ drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
+ drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
+ drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+ drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
+ drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
+ drop_ty (HsDocTy _ a _) = drop_ty $ unL a
+ drop_ty x = x
+
+outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p)
+ => DynFlags -> HsSigType (GhcPass p) -> String
+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
dropComment :: String -> String
@@ -106,14 +113,14 @@ outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
f [] = []
out :: Outputable a => DynFlags -> a -> String
-out dflags = outWith $ showSDocUnqual dflags
+out dflags = outWith $ showSDoc dflags
operator :: String -> String
operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
operator x = x
commaSeparate :: Outputable a => DynFlags -> [a] -> String
-commaSeparate dflags = showSDocUnqual dflags . interpp'SP
+commaSeparate dflags = showSDoc dflags . interpp'SP
---------------------------------------------------------------------
-- How to print each export
@@ -133,8 +140,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
f (TyClD _ (FamDecl _ d)) = ppFam dflags d
- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
f (SigD _ sig) = ppSig dflags sig
f _ = []
@@ -143,8 +150,8 @@ ppExport _ _ = []
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags sig subdocs = case sig of
- TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names
- PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names
+ TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names
+ PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
_ -> []
where
mkDocSig leader typ n = mkSubdoc dflags n subdocs
@@ -153,9 +160,9 @@ ppSigWithDoc dflags sig subdocs = case sig of
ppSig :: DynFlags -> Sig GhcRn -> [String]
ppSig dflags x = ppSigWithDoc dflags x []
-pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String
+pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String
pp_sig dflags names (L _ typ) =
- operator prettyNames ++ " :: " ++ outHsType dflags typ
+ operator prettyNames ++ " :: " ++ outHsSigType dflags typ
where
prettyNames = intercalate ", " $ map (out dflags) names
@@ -173,7 +180,7 @@ ppClass dflags decl subdocs =
ppTyFams
| null $ tcdATs decl = ""
- | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
+ | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat
[ map pprTyFam (tcdATs decl)
, map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
]
@@ -198,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
_ -> decl
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x =
- [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]
+ppInstance dflags unit_state x =
+ [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]
where
-- As per #168, we don't want safety information about the class
-- in Hoogle output. The easiest way to achieve this is to set the
@@ -234,13 +241,13 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
_ -> []
ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
-ppCtor dflags dat subdocs con@ConDeclH98 {}
+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
-- AZ:TODO get rid of the concatMap
- = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
where
- f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
- f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
+ f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+ f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
+ f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
[(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
@@ -248,11 +255,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+ typeSig nm flds = operator nm ++ " :: " ++
+ outHsSigType dflags (unL $ mkEmptySigType $ funs flds)
-- We print the constructors as comma-separated list. See GHC
-- docs for con_names on why it is a list to begin with.
- name = commaSeparate dflags . map unLoc $ getConNames con
+ name = commaSeparate dflags . map unL $ getConNames con
tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
@@ -262,13 +270,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
(HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
-ppCtor dflags _dat subdocs con@(ConDeclGADT { })
- = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
+ , con_bndrs = L _ outer_bndrs
+ , con_mb_cxt = mcxt
+ , con_g_args = args
+ , con_res_ty = res_ty })
+ = concatMap (lookupCon dflags subdocs) names ++ [typeSig]
where
- f = [typeSig name (getGADTConTypeG con)]
-
- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)
- name = out dflags $ map unLoc $ getConNames con
+ typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty
+ name = out dflags $ map unL names
+ con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
+ theta_ty = case mcxt of
+ Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+ Nothing -> tau_ty
+ tau_ty = foldr mkFunTy res_ty $
+ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
+ RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
+ mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 03be8c22..d85a3970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -70,10 +70,10 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
-- Get the AST and tokens corresponding to the source file we want
let fileFs = mkFastString file
mast | M.size asts == 1 = snd <$> M.lookupMin asts
- | otherwise = M.lookup fileFs asts
+ | otherwise = M.lookup (HiePath (mkFastString file)) asts
+ tokens = parse df file rawSrc
ast = fromMaybe (emptyHieAst fileFs) mast
fullAst = recoverFullIfaceTypes df types ast
- tokens = parse df file rawSrc
-- Warn if we didn't find an AST, but there were still ASTs
if M.null asts
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 3db3c685..52d73265 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -10,15 +10,18 @@ import Data.List ( isPrefixOf, isSuffixOf )
import qualified Data.ByteString as BS
-import GHC.Types.Basic ( IntegralLit(..) )
+import GHC.Types.SourceText
import GHC.Driver.Session
-import GHC.Utils.Error ( pprLocErrMsg )
+import GHC.Utils.Error ( pprLocMsgEnvelope )
import GHC.Data.FastString ( mkFastString )
+import GHC.Parser.Errors.Ppr ( pprError )
import GHC.Parser.Lexer as Lexer
( P(..), ParseResult(..), PState(..), Token(..)
- , mkPStatePure, lexer, mkParserFlags', getErrorMessages)
+ , initParserState, lexer, mkParserOpts, getErrorMessages)
import GHC.Data.Bag ( bagToList )
-import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) )
+import GHC.Utils.Outputable ( text, ($$) )
+import GHC.Utils.Panic ( panic )
+import GHC.Driver.Ppr ( showSDoc )
import GHC.Types.SrcLoc
import GHC.Data.StringBuffer ( StringBuffer, atEnd )
@@ -37,17 +40,16 @@ parse
parse dflags fpath bs = case unP (go False []) initState of
POk _ toks -> reverse toks
PFailed pst ->
- let err:_ = bagToList (getErrorMessages pst dflags) in
+ let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
panic $ showSDoc dflags $
- text "Hyperlinker parse error:" $$ pprLocErrMsg err
+ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
where
- initState = mkPStatePure pflags buf start
+ initState = initParserState pflags buf start
buf = stringBufferFromByteString bs
start = mkRealSrcLoc (mkFastString fpath) 1 1
- pflags = mkParserFlags' (warningFlags dflags)
+ pflags = mkParserOpts (warningFlags dflags)
(extensionFlags dflags)
- (homeUnitId dflags)
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
@@ -240,7 +242,6 @@ classify tok =
ITline_prag {} -> TkPragma
ITcolumn_prag {} -> TkPragma
ITscc_prag {} -> TkPragma
- ITgenerated_prag {} -> TkPragma
ITunpack_prag {} -> TkPragma
ITnounpack_prag {} -> TkPragma
ITann_prag {} -> TkPragma
@@ -381,7 +382,6 @@ inPragma False tok =
ITline_prag {} -> True
ITcolumn_prag {} -> True
ITscc_prag {} -> True
- ITgenerated_prag {} -> True
ITunpack_prag {} -> True
ITnounpack_prag {} -> True
ITann_prag {} -> True
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index b093b5a4..5c3bddef 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -21,7 +21,7 @@ import GHC
import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
import GHC.Iface.Type
import GHC.Types.Name ( getOccFS, getOccString )
-import GHC.Utils.Outputable( showSDoc )
+import GHC.Driver.Ppr ( showSDoc )
import GHC.Types.Var ( VarBndr(..) )
import System.FilePath.Posix ((</>), (<.>))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index ac904273..df1f94e6 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -31,7 +31,7 @@ import GHC.Types.Name ( nameOccName )
import GHC.Types.Name.Reader ( rdrNameOcc )
import GHC.Core.Type ( Specificity(..) )
import GHC.Data.FastString ( unpackFS )
-import GHC.Utils.Outputable ( panic)
+import GHC.Utils.Panic ( panic)
import qualified Data.Map as Map
import System.Directory
@@ -108,7 +108,7 @@ type LaTeX = Pretty.Doc
-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100
-- often overflows the line).
latex2String :: LaTeX -> String
-latex2String = fullRender PageMode 90 1 txtPrinter ""
+latex2String = fullRender (PageMode True) 90 1 txtPrinter ""
ppLaTeXTop
:: String
@@ -177,7 +177,7 @@ ppLaTeXModule _title odir iface = do
body = processExports exports
--
- writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex)
+ writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
@@ -215,10 +215,10 @@ processExports (e : es) =
processExport e $$ processExports es
-isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)
isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
isSimpleSig _ = Nothing
@@ -301,7 +301,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
InstD _ _ -> empty
@@ -313,7 +313,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
- ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode
+ ppFunSig Nothing doc [name] typ unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -350,9 +350,9 @@ ppFamDecl associated doc instances decl unicode =
-- Individual equations of a closed type family
ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
- ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
- , feqn_rhs = rhs
- , feqn_pats = ts } })
+ ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts })
= hsep [ ppAppNameTypeArgs n ts unicode
, equals
, ppType unicode (unLoc rhs)
@@ -407,7 +407,7 @@ ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype }) unicode
- = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode
+ = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type"
: ppDocBinder name
@@ -426,7 +426,7 @@ ppFunSig
:: Maybe LaTeX -- ^ a prefix to put right before the signature
-> DocForDecl DocName -- ^ documentation
-> [DocName] -- ^ pattern names in the pattern signature
- -> LHsType DocNameI -- ^ type of the pattern synonym
+ -> LHsSigType DocNameI -- ^ type of the pattern synonym
-> Bool -- ^ unicode
-> LaTeX
ppFunSig leader doc docnames (L _ typ) unicode =
@@ -447,11 +447,11 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation
-> Bool -- ^ unicode
-> LaTeX
ppLPatSig doc docnames ty unicode
- = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode
+ = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode
-- | Pretty-print a type, adding documentation to the whole type and its
-- arguments as needed.
-ppTypeOrFunSig :: HsType DocNameI
+ppTypeOrFunSig :: HsSigType DocNameI
-> DocForDecl DocName -- ^ documentation
-> ( LaTeX -- first-line (no-argument docs only)
, LaTeX -- first-line (argument docs only)
@@ -471,13 +471,24 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
-- to the arguments. The output is a list of (leader/seperator, argument and
-- its doc)
ppSubSigLike :: Bool -- ^ unicode
- -> HsType DocNameI -- ^ type signature
+ -> HsSigType DocNameI -- ^ type signature
-> FnArgsDoc DocName -- ^ docs to add
-> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)
-> LaTeX -- ^ seperator (beginning of first line)
-> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type)
-ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
+ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
where
+ do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]
+ do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
+ case outer_bndrs of
+ HsOuterExplicit{hso_bndrs = bndrs} ->
+ [ ( decltt leader
+ , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)
+ <+> ppLType unicode ltype
+ ) ]
+ HsOuterImplicit{} -> do_largs n leader ltype
+
+ do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)]
do_largs n leader (L _ t) = do_args n leader t
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
@@ -515,12 +526,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = char '{'
-ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
+ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
<+> dcolon unicode
- <+> ppType unicode ty
+ <+> ppSigType unicode ty
+ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX
+ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty
+ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =
+ hsep (forallSymbol unicode : ppTyVars bndrs) <> dot
ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX
ppHsForAllTelescope tele unicode = case tele of
@@ -635,7 +650,7 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}" <> emph (text "Methods") $$
- vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode
+ vcat [ ppFunSig leader doc names typ unicode
| L _ (ClassOpSig _ is_def lnames typ) <- lsigs
, let doc | is_def = noDocForDecl
| otherwise = lookupAnySubdoc (head names) subdocs
@@ -795,7 +810,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
header_ = ppConstrHdr forall_ tyVars context unicode
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args
+ PrefixCon _ args
| hasArgDocs -> header_ <+> ppOcc
| otherwise -> hsep [ header_
, ppOcc
@@ -819,23 +834,25 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
| otherwise -> hsep [ ppOcc
, dcolon unicode
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
- , ppLType unicode (getGADTConType con)
+ , ppLSigType unicode (getGADTConType con)
]
- fieldPart = case (con, getConArgsI con) of
- -- Record style GADTs
- (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs []
-
- -- Regular record declarations
- (_, RecCon (L _ fields)) -> doRecordFields fields
-
- -- Any GADT or a regular H98 prefix data constructor
- (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
-
- -- An infix H98 data constructor
- (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
-
- _ -> empty
+ fieldPart = case con of
+ ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+ -- GADT record declarations
+ RecConGADT _ -> doConstrArgsWithDocs []
+ -- GADT prefix data constructors
+ PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ _ -> empty
+
+ ConDeclH98{con_args = con_args'} -> case con_args' of
+ -- H98 record declarations
+ RecCon (L _ fields) -> doRecordFields fields
+ -- H98 prefix data constructors
+ PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ -- H98 infix data constructor
+ InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
+ _ -> empty
doRecordFields fields =
vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
@@ -892,18 +909,16 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppLType unicode (hsSigTypeI typ)
+ , ppLSigType unicode typ
]
fieldPart
| not hasArgDocs = empty
| otherwise = vcat
[ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r
- | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
+ | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode)
]
- patTy = hsSigTypeI typ
-
mDoc = fmap _doc $ combineDocumentation doc
@@ -1024,12 +1039,18 @@ ppLType unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
+ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX
+ppLSigType unicode y = ppSigType unicode (unLoc y)
+
ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
-ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode
+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
+ppSigType :: Bool -> HsSigType DocNameI -> LaTeX
+ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode
+
ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
@@ -1061,6 +1082,11 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
+ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX
+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode
+ = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode
+ , ppr_mono_lty ltype unicode ]
+
ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
@@ -1090,7 +1116,7 @@ ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy v _) _ = absurd v
ppr_mono_ty (HsRecTy {}) _ = text "{..}"
-ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
@@ -1123,6 +1149,7 @@ ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
ppr_tylit :: HsTyLit -> Bool -> LaTeX
ppr_tylit (HsNumTy _ n) _ = integer n
ppr_tylit (HsStrTy _ s) _ = text (show s)
+ppr_tylit (HsCharTy _ c) _ = text (show c)
-- XXX: Ok in verbatim, but not otherwise
-- XXX: Do something with Unicode parameter?
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index f8c22e0a..1bdbf81b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -223,10 +223,7 @@ moduleInfo iface =
("Language", lg)
] ++ extsForm
where
- lg inf = case hmi_language inf of
- Nothing -> Nothing
- Just Haskell98 -> Just "Haskell98"
- Just Haskell2010 -> Just "Haskell2010"
+ lg inf = fmap show (hmi_language inf)
multilineRow :: String -> [String] -> HtmlTable
multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 0b0050df..de37e42a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -63,9 +63,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigWcType lty) fixities splice unicode pkg qual
+ (dropWildCards lty) fixities splice unicode pkg qual
SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
- (hsSigTypeI lty) fixities splice unicode pkg qual
+ lty fixities splice unicode pkg qual
ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
@@ -73,25 +73,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+ [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
splice unicode pkg qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
- [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+ [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =
ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)
splice unicode pkg qual HideEmptyContexts
where
- pp_typ = ppLType unicode qual HideEmptyContexts typ
+ pp_typ = ppLSigType unicode qual HideEmptyContexts typ
-- | Pretty print a pattern synonym
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> [Located DocName] -- ^ names of patterns in declaration
- -> LHsType DocNameI -- ^ type of patterns in declaration
+ -> LHsSigType DocNameI -- ^ type of patterns in declaration
-> [(DocName, Fixity)]
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
@@ -102,7 +102,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
- [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
+ [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) ->
Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
splice unicode pkg qual emptyCtxts =
@@ -119,7 +119,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
| otherwise = html <+> ppFixities fixities qual
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
-> Splice -> Unicode -> Maybe Package -> Qualification
-> HideEmptyContexts -> Html
@@ -140,15 +140,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
-- If one passes in a list of the available subdocs, any top-level `HsRecTy`
-- found will be expanded out into their fields.
ppSubSigLike :: Unicode -> Qualification
- -> HsType DocNameI -- ^ type signature
+ -> HsSigType DocNameI -- ^ type signature
-> FnArgsDoc DocName -- ^ docs to add
-> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when
-- we expand an `HsRecTy`)
-> Html -> HideEmptyContexts -> [SubDecl]
-ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ
where
+ do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]
+ do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
+ case outer_bndrs of
+ HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype
+ HsOuterImplicit{} -> do_largs n leader ltype
+ where
+ leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs)
+
argDoc n = Map.lookup n argDocs
+ do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl]
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
@@ -222,7 +231,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode pkg qual
- = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
+ = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -233,13 +242,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype })
splice unicode pkg qual
- = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+ = ppTypeOrFunSig summary links loc [name] sig_type doc
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
splice unicode pkg qual ShowEmptyToplevelContexts
where
+ sig_type = mkHsImplicitSigTypeI ltype
hdr = hsep ([keyword "type", ppBinder summary occ]
++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
- full = hdr <+> equals <+> ppPatSigType unicode qual ltype
+ full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type)
occ = nameOccName . getName $ name
fixs
| summary = noHtml
@@ -253,15 +263,14 @@ ppTypeSig summary nms pp_ty unicode =
where
htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
-
ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
- -> [DocName] -> HsType DocNameI
+ -> [DocName] -> HsSigType DocNameI
-> Html
ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
where
topDeclElem' = topDeclElem links loc splice
- ppTyp = ppType unicode qual emptyCtxts typ
+ ppTyp = ppSigType unicode qual emptyCtxts typ
occNames = map getOccName names
@@ -301,9 +310,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
-- Individual equation of a closed type family
ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl
- ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
- , feqn_rhs = rhs
- , feqn_pats = ts } })
+ ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts })
= ( ppAppNameTypeArgs n ts unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing
@@ -497,7 +506,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)
+ [ ppFunSig summary links loc noHtml doc names typ
[] splice unicode pkg qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -561,14 +570,14 @@ ppClassDecl summary links instances fixities loc d subdocs
lookupDAT name = Map.lookup (getName name) defaultAssocTys
defaultAssocTys = Map.fromList
[ (getName name, (vs, typ))
- | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ
- , feqn_tycon = L _ name
- , feqn_pats = vs }))) <- atsDefs
+ | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs })) <- atsDefs
]
-- Methods
methodBit = subMethods
- [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)
+ [ ppFunSig summary links loc noHtml doc [name] typ
subfixs splice unicode pkg qual
<+>
subDefaults (maybeToList defSigs)
@@ -583,7 +592,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Default methods
ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
- d' [n] (hsSigTypeI t) [] splice unicode pkg qual
+ d' [n] t [] splice unicode pkg qual
lookupDM name = Map.lookup (getOccString name) defaultMethods
defaultMethods = Map.fromList
@@ -709,7 +718,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstanceSigs links splice unicode qual sigs = do
TypeSig _ lnames typ <- sigs
let names = map unLoc lnames
- L _ rtyp = hsSigWcType typ
+ L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
@@ -772,7 +781,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
pats1 = [ hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
- , ppPatSigType unicode qual (hsSigTypeI typ)
+ , ppPatSigType unicode qual typ
]
| (SigD _ (PatSynSig _ lnames typ),_) <- pats
]
@@ -851,7 +860,7 @@ ppShortConstrParts summary dataInst con unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args ->
+ PrefixCon _ args ->
( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
, noHtml
, noHtml
@@ -878,7 +887,7 @@ ppShortConstrParts summary dataInst con unicode qual
-- GADT constructor, e.g. 'Foo :: Int -> Foo'
ConDeclGADT {} ->
- ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]
+ ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ]
, noHtml
, noHtml
)
@@ -922,7 +931,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
- PrefixCon args
+ PrefixCon _ args
| hasArgDocs -> header_ <+> ppOcc <+> fixity
| otherwise -> hsep [ header_ <+> ppOcc
, hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
@@ -947,24 +956,26 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
| otherwise -> hsep [ ppOcc
, dcolon unicode
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
- , ppLType unicode qual HideEmptyContexts (getGADTConType con)
+ , ppLSigType unicode qual HideEmptyContexts (getGADTConType con)
, fixity
]
- fieldPart = case (con, getConArgsI con) of
- -- Record style GADTs
- (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ]
-
- -- Regular record declarations
- (_, RecCon (L _ fields)) -> [ doRecordFields fields ]
-
- -- Any GADT or a regular H98 prefix data constructor
- (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ]
-
- -- An infix H98 data constructor
- (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
-
- _ -> []
+ fieldPart = case con of
+ ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+ -- GADT record declarations
+ RecConGADT _ -> [ doConstrArgsWithDocs [] ]
+ -- GADT prefix data constructors
+ PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+ _ -> []
+
+ ConDeclH98{con_args = con_args'} -> case con_args' of
+ -- H98 record declarations
+ RecCon (L _ fields) -> [ doRecordFields fields ]
+ -- H98 prefix data constructors
+ PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+ -- H98 infix data constructor
+ InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
+ _ -> []
doRecordFields fields = subFields pkg qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
@@ -1049,18 +1060,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppPatSigType unicode qual (hsSigTypeI typ)
+ , ppPatSigType unicode qual typ
, fixity
]
fieldPart
| not hasArgDocs = []
- | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
+ | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ)
argDocs [] (dcolon unicode)
emptyCtxt) ]
- patTy = hsSigTypeI typ
- emptyCtxt = patSigContext patTy
+ emptyCtxt = patSigContext typ
-- | Print the LHS of a data\/newtype declaration.
@@ -1114,6 +1124,9 @@ ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc
ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
+ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html
+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)
+
ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts
@@ -1122,6 +1135,9 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP
ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts
ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts
+ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html
+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts
+
ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
@@ -1156,18 +1172,18 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
-patSigContext :: LHsType name -> HideEmptyContexts
-patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts
- | otherwise = HideEmptyContexts
+patSigContext :: LHsSigType DocNameI -> HideEmptyContexts
+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts
+ | otherwise = HideEmptyContexts
where
- hasNonEmptyContext :: LHsType name -> Bool
+ typ = sig_body (unLoc sig_typ)
+
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
- isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
@@ -1178,10 +1194,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in
-- the right 'HideEmptyContext' value)
-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html
ppPatSigType unicode qual typ =
- let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+ let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ
+ppHsOuterTyVarBndrs :: RenderableBndrFlag flag
+ => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html
+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of
+ HsOuterImplicit{} -> noHtml
+ HsOuterExplicit{hso_bndrs = bndrs} ->
+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
ppForAllPart unicode qual tele = case tele of
@@ -1191,6 +1213,10 @@ ppForAllPart unicode qual tele = case tele of
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
+ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts
+ = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts
+
ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
@@ -1236,7 +1262,7 @@ ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
@@ -1272,3 +1298,4 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
+ppr_tylit (HsCharTy _ c) = toHtml (show c)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 980af379..10e13152 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,8 +22,9 @@ module Haddock.Convert (
#include "HsVersions.h"
import GHC.Data.Bag ( emptyBag )
-import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)
- , PromotionFlag(..), DefMethSpec(..) )
+import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) )
+import GHC.Types.SourceText (SourceText(..))
+import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.ConLike
@@ -31,6 +32,7 @@ import Data.Either (lefts, rights)
import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Hs
+import GHC.Types.TyThing
import GHC.Types.Name
import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual )
@@ -47,7 +49,7 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
, filterByList, filterOut )
-import GHC.Utils.Outputable ( assertPanic )
+import GHC.Utils.Panic ( assertPanic )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
@@ -55,7 +57,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import Haddock.Types
import Haddock.Interface.Specialize
-import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
+import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType )
import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
@@ -90,10 +92,11 @@ tyThingToLHsDecl prr t = case t of
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
+ cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+ -- Without this signature, we trigger GHC#18932
cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField
(L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
- cvt (XTyVarBndr nec) = noExtCon nec
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
@@ -101,15 +104,14 @@ tyThingToLHsDecl prr t = case t of
extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl fd rhs =
- TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
- , hsib_body = FamEqn
+ TyFamInstDecl $ FamEqn
{ feqn_ext = noExtField
, feqn_tycon = fdLName fd
- , feqn_bndrs = Nothing
+ , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}
, feqn_pats = map (HsValArg . hsLTyVarBndrToType) $
hsq_explicit $ fdTyVars fd
, feqn_fixity = fdFixity fd
- , feqn_rhs = synifyType WithinType [] rhs }}
+ , feqn_rhs = synifyType WithinType [] rhs }
extractAtItem
:: ClassATItem
@@ -166,14 +168,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
typats = map (synifyType WithinType []) args_types_only
annot_typats = zipWith3 annotHsType args_poly args_types_only typats
hs_rhs = synifyType WithinType [] rhs
- in HsIB { hsib_ext = map tyVarName tkvs
- , hsib_body = FamEqn { feqn_ext = noExtField
- , feqn_tycon = name
- , feqn_bndrs = Nothing
+ outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
-- TODO: this must change eventually
- , feqn_pats = map HsValArg annot_typats
- , feqn_fixity = synifyFixity name
- , feqn_rhs = hs_rhs } }
+ in FamEqn { feqn_ext = noExtField
+ , feqn_tycon = name
+ , feqn_bndrs = outer_bndrs
+ , feqn_pats = map HsValArg annot_typats
+ , feqn_fixity = synifyFixity name
+ , feqn_rhs = hs_rhs }
where
args_poly = tyConArgsPolyKinded tc
@@ -227,7 +229,7 @@ synifyTyCon prr _coax tc
| otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
conKind = defaultType prr (tyConKind tc)
- tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
+ tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind
synifyTyCon _prr _coax tc
| Just flav <- famTyConFlav_maybe tc
@@ -367,6 +369,12 @@ synifyDataCon use_gadt_syntax dc =
(_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
+ outer_bndrs | null user_tvbndrs
+ = HsOuterImplicit { hso_ximplicit = [] }
+ | otherwise
+ = HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = map synifyTyVarBndr user_tvbndrs }
+
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
| otherwise = Just $ synifyCtx theta
@@ -383,34 +391,43 @@ synifyDataCon use_gadt_syntax dc =
con_decl_field fl synTy = noLoc $
ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
Nothing
- hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
- (True,True) -> Left "synifyDataCon: contradiction!"
- (True,False) -> return $ RecCon (noLoc field_tys)
- (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
- (False,True) -> case linear_tys of
- [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
- _ -> Left "synifyDataCon: infix with non-2 args?"
+
+ mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
+ mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
+ (True,True) -> Left "synifyDataCon: contradiction!"
+ (True,False) -> return $ RecCon (noLoc field_tys)
+ (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)
+ (False,True) -> case linear_tys of
+ [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
+ _ -> Left "synifyDataCon: infix with non-2 args?"
+
+ mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
+ mk_gadt_arg_tys
+ | use_named_field_syntax = RecConGADT (noLoc field_tys)
+ | otherwise = PrefixConGADT (map hsUnrestricted linear_tys)
+
-- finally we get synifyDataCon's result!
- in hs_arg_tys >>=
- \hat ->
- if use_gadt_syntax
- then return $ noLoc $
- ConDeclGADT { con_g_ext = []
- , con_names = [name]
- , con_forall = noLoc $ not $ null user_tvbndrs
- , con_qvars = map synifyTyVarBndr user_tvbndrs
- , con_mb_cxt = ctx
- , con_args = hat
- , con_res_ty = synifyType WithinType [] res_ty
- , con_doc = Nothing }
- else return $ noLoc $
- ConDeclH98 { con_ext = noExtField
- , con_name = name
- , con_forall = noLoc False
- , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
- , con_mb_cxt = ctx
- , con_args = hat
- , con_doc = Nothing }
+ in if use_gadt_syntax
+ then do
+ let hat = mk_gadt_arg_tys
+ return $ noLoc $ ConDeclGADT
+ { con_g_ext = noExtField
+ , con_names = [name]
+ , con_bndrs = noLoc outer_bndrs
+ , con_mb_cxt = ctx
+ , con_g_args = hat
+ , con_res_ty = synifyType WithinType [] res_ty
+ , con_doc = Nothing }
+ else do
+ hat <- mk_h98_arg_tys
+ return $ noLoc $ ConDeclH98
+ { con_ext = noExtField
+ , con_name = name
+ , con_forall = noLoc False
+ , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
+ , con_mb_cxt = ctx
+ , con_args = hat
+ , con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
@@ -526,17 +543,17 @@ data SynifyTypeState
synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
--- The empty binders is a bit suspicious;
--- what if the type has free variables?
-synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty)
+-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
+-- is a bit suspicious; what if the type has free variables?
+synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty))
+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
-synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
+synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps)
-- | Depending on the first argument, try to default all type variables of kind
-- 'RuntimeRep' to 'LiftedType'.
@@ -566,8 +583,8 @@ synifyType _ vs (TyConApp tc tys)
, tyConArity tc == tys_len
= noLoc $ HsTupleTy noExtField
(case sort of
- BoxedTuple -> HsBoxedTuple
- ConstraintTuple -> HsConstraintTuple
+ BoxedTuple -> HsBoxedOrConstraintTuple
+ ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType vs) vis_tys)
| isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys)
@@ -804,6 +821,7 @@ synifyPatSynType ps =
synifyTyLit :: TyLit -> HsTyLit
synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
+synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig k = synifyType WithinType [] k
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 10725ee5..546e2941 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,8 @@
{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -26,14 +29,14 @@ import Data.Maybe ( mapMaybe )
import Haddock.Types( DocName, DocNameI )
import GHC.Utils.FV as FV
-import GHC.Utils.Outputable ( Outputable, panic, showPpr )
-import GHC.Types.Basic (PromotionFlag(..))
+import GHC.Utils.Outputable ( Outputable )
+import GHC.Utils.Panic ( panic )
+import GHC.Driver.Ppr (showPpr )
import GHC.Types.Name
import GHC.Unit.Module
-import GHC.Driver.Types
import GHC
-import GHC.Core.Class
import GHC.Driver.Session
+import GHC.Types.Basic
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -51,6 +54,8 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
+import GHC.HsToCore.Docs
+
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -90,25 +95,12 @@ ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
ifTrueJust False = const Nothing
-sigName :: LSig name -> [IdP name]
+sigName :: LSig GhcRn -> [IdP GhcRn]
sigName (L _ sig) = sigNameNoLoc sig
-sigNameNoLoc :: Sig name -> [IdP name]
-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig _ n _) = [unLoc n]
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
-sigNameNoLoc _ = []
-
-- | Was this signature given by the user?
-isUserLSig :: LSig name -> Bool
-isUserLSig (L _ (TypeSig {})) = True
-isUserLSig (L _ (ClassOpSig {})) = True
-isUserLSig (L _ (PatSynSig {})) = True
-isUserLSig _ = False
-
+isUserLSig :: forall p. UnXRec p => LSig p -> Bool
+isUserLSig = isUserSig . unXRec @p
isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d
@@ -123,10 +115,10 @@ pretty = showPpr
-- instantiated at DocNameI instead of (GhcPass _).
-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
-hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n
-hsTyVarBndrName (UserTyVar _ _ name) = unLoc name
-hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name
-hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec
+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)
+ => HsTyVarBndr flag n -> IdP n
+hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name
+hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name
hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName
hsTyVarNameI (UserTyVar _ _ (L _ n)) = n
@@ -139,33 +131,45 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
getConNamesI ConDeclGADT {con_names = names} = names
-hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
-hsImplicitBodyI (HsIB { hsib_body = body }) = body
-
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
-hsSigTypeI = hsImplicitBodyI
+hsSigTypeI = sig_body . unLoc
+
+mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigType lty@(L loc ty) = L loc $ case ty of
+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
+ , hst_body = body }
+ -> HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = bndrs }
+ , sig_body = body }
+ _ -> HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}
+ , sig_body = lty }
mkHsForAllInvisTeleI ::
[LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI invis_bndrs =
HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
-getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
-getConArgsI d = con_args d
+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
+mkHsImplicitSigTypeI body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}
+ , sig_body = body }
-getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
-- The full type of a GADT data constructor We really only get this in
-- order to pretty-print it, and currently only in Haddock's code. So
-- we are cavalier about locations and extensions, hence the
-- 'undefined's
-getGADTConType (ConDeclGADT { con_forall = L _ has_forall
- , con_qvars = qtvs
- , con_mb_cxt = mcxt, con_args = args
+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
+ , con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTeleI qtvs
- , hst_body = theta_ty })
- | otherwise = theta_ty
+ = noLoc (HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
= noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
@@ -174,9 +178,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
- PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
- InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
+ RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+ PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
@@ -186,7 +189,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
getMainDeclBinderI (TyClD _ d) = [tcdNameI d]
getMainDeclBinderI (ValD _ d) =
- case collectHsBindBinders d of
+ case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
@@ -206,73 +209,33 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln
tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI = unLoc . tyClDeclLNameI
--- -------------------------------------
-
-getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
--- The full type of a GADT data constructor We really only get this in
--- order to pretty-print it, and currently only in Haddock's code. So
--- we are cavalier about locations and extensions, hence the
--- 'undefined's
-getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
- , con_qvars = qtvs
- , con_mb_cxt = mcxt, con_args = args
- , con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
- , hst_tele = mkHsForAllInvisTele qtvs
- , hst_body = theta_ty })
- | otherwise = theta_ty
- where
- theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
- | otherwise
- = tau_ty
-
--- tau_ty :: LHsType DocNameI
- tau_ty = case args of
- RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
- PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
- InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
-
- -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
-
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
- -- Should only be called on ConDeclGADT
-
-
-mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
--- Dubious, because the implicit binders are empty even
--- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
-
-
addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
- = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
- -- The mkEmptySigWcType is suspicious
+ = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
where
- go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
- = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField
- , hst_body = go ty })
- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
+ = L loc (HsSig { sig_ext = noExtField
+ , sig_bndrs = bndrs, sig_body = go_ty ty })
+
+ go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
+ = L loc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = tele, hst_body = go_ty ty })
+ go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
- go (L loc ty)
+ go_ty (L loc ty)
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
- extra_pred :: LHsType GhcRn
- extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))
-
- add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn
+ extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
add_ctxt (L loc preds) = L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
-lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
@@ -280,7 +243,6 @@ lHsQTyVarsToTypes tvs
-- * Making abstract declarations
--------------------------------------------------------------------------------
-
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
TyClD x d | isDataDecl d ->
@@ -303,17 +265,27 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
- keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
- case con_args d of
- PrefixCon _ -> Just d
- RecCon fields
- | all field_avail (unLoc fields) -> Just d
- | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) })
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
- InfixCon _ _ -> Just d
+ keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)
+ keep d
+ | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+ case d of
+ ConDeclH98 { con_args = con_args' } -> case con_args' of
+ PrefixCon {} -> Just d
+ RecCon fields
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc fields) })
+ -- if we have *all* the field names available, then
+ -- keep the record declaration. Otherwise degrade to
+ -- a constructor declaration. This isn't quite right, but
+ -- it's the best we can do.
+ InfixCon _ _ -> Just d
+
+ ConDeclGADT { con_g_args = con_args' } -> case con_args' of
+ PrefixConGADT {} -> Just d
+ RecConGADT fields
+ | all field_avail (unLoc fields) -> Just d
+ | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })
+ -- see above
where
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField _ fs _ _))
@@ -358,17 +330,19 @@ data Precedence
--
-- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(.
-reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+ go :: Precedence -> HsType a -> HsType a
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
- go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)
+ go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
@@ -381,7 +355,8 @@ reparenTypePrec = go
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
- in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)
+ ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
+ in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
@@ -390,7 +365,7 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
go p (HsOpTy x ty1 op ty2)
= paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
- go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
+ go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
go _ t@HsTyVar{} = t
go _ t@HsStarTy{} = t
go _ t@HsSpliceTy{} = t
@@ -399,43 +374,68 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
- goL ctxt_prec = fmap (go ctxt_prec)
+ goL :: Precedence -> LHsType a -> LHsType a
+ goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: (XParTy a ~ NoExtField)
- => Precedence -- Precedence of context
+ paren :: Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator
-> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
- paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a
| otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a
+reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
-reparenLType = fmap reparenType
+reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => LHsType a -> LHsType a
+reparenLType = mapXRec @a reparenType
+
+-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
+reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsSigType a -> HsSigType a
+reparenSigType (HsSig x bndrs body) =
+ HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
+reparenSigType v@XHsSigType{} = v
+
+-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
+reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)
+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: (XParTy a ~ NoExtField)
+reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
=> HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) =
- HsForAllVis x (map (fmap reparenTyVar) bndrs)
+ HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope (HsForAllInvis x bndrs) =
- HsForAllInvis x (map (fmap reparenTyVar) bndrs)
+ HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+ , MapXRec a, UnXRec a, WrapXRec a )
+ => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c
@@ -471,10 +471,9 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
- case con_args con of
- RecCon fields -> map (extFieldOcc . unLoc) $
- concatMap (cd_fld_names . unLoc) (unLoc fields)
- _ -> []
+ case getRecConArgs_maybe con of
+ Nothing -> []
+ Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
@@ -526,14 +525,6 @@ modifySessionDynFlags f = do
return ()
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
- mty <- lookupGlobalName n
- case mty of
- Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
- _ -> return Nothing
-
-------------------------------------------------------------------------------
-- * DynFlags
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index b68cc4a9..f1403def 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -29,7 +29,8 @@
-- using this environment.
-----------------------------------------------------------------------------
module Haddock.Interface (
- processModules
+ plugin
+ , processModules
) where
@@ -43,26 +44,34 @@ import Haddock.Types
import Haddock.Utils
import Control.Monad
-import Control.Monad.IO.Class ( liftIO )
-import Control.Exception (evaluate)
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.IORef
import Data.List (foldl', isPrefixOf, nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Printf
import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
+import GHC.Unit.Module.ModSummary
+import GHC.Unit.Module.Graph
+import GHC.Unit.Types
import GHC.Data.Graph.Directed
import GHC.Driver.Session hiding (verbosity)
import GHC hiding (verbosity)
-import GHC.Driver.Types
+import GHC.Driver.Env
+import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (tcg_rdr_env)
+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, gre_name, globalRdrEnvElts)
+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(..),
+ defaultPlugin, keepRenamedSource)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -88,8 +97,14 @@ processModules verbosity modules flags extIfaces = do
#endif
out verbosity verbose "Creating interfaces..."
- let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
- , iface <- ifInstalledIfaces ext ]
+ let
+ instIfaceMap :: InstIfaceMap
+ instIfaceMap = Map.fromList
+ [ (instMod iface, iface)
+ | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext
+ ]
+
(interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap
let exportedNames =
@@ -125,98 +140,202 @@ processModules verbosity modules flags extIfaces = do
createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces verbosity modules flags instIfaceMap = do
- -- Ask GHC to tell us what the module graph is
+ (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
+ verbosity flags instIfaceMap
+
+ let
+ installHaddockPlugin :: HscEnv -> HscEnv
+ installHaddockPlugin hsc_env = hsc_env
+ {
+ hsc_dflags =
+ gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy
+ , hsc_static_plugins =
+ haddockPlugin : hsc_static_plugins hsc_env
+ }
+
+ -- Note that we would rather use withTempSession but as long as we
+ -- have the separate attachInstances step we need to keep the session
+ -- alive to be able to find all the instances.
+ modifySession installHaddockPlugin
+
targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
setTargets targets
- modGraph <- depanal [] False
- -- Visit modules in that order
- let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing
- out verbosity normal "Haddock coverage:"
- (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
- return (reverse ifaces, ms)
- where
- f (ifaces, ifaceMap, !ms) modSummary = do
- x <- {-# SCC processModule #-}
- withTimingD "processModule" (const ()) $ do
- processModule verbosity modSummary flags ifaceMap instIfaceMap
- return $ case x of
- Just (iface, ms') -> ( iface:ifaces
- , Map.insert (ifaceMod iface) iface ifaceMap
- , unionModuleSet ms ms' )
- Nothing -> ( ifaces
- , ifaceMap
- , ms ) -- Boot modules don't generate ifaces.
-
-
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
-processModule verbosity modsum flags modMap instIfaceMap = do
- out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
-
- -- Since GHC 8.6, plugins are initialized on a per module basis
- hsc_env' <- getSession
- dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum))
- let modsum' = modsum { ms_hspp_opts = dynflags' }
-
- tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum'
-
- case isBootSummary modsum of
- IsBoot ->
- return Nothing
- NotBoot -> do
- out verbosity verbose "Creating interface..."
- (interface, msgs) <- {-# SCC createIterface #-}
- withTimingD "createInterface" (const ()) $ do
- runWriterGhc $ createInterface tm flags modMap instIfaceMap
-
- -- We need to keep track of which modules were somehow in scope so that when
- -- Haddock later looks for instances, it also looks in these modules too.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- this_pkg = homeUnit (hsc_dflags hsc_env)
- !mods = mkModuleSet [ nameModule name
- | gre <- globalRdrEnvElts new_rdr_env
- , let name = gre_name gre
- , nameIsFromExternalPackage this_pkg name
- , isTcOcc (nameOccName name) -- Types and classes only
- , unQualOK gre ] -- In scope unqualified
-
- liftIO $ mapM_ putStrLn (nub msgs)
- dflags <- getDynFlags
- let (haddockable, haddocked) = ifaceHaddockCoverage interface
- percentage = div (haddocked * 100) haddockable
- modString = moduleString (ifaceMod interface)
- coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
- header = case ifaceDoc interface of
- Documentation Nothing _ -> False
- _ -> True
- undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface ]
- where
- formatName :: SrcSpan -> HsDecl GhcRn -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
- RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
- _ -> ""
-
- p [] = ""
- p (x:_) = let n = pretty dflags x
- ms = modString ++ "."
- in if ms `isPrefixOf` n
- then drop (length ms) n
- else n
-
- when (OptHide `notElem` ifaceOptions interface) $ do
- out verbosity normal coverageMsg
- when (Flag_NoPrintMissingDocs `notElem` flags
- && not (null undocumentedExports && header)) $ do
- out verbosity normal " Missing documentation for:"
- unless header $ out verbosity normal " Module header"
- mapM_ (out verbosity normal . (" " ++)) undocumentedExports
- interface' <- liftIO $ evaluate interface
- return (Just (interface', mods))
+ loadOk <- withTimingD "load" (const ()) $
+ {-# SCC load #-} GHC.load LoadAllTargets
+
+ case loadOk of
+ Failed ->
+ throwE "Cannot typecheck modules"
+ Succeeded -> do
+ modGraph <- GHC.getModuleGraph
+ ifaceMap <- liftIO getIfaces
+ moduleSet <- liftIO getModules
+
+ let
+ ifaces :: [Interface]
+ ifaces =
+ [ Map.findWithDefault
+ (error "haddock:iface")
+ (ms_mod (emsModSummary ems))
+ ifaceMap
+ | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+ ]
+
+ return (ifaces, moduleSet)
+
+
+-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock
+-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
+-- parallelize the compilation process.
+plugin
+ :: MonadIO m
+ => Verbosity
+ -> [Flag]
+ -> InstIfaceMap
+ -> m
+ (
+ StaticPlugin -- the plugin to install with GHC
+ , m IfaceMap -- get the processed interfaces
+ , m ModuleSet -- get the loaded modules
+ )
+plugin verbosity flags instIfaceMap = liftIO $ do
+ ifaceMapRef <- newIORef Map.empty
+ moduleSetRef <- newIORef emptyModuleSet
+
+ let
+ processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
+ processTypeCheckedResult mod_summary tc_gbl_env
+ -- Don't do anything for hs-boot modules
+ | IsBoot <- isBootSummary mod_summary =
+ pure ()
+ | otherwise = do
+ hsc_env <- getTopEnv
+ ifaces <- liftIO $ readIORef ifaceMapRef
+ (iface, modules) <- withTimingD "processModule" (const ()) $
+ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
+
+ liftIO $ do
+ atomicModifyIORef' ifaceMapRef $ \xs ->
+ (Map.insert (ms_mod mod_summary) iface xs, ())
+
+ atomicModifyIORef' moduleSetRef $ \xs ->
+ (modules `unionModuleSet` xs, ())
+
+ staticPlugin :: StaticPlugin
+ staticPlugin = StaticPlugin
+ {
+ spPlugin = PluginWithArgs
+ {
+ paPlugin = defaultPlugin
+ {
+ renamedResultAction = keepRenamedSource
+ , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+ processTypeCheckedResult mod_summary tc_gbl_env
+ pure tc_gbl_env
+
+ }
+ , paArguments = []
+ }
+ }
+
+ pure
+ ( staticPlugin
+ , liftIO (readIORef ifaceMapRef)
+ , liftIO (readIORef moduleSetRef)
+ )
+
+
+processModule1
+ :: Verbosity
+ -> [Flag]
+ -> IfaceMap
+ -> InstIfaceMap
+ -> HscEnv
+ -> ModSummary
+ -> TcGblEnv
+ -> TcM (Interface, ModuleSet)
+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do
+ out verbosity verbose "Creating interface..."
+
+ let
+ TcGblEnv { tcg_rdr_env } = tc_gbl_env
+
+ unit_state = hsc_units hsc_env
+
+ (!interface, messages) <- {-# SCC createInterface #-}
+ withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+ createInterface1 flags unit_state mod_summary tc_gbl_env
+ ifaces inst_ifaces
+
+ -- We need to keep track of which modules were somehow in scope so that when
+ -- Haddock later looks for instances, it also looks in these modules too.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ let
+ mods :: ModuleSet
+ !mods = mkModuleSet
+ [ nameModule name
+ | gre <- globalRdrEnvElts tcg_rdr_env
+ , let name = greMangledName gre
+ , nameIsFromExternalPackage (hsc_home_unit hsc_env) name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre -- In scope unqualified
+ ]
+
+ liftIO $ mapM_ putStrLn (nub messages)
+ dflags <- getDynFlags
+
+ let
+ (haddockable, haddocked) =
+ ifaceHaddockCoverage interface
+
+ percentage :: Int
+ percentage = div (haddocked * 100) haddockable
+
+ modString :: String
+ modString = moduleString (ifaceMod interface)
+
+ coverageMsg :: String
+ coverageMsg =
+ printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+
+ header :: Bool
+ header = case ifaceDoc interface of
+ Documentation Nothing _ -> False
+ _ -> True
+
+ undocumentedExports :: [String]
+ undocumentedExports =
+ [ formatName s n
+ | ExportDecl { expItemDecl = L s n
+ , expItemMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface
+ ]
+ where
+ formatName :: SrcSpan -> HsDecl GhcRn -> String
+ formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
+ show (srcSpanStartLine rss) ++ ")"
+ _ -> ""
+
+ p :: Outputable a => [a] -> String
+ p [] = ""
+ p (x:_) = let n = pretty dflags x
+ ms = modString ++ "."
+ in if ms `isPrefixOf` n
+ then drop (length ms) n
+ else n
+
+ when (OptHide `notElem` ifaceOptions interface) $ do
+ out verbosity normal coverageMsg
+ when (Flag_NoPrintMissingDocs `notElem` flags
+ && not (null undocumentedExports && header)) $ do
+ out verbosity normal " Missing documentation for:"
+ unless header $ out verbosity normal " Module header"
+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports
+
+ pure (interface, mods)
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c4988480..9a773b6c 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -18,234 +20,321 @@
-- which creates a Haddock 'Interface' from the typechecking
-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface) where
+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where
import Documentation.Haddock.Doc (metaDocAppend)
-import Haddock.Types
+import Haddock.Types hiding (liftErrMsg)
import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
import Haddock.Interface.LexParseRn
-import Data.Bifunctor
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict hiding (tell)
import Data.Bitraversable
import qualified Data.Map as M
-import qualified Data.Set as S
import Data.Map (Map)
-import Data.List (find, foldl')
+import Data.List
import Data.Maybe
-import Control.Monad
import Data.Traversable
-import GHC.Stack (HasCallStack)
+import GHC.Stack
+import GHC.Tc.Utils.Monad (finalSafeMode)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
import qualified GHC.Unit.Module as Module
+import GHC.Unit.Module.ModSummary
import qualified GHC.Types.SrcLoc as SrcLoc
+import GHC.Types.SourceFile
+import GHC.Core.Class
import GHC.Core.ConLike (ConLike(..))
-import GHC
-import GHC.Driver.Types
+import GHC hiding (lookupName)
+import GHC.Driver.Ppr
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State
import GHC.Types.Name.Reader
-import GHC.Tc.Types
+import GHC.Tc.Types hiding (IfM)
import GHC.Data.FastString ( unpackFS, bytesFS )
-import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
+import GHC.Types.Basic ( PromotionFlag(..) )
+import GHC.Types.SourceText
import qualified GHC.Utils.Outputable as O
+import GHC.Utils.Panic
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.Module.Warnings
-mkExceptionContext :: TypecheckedModule -> String
-mkExceptionContext =
- ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-
--- | Use a 'TypecheckedModule' to produce an 'Interface'.
--- To do this, we need access to already processed modules in the topological
--- sort. That's what's in the 'IfaceMap'.
-createInterface :: HasCallStack
- => TypecheckedModule
- -> [Flag] -- Boolean flags
- -> IfaceMap -- Locally processed modules
- -> InstIfaceMap -- External, already installed interfaces
- -> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap =
- withExceptionContext (mkExceptionContext tm) $ do
-
- let ms = pm_mod_summary . tm_parsed_module $ tm
- mi = moduleInfo tm
- L _ hsm = parsedSource tm
- !safety = modInfoSafe mi
- mdl = ms_mod ms
- sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
- is_sig = ms_hsc_src ms == HsigFile
- dflags = ms_hspp_opts ms
- !instances = modInfoInstances mi
- !fam_instances = md_fam_insts md
- !exportedNames = modInfoExportsWithSelectors mi
- (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
- pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
-
- (TcGblEnv { tcg_rdr_env = gre
- , tcg_warns = warnings
- , tcg_exports = all_exports0
- }, md) = tm_internals_ tm
- all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre
-
- -- The 'pkgName' is necessary to decide what package to mention in "@since"
- -- annotations. Not having it is not fatal though.
- --
- -- Cabal can be trusted to pass the right flags, so this warning should be
- -- mostly encountered when running Haddock outside of Cabal.
- when (isNothing pkgName) $
- liftErrMsg $ tell [ "Warning: Package name is not available." ]
-
- -- The renamed source should always be available to us, but it's best
- -- to be on the safe side.
- (group_, imports, mayExports, mayDocHeader) <-
- case renamedSource tm of
- Nothing -> do
- liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
- return (emptyRnGroup, [], Nothing, Nothing)
- Just x -> return x
-
- opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
+newtype IfEnv m = IfEnv
+ {
+ -- | Lookup names in the enviroment.
+ ife_lookup_name :: Name -> m (Maybe TyThing)
+ }
+
+
+-- | A monad in which we create Haddock interfaces. Not to be confused with
+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
+--
+-- In the past `createInterface` was running in the `Ghc` monad but proved hard
+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
+-- over the Ghc specific clarifies where side effects happen.
+newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a }
+
+
+deriving newtype instance Functor m => Functor (IfM m)
+deriving newtype instance Applicative m => Applicative (IfM m)
+deriving newtype instance Monad m => Monad (IfM m)
+deriving newtype instance MonadIO m => MonadIO (IfM m)
+deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)
+deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)
+
+
+-- | Run an `IfM` action.
+runIfM
+ -- | Lookup a global name in the current session. Used in cases
+ -- where declarations don't
+ :: (Name -> m (Maybe TyThing))
+ -- | The action to run.
+ -> IfM m a
+ -- | Result and accumulated error/warning messages.
+ -> m (a, [ErrMsg])
+runIfM lookup_name action = do
+ let
+ if_env = IfEnv
+ {
+ ife_lookup_name = lookup_name
+ }
+ runWriterT (runReaderT (unIfM action) if_env)
+
+
+liftErrMsg :: Monad m => ErrMsgM a -> IfM m a
+liftErrMsg action = do
+ writer (runWriter action)
+
+
+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
+lookupName name = IfM $ do
+ lookup_name <- asks ife_lookup_name
+ lift $ lift (lookup_name name)
+
+
+createInterface1
+ :: MonadIO m
+ => [Flag]
+ -> UnitState
+ -> ModSummary
+ -> TcGblEnv
+ -> IfaceMap
+ -> InstIfaceMap
+ -> IfM m Interface
+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
+
+ let
+ ModSummary
+ {
+ -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
+ -- pragmas in the modules source code. Used to infer
+ -- safety of module.
+ ms_hspp_opts
+ , ms_location = ModLocation
+ {
+ ml_hie_file
+ }
+ } = mod_sum
+
+ TcGblEnv
+ {
+ tcg_mod
+ , tcg_src
+ , tcg_semantic_mod
+ , tcg_rdr_env
+ , tcg_exports
+ , tcg_insts
+ , tcg_fam_insts
+ , tcg_warns
+
+ -- Renamed source
+ , tcg_rn_imports
+ , tcg_rn_exports
+ , tcg_rn_decls
+
+ , tcg_doc_hdr
+ } = tc_gbl_env
+
+ dflags = ms_hspp_opts
+
+ is_sig = tcg_src == HsigFile
+
+ (pkg_name_fs, _) =
+ modulePackageInfo unit_state flags (Just tcg_mod)
+
+ pkg_name :: Maybe Package
+ pkg_name =
+ let
+ unpack (PackageName name) = unpackFS name
+ in
+ fmap unpack pkg_name_fs
+
+ fixities :: FixMap
+ fixities = case tcg_rn_decls of
+ Nothing -> mempty
+ Just dx -> mkFixMap dx
+
+ -- Locations of all the TH splices
+ loc_splices :: [SrcSpan]
+ loc_splices = case tcg_rn_decls of
+ Nothing -> []
+ Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]
+
+ decls <- case tcg_rn_decls of
+ Nothing -> do
+ tell [ "Warning: Renamed source is not available" ]
+ pure []
+ Just dx ->
+ pure (topDecls dx)
+
+ -- Derive final options to use for haddocking this module
+ doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod
+
+ let
+ -- All elements of an explicit export list, if present
+ export_list :: Maybe [(IE GhcRn, Avails)]
+ export_list
+ | OptIgnoreExports `elem` doc_opts =
+ Nothing
+ | Just rn_exports <- tcg_rn_exports =
+ Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]
+ | otherwise =
+ Nothing
+
+ -- All the exported Names of this module.
+ exported_names :: [Name]
+ exported_names =
+ concatMap availNamesWithSelectors tcg_exports
+
+ -- Module imports of the form `import X`. Note that there is
+ -- a) no qualification and
+ -- b) no import list
+ imported_modules :: Map ModuleName [ModuleName]
+ imported_modules
+ | Just{} <- export_list =
+ unrestrictedModuleImports (map unLoc tcg_rn_imports)
+ | otherwise =
+ M.empty
+
+ -- TyThings that have instances defined in this module
+ local_instances :: [Name]
+ local_instances =
+ [ name
+ | name <- map getName tcg_insts ++ map getName tcg_fam_insts
+ , nameIsLocalOrFrom tcg_semantic_mod name
+ ]
+
+ -- Infer module safety
+ safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)
-- Process the top-level module header documentation.
- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
-
- let declsWithDocs = topDecls group_
-
- exports0 = fmap (map (first unLoc)) mayExports
- (all_exports, exports)
- | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
- | otherwise = (all_exports0, exports0)
-
- unrestrictedImportedMods
- -- module re-exports are only possible with
- -- explicit export list
- | Just{} <- exports
- = unrestrictedModuleImports (map unLoc imports)
- | otherwise = M.empty
-
- fixMap = mkFixMap group_
- (decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom sem_mdl)
- $ map getName fam_instances
- ++ map getName instances
- -- Locations of all TH splices
- splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
-
- warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
-
- maps@(!docMap, !argMap, !declMap, _) <-
- liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)
-
- let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-
- -- The MAIN functionality: compute the export items which will
- -- each be the actual documentation of this module.
- exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre
- exportedNames decls maps fixMap unrestrictedImportedMods
- splices exports all_exports instIfaceMap dflags
-
- let !visibleNames = mkVisibleNames maps exportItems opts
-
- -- Measure haddock documentation coverage.
- let prunedExportItems0 = pruneExportItems exportItems
- !haddockable = 1 + length exportItems -- module + exports
- !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
- !coverage = (haddockable, haddocked)
-
- -- Prune the export list to just those declarations that have
- -- documentation, if the 'prune' option is on.
- let prunedExportItems'
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
- !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
-
- let !aliases =
- mkAliasMap (unitState dflags) $ tm_renamed_source tm
-
- modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
-
- -- Prune the docstring 'Map's to keep only docstrings that are not private.
- --
- -- Besides all the names that GHC has told us this module exports, we also
- -- keep the docs for locally defined class instances. This is more names than
- -- we need, but figuring out which instances are fully private is tricky.
- --
- -- We do this pruning to avoid having to rename, emit warnings, and save
- -- docstrings which will anyways never be rendered.
- let !localVisibleNames = S.fromList (localInsts ++ exportedNames)
- !prunedDocMap = M.restrictKeys docMap localVisibleNames
- !prunedArgMap = M.restrictKeys argMap localVisibleNames
-
- return $! Interface {
- ifaceMod = mdl
- , ifaceIsSig = is_sig
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = prunedDocMap
- , ifaceArgMap = prunedArgMap
- , ifaceRnDocMap = M.empty -- Filled in `renameInterface`
- , ifaceRnArgMap = M.empty -- Filled in `renameInterface`
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = [] -- Filled in `renameInterface`
- , ifaceExports = exportedNames
- , ifaceVisibleExports = visibleNames
- , ifaceDeclMap = declMap
- , ifaceFixMap = fixMap
- , ifaceModuleAliases = aliases
- , ifaceInstances = instances
- , ifaceFamInstances = fam_instances
- , ifaceOrphanInstances = [] -- Filled in `attachInstances`
- , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
- , ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warningMap
- , ifaceHieFile = Just $ ml_hie_file $ ms_location ms
- , ifaceDynFlags = dflags
- }
+ (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
+ tcg_rdr_env safety tcg_doc_hdr
+
+ -- Warnings on declarations in this module
+ decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
+
+ -- Warning on the module header
+ mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)
+
+ let
+ -- Warnings in this module and transitive warnings from dependend modules
+ warnings :: Map Name (Doc Name)
+ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))
+
+ maps@(!docs, !arg_docs, !decl_map, _) <-
+ liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)
+
+ export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod
+ warnings tcg_rdr_env exported_names (map fst decls) maps fixities
+ imported_modules loc_splices export_list tcg_exports inst_ifaces dflags
+
+ let
+ visible_names :: [Name]
+ visible_names = mkVisibleNames maps export_items doc_opts
+
+ -- Measure haddock documentation coverage.
+ pruned_export_items :: [ExportItem GhcRn]
+ pruned_export_items = pruneExportItems export_items
+
+ !haddockable = 1 + length export_items -- module + exports
+ !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items
+
+ coverage :: (Int, Int)
+ !coverage = (haddockable, haddocked)
+
+ aliases :: Map Module ModuleName
+ aliases = mkAliasMap unit_state tcg_rn_imports
+
+ return $! Interface
+ {
+ ifaceMod = tcg_mod
+ , ifaceIsSig = is_sig
+ , ifaceOrigFilename = msHsFilePath mod_sum
+ , ifaceHieFile = Just ml_hie_file
+ , ifaceInfo = info
+ , ifaceDoc = Documentation header_doc mod_warning
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = doc_opts
+ , ifaceDocMap = docs
+ , ifaceArgMap = arg_docs
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = if OptPrune `elem` doc_opts then
+ pruned_export_items else export_items
+ , ifaceRnExportItems = []
+ , ifaceExports = exported_names
+ , ifaceVisibleExports = visible_names
+ , ifaceDeclMap = decl_map
+ , ifaceFixMap = fixities
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = tcg_insts
+ , ifaceFamInstances = tcg_fam_insts
+ , ifaceOrphanInstances = [] -- Filled in attachInstances
+ , ifaceRnOrphanInstances = [] -- Filled in attachInstances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warnings
+ , ifaceDynFlags = dflags
+ }
-- | Given all of the @import M as N@ declarations in a package,
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
-- will go in 'ifaceModuleAliases'.
-mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap state mRenamedSource =
- case mRenamedSource of
- Nothing -> M.empty
- Just (_,impDecls,_,_) ->
- M.fromList $
- mapMaybe (\(SrcLoc.L _ impDecl) -> do
- SrcLoc.L _ alias <- ideclAs impDecl
- return $
- (lookupModuleDyn state
- -- TODO: This is supremely dodgy, because in general the
- -- UnitId isn't going to look anything like the package
- -- qualifier (even with old versions of GHC, the
- -- IPID would be p-0.1, but a package qualifier never
- -- has a version number it. (Is it possible that in
- -- Haddock-land, the UnitIds never have version numbers?
- -- I, ezyang, have not quite understand Haddock's package
- -- identifier model.)
- --
- -- Additionally, this is simulating some logic GHC already
- -- has for deciding how to qualify names when it outputs
- -- them to the user. We should reuse that information;
- -- or at least reuse the renamed imports, which know what
- -- they import!
- (fmap Module.fsToUnit $
- fmap sl_fs $ ideclPkgQual impDecl)
- (case ideclName impDecl of SrcLoc.L _ name -> name),
- alias))
- impDecls
+mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName
+mkAliasMap state impDecls =
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ SrcLoc.L _ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn state
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
+ (fmap Module.fsToUnit $
+ fmap sl_fs $ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
-- We want to know which modules are imported without any qualification. This
-- way we can display module reexports more compactly. This mapping also looks
@@ -257,7 +346,7 @@ mkAliasMap state mRenamedSource =
--
-- With our mapping we know that we can display exported modules M1 and M2.
--
-unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName]
+unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName]
unrestrictedModuleImports idecls =
M.map (map (unLoc . ideclName))
$ M.filter (all isInteresting) impModMap
@@ -306,7 +395,7 @@ mkWarningMap dflags warnings gre exps = case warnings of
let ws' = [ (n, w)
| (occ, w) <- ws
, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
+ , let n = greMangledName elt, n `elem` exps ]
in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
@@ -436,7 +525,7 @@ mkMaps dflags pkgName gre instances decls = do
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
-- get the identifier with the right location.
- TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))
+ TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -470,7 +559,7 @@ mkFixMap group_ =
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: HasCallStack
+ :: Monad m
=> Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
@@ -488,7 +577,7 @@ mkExportItems
-> Avails -- exported stuff from this module
-> InstIfaceMap
-> DynFlags
- -> ErrMsgGhc [ExportItem GhcRn]
+ -> IfM m [ExportItem GhcRn]
mkExportItems
is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
maps fixMap unrestricted_imp_mods splices exportList allExports
@@ -509,7 +598,7 @@ mkExportItems
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unLoc d | d <- decls ] >>= \case
+ findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
@@ -530,25 +619,39 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: HasCallStack
- => Bool -- is it a signature
- -> IfaceMap
- -> Module -- this module
- -> Module -- semantic module
- -> WarningMap
- -> [Name] -- exported names (orig)
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> InstIfaceMap
- -> DynFlags
- -> AvailInfo
- -> ErrMsgGhc [ExportItem GhcRn]
+
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)
+minimalDef n = do
+ mty <- lookupName n
+ case mty of
+ Just (ATyCon (tyConClass_maybe -> Just c)) ->
+ return . Just $ classMinimalDef c
+ _ ->
+ return Nothing
+
+
+availExportItem
+ :: forall m
+ . Monad m
+ => Bool -- is it a signature
+ -> IfaceMap
+ -> Module -- this module
+ -> Module -- semantic module
+ -> WarningMap
+ -> [Name] -- exported names (orig)
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> AvailInfo
+ -> IfM m [ExportItem GhcRn]
availExportItem is_sig modMap thisMod semMod warnings exportedNames
(docMap, argMap, declMap, _) fixMap splices instIfaceMap
dflags availInfo = declWith availInfo
where
- declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]
+ declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]
declWith avail = do
let t = availName avail
r <- findDecl avail
@@ -558,13 +661,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unLoc decl)
+ let declNames = getMainDeclBinder (unL decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unLoc decl) ->
+ Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
@@ -584,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig
in availExportDecl avail newDecl docs_
- L loc (TyClD _ cl@ClassDecl{}) -> do
- mdef <- liftGhcToErrMsgGhc $ minimalDef t
+ L loc (TyClD _ ClassDecl {..}) -> do
+ mdef <- minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
- (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+ (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
_ -> availExportDecl avail decl docs_
@@ -614,7 +717,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
- availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+ availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl declName parentDecl =
case extractDecl declMap declName parentDecl of
Right d -> pure d
@@ -622,11 +725,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
synifiedDeclOpt <- hiDecl dflags declName
case synifiedDeclOpt of
Just synifiedDecl -> pure synifiedDecl
- Nothing -> O.pprPanic "availExportItem" (O.text err)
+ Nothing -> pprPanic "availExportItem" (O.text err)
availExportDecl :: AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
- -> ErrMsgGhc [ ExportItem GhcRn ]
+ -> IfM m [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
| availExportsDecl avail = do
extractedDecl <- availDecl (availName avail) decl
@@ -672,7 +775,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
- findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl avail
| m == semMod =
case M.lookup n declMap of
@@ -701,10 +804,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
n = availName avail
m = nameModule n
- findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+ findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
findBundledPatterns avail = do
patsyns <- for constructor_names $ \name -> do
- mtyThing <- liftGhcToErrMsgGhc (lookupName name)
+ mtyThing <- lookupName name
case mtyThing of
Just (AConLike PatSynCon{}) -> do
export_items <- declWith (Avail.avail name)
@@ -720,16 +823,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
constructor_names =
filter isDataConName (availSubordinates avail)
--- this heavily depends on the invariants stated in Avail
-availExportsDecl :: AvailInfo -> Bool
-availExportsDecl (AvailTC ty_name names _)
- | n : _ <- names = ty_name == n
- | otherwise = False
-availExportsDecl _ = True
-
availSubordinates :: AvailInfo -> [Name]
-availSubordinates avail =
- filter (/= availName avail) (availNamesWithSelectors avail)
+availSubordinates = map greNameMangledName . availSubordinateGreNames
availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]
availNoDocs avail =
@@ -742,10 +837,9 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
--- | Reify a declaration from the GHC internal 'TyThing' representation.
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
+hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))
hiDecl dflags t = do
- mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ mayTyThing <- lookupName t
case mayTyThing of
Nothing -> do
liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
@@ -758,14 +852,15 @@ hiDecl dflags t = do
warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
O.comma O.<+> O.quotes (O.ppr t) O.<+>
O.text "-- Please report this on Haddock issue tracker!"
- bugWarn = O.showSDoc dflags . warnLine
+ bugWarn = showSDoc dflags . warnLine
-- | This function is called for top-level bindings without type signatures.
-- It gets the type signature from GHC and that means it's not going to
-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
-- declaration and use it instead - 'nLoc' here.
-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
- -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)
+hiValExportItem
+ :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+ -> Maybe Fixity -> IfM m (ExportItem GhcRn)
hiValExportItem dflags name nLoc doc splice fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
@@ -795,12 +890,14 @@ lookupDocs avail warnings docMap argMap =
-- | Export the given module as `ExportModule`. We are not concerned with the
-- single export items of the given module.
-moduleExport :: Module -- ^ Module A (identity, NOT semantic)
- -> DynFlags -- ^ The flags used when typechecking A
- -> IfaceMap -- ^ Already created interfaces
- -> InstIfaceMap -- ^ Interfaces in other packages
- -> ModuleName -- ^ The exported module
- -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items
+moduleExport
+ :: Monad m
+ => Module -- ^ Module A (identity, NOT semantic)
+ -> DynFlags -- ^ The flags used when typechecking A
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> ModuleName -- ^ The exported module
+ -> IfM m [ExportItem GhcRn] -- ^ Resulting export items
moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- NB: we constructed the identity module when looking up in
-- the IfaceMap.
@@ -814,9 +911,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
- liftErrMsg $
- tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty dflags expMod]
+ liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
return []
where
m = mkModule (moduleUnit thisMod) expMod -- Identity module!
@@ -842,22 +938,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- every locally defined declaration is exported; thus, we just
-- zip through the renamed declarations.
-fullModuleContents :: Bool -- is it a signature
- -> IfaceMap
- -> Maybe Package -- this package
- -> Module -- this module
- -> Module -- semantic module
- -> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment
- -> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> InstIfaceMap
- -> DynFlags
- -> Avails
- -> ErrMsgGhc [ExportItem GhcRn]
+fullModuleContents
+ :: Monad m
+ => Bool -- is it a signature
+ -> IfaceMap
+ -> Maybe Package -- this package
+ -> Module -- this module
+ -> Module -- semantic module
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> [Name] -- exported names (orig)
+ -> [LHsDecl GhcRn] -- renamed source declarations
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> InstIfaceMap
+ -> DynFlags
+ -> Avails
+ -> IfM m [ExportItem GhcRn]
fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
let availEnv = availsToNameEnv (nubAvails avails)
@@ -870,7 +968,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
return [[ExportDoc doc]]
(L _ (ValD _ valDecl))
- | name:_ <- collectHsBindBinders valDecl
+ | name:_ <- collectHsBindBinders CollNoDictBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> return []
_ ->
@@ -885,7 +983,6 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
isSigD (L _ SigD{}) = True
isSigD _ = False
-
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
@@ -936,7 +1033,7 @@ extractDecl declMap name decl
TyClD _ d@DataDecl { tcdLName = L _ dataNm
, tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do
- let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))
+ let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d)
lsig <- if isDataConName name
then extractPatternSyn name dataNm ty_args dataCons
else extractRecSel name dataNm ty_args dataCons
@@ -946,30 +1043,26 @@ extractDecl declMap name decl
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ famName
- , feqn_pats = ty_args
- , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do
- lsig <- if isDataConName name
- then extractPatternSyn name famName ty_args dataCons
- else extractRecSel name famName ty_args dataCons
- pure (SigD noExtField <$> lsig)
+ InstD _ (DataFamInstD _ (DataFamInstDecl
+ (FamEqn { feqn_tycon = L _ n
+ , feqn_pats = tys
+ , feqn_rhs = defn }))) ->
+ if isDataConName name
+ then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn)
+ else fmap (SigD noExtField) <$> extractRecSel name n tys (dd_cons defn)
InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
| isDataConName name ->
- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons }
- }
- })) <- insts
- , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)
+ let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts
+ , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
]
in case matches of
[d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))
_ -> Left "internal: extractDecl (ClsInstD)"
| otherwise ->
- let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+ let matches = [ d' | L _ d'@(DataFamInstDecl d )
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
- , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
+ , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
, extFieldOcc n == name
@@ -979,10 +1072,13 @@ extractDecl declMap name decl
_ -> Left "internal: extractDecl (ClsInstD)"
_ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
-extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)
+extractPatternSyn :: HasCallStack
+ => Name -> Name
+ -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
+ -> Either ErrMsg (LSig GhcRn)
extractPatternSyn nm t tvs cons =
case filter matches cons of
- [] -> Left . O.showSDocUnsafe $
+ [] -> Left . O.showSDocOneLine O.defaultSDocContext $
O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
con:_ -> pure (extract <$> con)
where
@@ -991,17 +1087,21 @@ extractPatternSyn nm t tvs cons =
extract :: ConDecl GhcRn -> Sig GhcRn
extract con =
let args =
- case getConArgs con of
- PrefixCon args' -> (map hsScaledThing args')
- RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
- InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+ case con of
+ ConDeclH98 { con_args = con_args' } -> case con_args' of
+ PrefixCon _ args' -> map hsScaledThing args'
+ RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+ InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+ ConDeclGADT { con_g_args = con_args' } -> case con_args' of
+ PrefixConGADT args' -> map hsScaledThing args'
+ RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)
_ -> typ
typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
- in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
+ in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
@@ -1019,9 +1119,9 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
- case getConArgs con of
- RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ case getRecConArgs_maybe con of
+ Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 95889a63..92fb2e75 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -5,7 +5,7 @@ module Haddock.Interface.Json (
, renderJson
) where
-import GHC.Types.Basic
+import GHC.Types.Fixity
import GHC.Utils.Json
import GHC.Unit.Module
import GHC.Types.Name
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 87210273..6da89e7c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -21,8 +22,8 @@ module Haddock.Interface.LexParseRn
import Control.Arrow
import Control.Monad
-import Data.Functor (($>))
-import Data.List (maximumBy, (\\))
+import Data.Functor
+import Data.List ((\\), maximumBy)
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
import GHC.Driver.Session (languageExtensions)
@@ -32,8 +33,9 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import GHC.Types.Name
+import GHC.Types.Avail ( availName )
import GHC.Parser.PostProcess
-import GHC.Utils.Outputable ( showPpr, showSDoc )
+import GHC.Driver.Ppr ( showPpr, showSDoc )
import GHC.Types.Name.Reader
import GHC.Data.EnumSet as EnumSet
@@ -134,7 +136,7 @@ rename dflags gre = rn
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (i $> gre_name a))
+ [a] -> pure $ DocIdentifier (i $> greMangledName a)
-- There are multiple names available.
gres -> ambiguous dflags i gres
@@ -199,9 +201,10 @@ ambiguous :: DynFlags
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
- let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres
+ let noChildren = map availName (gresToAvailInfo gres)
+ dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
" by specifying the type/value namespace explicitly.\n" ++
" Defaulting to the one defined " ++ defnLoc dflt
@@ -210,10 +213,12 @@ ambiguous dflags x gres = do
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
- when (length (gresToAvailInfo gres) > 1) $ tell [msg]
- pure (DocIdentifier (x $> gre_name dflt))
+ when (length noChildren > 1) $ tell [msg]
+ pure (DocIdentifier (x $> dflt))
where
- defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name
+ isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
+ isLocalName _ = False
+ defnLoc = showSDoc dflags . pprNameDefnLoc
-- | Handle value-namespaced names that cannot be for values.
--
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index bb9cd02d..b212adce 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -213,10 +213,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki
renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
-renameLSigType = renameImplicit renameLType
+renameLSigType = mapM renameSigType
renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
-renameLSigWcType = renameWc (renameImplicit renameLType)
+renameLSigWcType = renameWc renameLSigType
renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
renameLKind = renameLType
@@ -310,12 +310,18 @@ renameType t = case t of
HsTyLit _ x -> return (HsTyLit noExtField x)
HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a
- (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
+ XHsType a -> pure (XHsType a)
HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy a -> pure (HsWildCardTy a)
+renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
+ bndrs' <- renameOuterTyVarBndrs bndrs
+ body' <- renameLType body
+ pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }
+
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
--
@@ -496,46 +502,55 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
- , con_doc = mbldoc }) = do
+ , con_doc = mbldoc
+ , con_forall = forall }) = do
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
- details' <- renameDetails details
+ details' <- renameH98Details details
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
+ , con_forall = forall -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
-renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
- , con_mb_cxt = lcontext, con_args = details
+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
+ , con_mb_cxt = lcontext, con_g_args = details
, con_res_ty = res_ty
- , con_doc = mbldoc }) = do
+ , con_doc = mbldoc } = do
lnames' <- mapM renameL lnames
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ bndrs' <- mapM renameOuterTyVarBndrs bndrs
lcontext' <- traverse renameLContext lcontext
- details' <- renameDetails details
+ details' <- renameGADTDetails details
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
- , con_mb_cxt = lcontext', con_args = details'
+ return (ConDeclGADT
+ { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'
+ , con_mb_cxt = lcontext', con_g_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' })
renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
-> RnM (HsScaled DocNameI (LHsType DocNameI))
renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
-renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
-renameDetails (RecCon (L l fields)) = do
+renameH98Details :: HsConDeclH98Details GhcRn
+ -> RnM (HsConDeclH98Details DocNameI)
+renameH98Details (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
return (RecCon (L l fields'))
- -- This causes an assertion failure
---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps
-renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
-renameDetails (InfixCon a b) = do
+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
+renameH98Details (InfixCon a b) = do
a' <- renameHsScaled a
b' <- renameHsScaled b
return (InfixCon a' b')
+renameGADTDetails :: HsConDeclGADTDetails GhcRn
+ -> RnM (HsConDeclGADTDetails DocNameI)
+renameGADTDetails (RecConGADT (L l fields)) = do
+ fields' <- mapM renameConDeclFieldField fields
+ return (RecConGADT (L l fields'))
+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
+
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
@@ -630,32 +645,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
; return (TyFamInstDecl { tfid_eqn = eqn' }) }
renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
-renameTyFamInstEqn eqn
- = renameImplicit rename_ty_fam_eqn eqn
- where
- rename_ty_fam_eqn
- :: FamEqn GhcRn (LHsType GhcRn)
- -> RnM (FamEqn DocNameI (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
- , feqn_pats = pats, feqn_fixity = fixity
- , feqn_rhs = rhs })
- = do { tc' <- renameL tc
- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
- ; pats' <- mapM renameLTypeArg pats
- ; rhs' <- renameLType rhs
- ; return (FamEqn { feqn_ext = noExtField
- , feqn_tycon = tc'
- , feqn_bndrs = bndrs'
- , feqn_pats = pats'
- , feqn_fixity = fixity
- , feqn_rhs = rhs' }) }
+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; bndrs' <- renameOuterTyVarBndrs bndrs
+ ; pats' <- mapM renameLTypeArg pats
+ ; rhs' <- renameLType rhs
+ ; return (FamEqn { feqn_ext = noExtField
+ , feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }) }
renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
renameTyFamDefltD = renameTyFamInstD
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
- = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
+ = do { eqn' <- rename_data_fam_eqn eqn
; return (DataFamInstDecl { dfid_eqn = eqn' }) }
where
rename_data_fam_eqn
@@ -665,7 +674,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = defn })
= do { tc' <- renameL tc
- ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+ ; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExtField
@@ -675,13 +684,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
-renameImplicit :: (in_thing -> RnM out_thing)
- -> HsImplicitBndrs GhcRn in_thing
- -> RnM (HsImplicitBndrs DocNameI out_thing)
-renameImplicit rn_thing (HsIB { hsib_body = thing })
- = do { thing' <- rn_thing thing
- ; return (HsIB { hsib_body = thing'
- , hsib_ext = noExtField }) }
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+ -> RnM (HsOuterTyVarBndrs flag DocNameI)
+renameOuterTyVarBndrs (HsOuterImplicit{}) =
+ pure $ HsOuterImplicit{hso_ximplicit = noExtField}
+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =
+ HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index ad2f61c2..f37e1da9 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Haddock.Interface.Specialize
@@ -38,7 +39,7 @@ specialize specs = go spec_map0
go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
- strip_kind_sig :: HsType name -> HsType name
+ strip_kind_sig :: HsType GhcRn -> HsType GhcRn
strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
@@ -57,7 +58,7 @@ specialize specs = go spec_map0
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a
specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
where
bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
@@ -74,13 +75,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+ TypeSig noExtField lnames (typ {hswc_body = noLoc typ'})
where
- true_type :: HsType GhcRn
- true_type = unLoc (hsSigWcType typ)
- typ' :: HsType GhcRn
+ true_type :: HsSigType GhcRn
+ true_type = unLoc (dropWildCards typ)
+ typ' :: HsSigType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
- fv = foldr Set.union Set.empty . map freeVariables $ typs
+ fv = foldr Set.union Set.empty . map freeVariablesType $ typs
specializeSig _ _ sig = sig
@@ -121,7 +122,7 @@ sugarTuples typ =
aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy _ (L _ typ')) = aux apps typ'
aux apps (HsTyVar _ _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps
+ | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedOrConstraintTuple apps
where
name' = getName name
strName = getOccString name
@@ -176,19 +177,25 @@ parseTupleArity _ = Nothing
-- not converted to 'String' or alike to avoid new allocations. Additionally,
-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
-- quite nice.
-type NameRep = FastString
+newtype NameRep
+ = NameRep FastString
+ deriving (Eq)
+
+instance Ord NameRep where
+ compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2
+
getNameRep :: NamedThing name => name -> NameRep
-getNameRep = getOccFS
+getNameRep = NameRep . getOccFS
nameRepString :: NameRep -> String
-nameRepString = unpackFS
+nameRepString (NameRep fs) = unpackFS fs
stringNameRep :: String -> NameRep
-stringNameRep = mkFastString
+stringNameRep = NameRep . mkFastString
setInternalNameRep :: SetName name => NameRep -> name -> name
-setInternalNameRep = setInternalOccName . mkVarOccFS
+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)
setInternalOccName :: SetName name => OccName -> name -> name
setInternalOccName occ name =
@@ -198,23 +205,37 @@ setInternalOccName occ name =
nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
--- | Compute set of free variables of given type.
-freeVariables :: HsType GhcRn -> Set Name
-freeVariables =
- everythingWithState Set.empty Set.union query
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesType :: HsType GhcRn -> Set Name
+freeVariablesType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType)
+
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesSigType :: HsSigType GhcRn -> Set Name
+freeVariablesSigType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)
+
+queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)
+queryType term ctx = case term of
+ HsForAllTy _ tele _ ->
+ (Set.empty, Set.union ctx (teleNames tele))
+ HsTyVar _ _ (L _ name)
+ | getName name `Set.member` ctx -> (Set.empty, ctx)
+ | otherwise -> (Set.singleton $ getName name, ctx)
+ _ -> (Set.empty, ctx)
where
- query term ctx = case cast term :: Maybe (HsType GhcRn) of
- Just (HsForAllTy _ tele _) ->
- (Set.empty, Set.union ctx (teleNames tele))
- Just (HsTyVar _ _ (L _ name))
- | getName name `Set.member` ctx -> (Set.empty, ctx)
- | otherwise -> (Set.singleton $ getName name, ctx)
- _ -> (Set.empty, ctx)
-
+ teleNames :: HsForAllTelescope GhcRn -> Set Name
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
- bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)
+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)
+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =
+ (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs)))
+
+bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name
+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
-- | Make given type visually unambiguous.
@@ -225,12 +246,12 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: Set Name -> HsType GhcRn -> HsType GhcRn
-rename fv typ = evalState (renameType typ) env
+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn
+rename fv typ = evalState (renameSigType typ) env
where
env = RenameEnv
{ rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
- , rneSigFVs = Set.map getNameRep $ freeVariables typ
+ , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ
, rneCtx = Map.empty
}
mkPair name = (getNameRep name, name)
@@ -245,6 +266,17 @@ data RenameEnv name = RenameEnv
}
+renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)
+renameSigType (HsSig x bndrs body) =
+ HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body
+
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+ -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)
+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =
+ HsOuterImplicit <$> mapM renameName imp_tvs
+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x <$> mapM renameLBinder exp_bndrs
+
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType (HsForAllTy x tele lt) =
HsForAllTy x
@@ -271,7 +303,7 @@ renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
renameType t@(HsRecTy _ _) = pure t
-renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType t@(XHsType _) = pure t
renameType (HsExplicitListTy x ip ltys) =
HsExplicitListTy x ip <$> renameLTypes ltys
renameType (HsExplicitTupleTy x ltys) =
@@ -362,3 +394,8 @@ alternativeNames name =
located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
+
+
+tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
+tyVarName (UserTyVar _ _ name) = unLoc name
+tyVarName (KindedTyVar _ _ (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 69201eb0..95bfc903 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -38,7 +38,7 @@ import GHC.Data.FastMutInt
import GHC.Data.FastString
import GHC hiding (NoLink)
import GHC.Driver.Monad (withSession)
-import GHC.Driver.Types
+import GHC.Driver.Env
import GHC.Types.Name.Cache
import GHC.Iface.Env
import GHC.Types.Name
@@ -94,7 +94,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0)
+#if MIN_VERSION_ghc(9,1,0) && !MIN_VERSION_ghc(9,2,0)
binaryInterfaceVersion = 38
binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 0b886d1a..4d22505f 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -24,6 +24,7 @@ module Haddock.Options (
optSourceCssFile,
sourceUrls,
wikiUrls,
+ optParCount,
optDumpInterfaceFile,
optShowInterfaceFile,
optLaTeXStyle,
@@ -45,10 +46,10 @@ import qualified Data.Char as Char
import Data.Version
import Control.Applicative
import GHC.Data.FastString
-import GHC ( DynFlags, Module, moduleUnit, unitState )
+import GHC ( Module, moduleUnit )
+import GHC.Unit.State
import Haddock.Types
import Haddock.Utils
-import GHC.Unit.State
import System.Console.GetOpt
import qualified Text.ParserCombinators.ReadP as RP
@@ -110,6 +111,7 @@ data Flag
| Flag_Reexport String
| Flag_SinceQualification String
| Flag_IgnoreLinkSymbol String
+ | Flag_ParCount (Maybe Int)
deriving (Eq, Show)
@@ -223,7 +225,9 @@ options backwardsCompat =
Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
"package qualification of @since, one of\n'always' (default) or 'only-external'",
Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
- "name of a symbol which does not trigger a warning in case of link issue"
+ "name of a symbol which does not trigger a warning in case of link issue",
+ Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
+ "load modules in parallel"
]
@@ -306,10 +310,11 @@ optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-
optMathjax :: [Flag] -> Maybe String
optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ]
+optParCount :: [Flag] -> Maybe (Maybe Int)
+optParCount flags = optLast [ n | Flag_ParCount n <- flags ]
qualification :: [Flag] -> Either String QualOption
qualification flags =
@@ -375,16 +380,16 @@ optLast xs = Just (last xs)
--
-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
-- specify this information manually and it is returned here if present.
-modulePackageInfo :: DynFlags
+modulePackageInfo :: UnitState
-> [Flag] -- ^ Haddock flags are checked as they may contain
-- the package name or version provided by the user
-- which we prioritise
-> Maybe Module
-> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
-modulePackageInfo dflags flags (Just modu) =
+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
+modulePackageInfo unit_state flags (Just modu) =
( optPackageName flags <|> fmap unitPackageName pkgDb
, optPackageVersion flags <|> fmap unitPackageVersion pkgDb
)
where
- pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)
+ pkgDb = lookupUnit unit_state (moduleUnit modu)
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e335ee19..ab2fa549 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -19,8 +19,9 @@ import Documentation.Haddock.Types
import Haddock.Types
import GHC.Driver.Session ( DynFlags )
+import GHC.Driver.Config
import GHC.Data.FastString ( fsLit )
-import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) )
+import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) )
import GHC.Parser ( parseIdentifier )
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name.Reader ( RdrName(..) )
@@ -48,7 +49,7 @@ parseIdent dflags ns str0 =
PFailed{} -> Nothing
where
realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
- pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc
+ pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc
(wrap,str1) = case str0 of
'(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names
-> (Parenthesized, init s)
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 7e34ae8c..fc946c8e 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -6,7 +6,7 @@
module Haddock.Syb
( everything, everythingButType, everythingWithState
, everywhere, everywhereButType
- , mkT
+ , mkT, mkQ, extQ
, combine
) where
@@ -91,6 +91,21 @@ mkT f = case cast f of
Just f' -> f'
Nothing -> id
+-- | Create generic query.
+--
+-- Another function stolen from SYB package.
+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+(r `mkQ` br) a = case cast a of
+ Just b -> br b
+ Nothing -> r
+
+
+-- | Extend a generic query by a type-specific case.
+--
+-- Another function stolen from SYB package.
+extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
+extQ f g a = maybe (f a) g (cast a)
+
-- | Combine two queries into one using alternative combinator.
combine :: Alternative f => (forall a. Data a => a -> f r)
-> (forall a. Data a => a -> f r)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53d01565..83c9dd72 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -3,6 +3,9 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -25,20 +28,24 @@ module Haddock.Types (
, HsDocString, LHsDocString
, Fixity(..)
, module Documentation.Haddock.Types
+
+ -- $ Reexports
+ , runWriter
+ , tell
) where
-import Control.Arrow hiding ((<+>))
import Control.DeepSeq
import Control.Exception (throw)
-import Control.Monad (ap)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
import Data.Void (Void)
import Documentation.Haddock.Types
-import GHC.Types.Basic (Fixity(..), PromotionFlag(..))
+import GHC.Types.Basic (PromotionFlag(..))
+import GHC.Types.Fixity (Fixity(..))
import GHC
import GHC.Driver.Session (Language)
@@ -305,10 +312,12 @@ data DocName
data DocNameI
+type instance NoGhcTc DocNameI = DocNameI
+
type instance IdP DocNameI = DocName
instance CollectPass DocNameI where
- collectXXPat _ ext = noExtCon ext
+ collectXXPat _ _ ext = noExtCon ext
instance NamedThing DocName where
getName (Documented name _) = name
@@ -628,26 +637,7 @@ data SinceQual
type ErrMsg = String
-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
-
-
-instance Functor ErrMsgM where
- fmap f (Writer (a, msgs)) = Writer (f a, msgs)
-
-instance Applicative ErrMsgM where
- pure a = Writer (a, [])
- (<*>) = ap
-
-instance Monad ErrMsgM where
- return = pure
- m >>= k = Writer $ let
- (a, w) = runWriter m
- (b, w') = runWriter (k a)
- in (b, w ++ w')
-
-
-tell :: [ErrMsg] -> ErrMsgM ()
-tell w = Writer ((), w)
+type ErrMsgM = Writer [ErrMsg]
-- Exceptions
@@ -681,46 +671,36 @@ withExceptionContext ctxt =
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
-- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
---instance MonadIO ErrMsgGhc where
--- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
---er, implementing GhcMonad involves annoying ExceptionMonad and
---WarnLogMonad classes, so don't bother.
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = WriterGhc . return . runWriter
--- for now, use (liftErrMsg . tell) for this
---tell :: [ErrMsg] -> ErrMsgGhc ()
---tell msgs = WriterGhc $ return ( (), msgs )
+newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a }
-instance Functor ErrMsgGhc where
- fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
+deriving newtype instance Functor ErrMsgGhc
+deriving newtype instance Applicative ErrMsgGhc
+deriving newtype instance Monad ErrMsgGhc
+deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc
+deriving newtype instance MonadIO ErrMsgGhc
-instance Applicative ErrMsgGhc where
- pure a = WriterGhc (return (a, []))
- (<*>) = ap
-instance Monad ErrMsgGhc where
- return = pure
- m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
- fmap (second (msgs1 ++)) (runWriterGhc (k a))
+runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])
+runWriterGhc = runWriterT . unErrMsgGhc
-instance MonadIO ErrMsgGhc where
- liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
-
-instance MonadThrow ErrMsgGhc where
- throwM e = WriterGhc (throwM e)
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = ErrMsgGhc . lift
-instance MonadCatch ErrMsgGhc where
- catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f))
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = writer . runWriter
-----------------------------------------------------------------------------
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance XRec DocNameI f = Located (f DocNameI)
+type instance XRec DocNameI a = Located a
+instance UnXRec DocNameI where
+ unXRec = unLoc
+instance MapXRec DocNameI where
+ mapXRec = fmap
+instance WrapXRec DocNameI where
+ wrapXRec = noLoc
type instance XForAllTy DocNameI = NoExtField
type instance XQualTy DocNameI = NoExtField
@@ -744,7 +724,7 @@ type instance XExplicitListTy DocNameI = NoExtField
type instance XExplicitTupleTy DocNameI = NoExtField
type instance XTyLit DocNameI = NoExtField
type instance XWildCardTy DocNameI = NoExtField
-type instance XXType DocNameI = NewHsTypeX
+type instance XXType DocNameI = HsCoreTy
type instance XHsForAllVis DocNameI = NoExtField
type instance XHsForAllInvis DocNameI = NoExtField
@@ -799,9 +779,14 @@ type instance XFamDecl DocNameI = NoExtField
type instance XXFamilyDecl DocNameI = NoExtCon
type instance XXTyClDecl DocNameI = NoExtCon
-type instance XHsIB DocNameI _ = NoExtField
-type instance XHsWC DocNameI _ = NoExtField
-type instance XXHsImplicitBndrs DocNameI _ = NoExtCon
+type instance XHsWC DocNameI _ = NoExtField
+
+type instance XHsOuterExplicit DocNameI _ = NoExtField
+type instance XHsOuterImplicit DocNameI = NoExtField
+type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon
+
+type instance XHsSig DocNameI = NoExtField
+type instance XXHsSigType DocNameI = NoExtCon
type instance XHsQTvs DocNameI = NoExtField
type instance XConDeclField DocNameI = NoExtField
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 0c9c6073..314b8db9 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:30:20 +0000