aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs61
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs66
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs94
-rw-r--r--haddock-api/src/Haddock/Convert.hs44
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs76
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs70
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs69
-rw-r--r--haddock-api/src/Haddock/Syb.hs17
-rw-r--r--haddock-api/src/Haddock/Types.hs11
-rw-r--r--haddock-api/src/Haddock/Utils.hs34
11 files changed, 350 insertions, 209 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 8939664d..44841bc5 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -71,27 +71,31 @@ ppModule dflags iface =
---------------------------------------------------------------------
-- Utility functions
-dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
-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 $ unL 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
@@ -135,8 +139,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 _ = []
@@ -145,8 +149,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
@@ -155,9 +159,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
@@ -250,7 +254,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
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.
@@ -269,7 +274,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
where
f = [typeSig name (getGADTConTypeG con)]
- typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
+ typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d0528322..3a774ace 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -210,10 +210,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
@@ -296,7 +296,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 (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig (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
@@ -308,7 +308,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 doc [name] (hsSigTypeI typ) unicode
+ ppFunSig doc [name] typ unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -343,9 +343,9 @@ ppFamDecl 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)
@@ -396,7 +396,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
@@ -411,7 +411,7 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI
+ppFunSig :: DocForDecl DocName -> [DocName] -> LHsSigType DocNameI
-> Bool -> LaTeX
ppFunSig doc docnames (L _ typ) unicode =
ppTypeOrFunSig typ doc
@@ -437,12 +437,12 @@ ppLPatSig doc docnames ty unicode
)
unicode
where
- typ = unLoc (hsSigTypeI ty)
+ typ = unLoc ty
names = map getName docnames
-- | 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)
@@ -462,13 +462,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
@@ -505,12 +516,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = text "\\{"
-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
@@ -617,7 +632,7 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}" <> emph (text "Methods") $$
- vcat [ ppFunSig doc names (hsSigWcType typ) unicode
+ vcat [ ppFunSig doc names (dropWildCards typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -793,7 +808,7 @@ 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 of
@@ -868,18 +883,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
@@ -1000,12 +1013,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_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 <>
@@ -1038,6 +1057,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
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d80f8e95..8b9739f1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -62,9 +62,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
@@ -72,25 +72,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 doc (map unLoc lnames) lty fixities
splice unicode pkg qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+ [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
ppSigLike summary links loc mempty 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 =
@@ -101,7 +101,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 =
@@ -118,7 +118,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
@@ -139,15 +139,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 <+> ppForAll (mkHsForAllInvisTeleI bndrs) unicode qual
+
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]
@@ -239,7 +248,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 doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
+ = ppFunSig summary links loc doc [name] typ fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -250,13 +259,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
@@ -276,13 +286,13 @@ ppTyName = ppName Prefix
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
@@ -322,9 +332,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
@@ -518,7 +528,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names (hsSigTypeI typ)
+ [ ppFunSig summary links loc doc names typ
[] splice unicode pkg qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -568,7 +578,7 @@ ppClassDecl summary links instances fixities loc d subdocs
doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
- methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigTypeI typ)
+ methodBit = subMethods [ ppFunSig summary links loc doc [name] typ
subfixs splice unicode pkg qual
| L _ (ClassOpSig _ _ lnames typ) <- lsigs
, name <- map unLoc lnames
@@ -692,7 +702,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
@@ -755,7 +765,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
]
@@ -863,7 +873,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
)
@@ -933,7 +943,7 @@ 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
]
@@ -1037,18 +1047,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.
@@ -1102,6 +1111,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
@@ -1110,6 +1122,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 <>
@@ -1144,10 +1159,12 @@ 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 DocNameI -> 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
+ typ = sig_body (unLoc sig_typ)
+
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
@@ -1164,9 +1181,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
@@ -1176,6 +1200,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)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index c0347e56..2f342ba4 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -58,7 +58,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import Haddock.Types
import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
-
+import Haddock.Utils ( mkEmptySigType )
import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
@@ -104,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
@@ -170,14 +169,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
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
fam_tvs = tyConVisibleTyVars tc
@@ -371,6 +370,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
@@ -407,10 +412,9 @@ synifyDataCon use_gadt_syntax dc =
then do
let hat = mk_gadt_arg_tys
return $ noLoc $ ConDeclGADT
- { con_g_ext = []
+ { con_g_ext = noExtField
, con_names = [name]
- , con_forall = noLoc $ not $ null user_tvbndrs
- , con_qvars = map synifyTyVarBndr user_tvbndrs
+ , con_bndrs = noLoc outer_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
, con_res_ty = synifyType WithinType [] res_ty
@@ -531,17 +535,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'.
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index d6d12e4e..39d6d3fd 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -123,30 +123,28 @@ 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
-
mkHsForAllInvisTeleI ::
[LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
mkHsForAllInvisTeleI invis_bndrs =
HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
-getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
+mkHsImplicitSigTypeI body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}
+ , sig_body = body }
+
+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
+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 })
@@ -188,19 +186,17 @@ tcdNameI = unLoc . tyClDeclLNameI
-- -------------------------------------
-getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
+getGADTConTypeG :: ConDecl GhcRn -> LHsSigType 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
+getGADTConTypeG (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 = mkHsForAllInvisTele 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 })
@@ -244,7 +240,9 @@ 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 :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => 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
@@ -294,15 +292,37 @@ reparenTypePrec = go
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => 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 :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
+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 :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a)
+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 (mapXRec @a reparenTyVar) bndrs)
@@ -311,13 +331,17 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => 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, MapXRec a, UnXRec a, WrapXRec a) => 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
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index ecaf1a5d..a0e56f07 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -422,7 +422,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
@@ -904,26 +904,23 @@ 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 _ n
+ InstD _ (DataFamInstD _ (DataFamInstDecl
+ (FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
- , feqn_rhs = defn }}))) ->
+ , feqn_rhs = defn }))) ->
if isDataConName name
then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)
else 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 = dd
- }
- })) <- insts
+ 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)))
_ -> error "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)
, Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
@@ -963,7 +960,7 @@ extractPatternSyn nm t tvs cons =
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
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e7d19dfe..a1e712e0 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,10 +191,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
@@ -294,6 +294,12 @@ renameType t = case t of
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:
--
@@ -486,21 +492,20 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_forall = forall -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
-renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
, con_mb_cxt = lcontext, con_g_args = details
- , con_res_ty = res_ty, con_forall = forall
+ , con_res_ty = res_ty
, con_doc = mbldoc } = do
lnames' <- mapM renameL lnames
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ bndrs' <- mapM renameOuterTyVarBndrs bndrs
lcontext' <- traverse renameLContext lcontext
details' <- renameGADTDetails details
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (ConDeclGADT
- { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
+ { 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'
- , con_forall = forall}) -- Remove when #18311 is fixed
+ , con_res_ty = res_ty', con_doc = mbldoc' })
renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
-> RnM (HsScaled DocNameI (LHsType DocNameI))
@@ -618,32 +623,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
@@ -653,7 +652,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
@@ -663,13 +662,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 35e5258f..b19f52d0 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -56,7 +56,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
@@ -77,13 +77,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
@@ -207,25 +207,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 :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
- 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 . tyVarName . 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.
@@ -236,12 +248,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)
@@ -256,6 +268,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
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 6aad5dd1..7b261f4e 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -755,9 +755,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 1177fb18..aec7f9ab 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -17,7 +17,8 @@ module Haddock.Utils (
-- * Misc utilities
restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
- mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
+ mkEmptySigWcType, mkEmptySigType,
+ addClassContext, lHsQTyVarsToTypes,
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
@@ -131,21 +132,38 @@ mkMeta x = emptyMetaDoc { _doc = x }
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)
+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptySigType ty)
+
+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 }
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 }))
+ 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 })
- go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ , 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 })
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 14:50:13 +0000