aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs60
-rw-r--r--haddock-api/src/Haddock/Convert.hs139
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs32
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs17
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs24
-rw-r--r--haddock-api/src/Haddock/Types.hs4
-rw-r--r--haddock-api/src/Haddock/Utils.hs6
10 files changed, 198 insertions, 112 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e03611b2..27a7d804 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -71,7 +71,7 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e)
+ 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)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b49fc74e..0c323ae5 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -474,10 +474,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
- do_args _n leader (HsForAllTy _ fvf tvs ltype)
+ do_args _n leader (HsForAllTy _ tele ltype)
= [ ( decltt leader
- , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++
- [ppForAllSeparator unicode fvf]))
+ , decltt (ppHsForAllTelescope tele unicode)
<+> ppLType unicode ltype
) ]
do_args n leader (HsQualTy _ lctxt ltype)
@@ -506,12 +505,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = text "\\{"
-ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
-ppForAllSeparator unicode fvf =
- case fvf of
- ForallVis -> text "\\ " <> arrow unicode
- ForallInvis -> dot
-
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
@@ -519,6 +512,14 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
+ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX
+ppHsForAllTelescope tele unicode = case tele of
+ HsForAllVis { hsf_vis_bndrs = bndrs } ->
+ hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode
+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+ hsep (forallSymbol unicode : ppTyVars bndrs) <> dot
+
+
ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]
ppTyVars = map (ppSymName . getName . hsLTyVarNameI)
@@ -1040,9 +1041,8 @@ ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
- = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <>
- ppForAllSeparator unicode fvf
+ppr_mono_ty (HsForAllTy _ tele ty) unicode
+ = sep [ ppHsForAllTelescope tele unicode
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 36bc04c3..5163fb6b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -151,10 +151,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
- do_args n leader (HsForAllTy _ fvf tvs ltype)
+ do_args n leader (HsForAllTy _ tele ltype)
= do_largs n leader' ltype
where
- leader' = leader <+> ppForAll tvs unicode qual fvf
+ leader' = leader <+> ppForAll tele unicode qual
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -189,20 +189,22 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
-ppForAll :: [LHsTyVarBndr flag DocNameI] -> Unicode -> Qualification -> ForallVisFlag
+ppForAll :: HsForAllTelescope DocNameI -> Unicode -> Qualification
-> Html
-ppForAll tvs unicode qual fvf =
- case [ppKTv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
- [] -> noHtml
- ts -> forallSymbol unicode <+> hsep ts +++ ppForAllSeparator unicode fvf
- where ppKTv n k = parens $
- ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
-
-ppForAllSeparator :: Unicode -> ForallVisFlag -> Html
-ppForAllSeparator unicode fvf =
- case fvf of
- ForallVis -> spaceHtml +++ arrow unicode
- ForallInvis -> dot
+ppForAll tele unicode qual = case tele of
+ HsForAllVis { hsf_vis_bndrs = bndrs } ->
+ pp_bndrs bndrs (spaceHtml +++ arrow unicode)
+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+ pp_bndrs bndrs dot
+ where
+ pp_bndrs :: [LHsTyVarBndr flag DocNameI] -> Html -> Html
+ pp_bndrs tvs forall_separator =
+ case [pp_ktv n k | L _ (KindedTyVar _ _ (L _ n) k) <- tvs] of
+ [] -> noHtml
+ ts -> forallSymbol unicode <+> hsep ts +++ forall_separator
+
+ pp_ktv n k = parens $
+ ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
@@ -1146,16 +1148,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
hasNonEmptyContext :: LHsType name -> Bool
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
+ 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
- HsQualTy _ cxt _ -> null (unLoc cxt)
- HsFunTy _ _ s -> isFirstContextEmpty s
+ HsForAllTy _ _ s -> isFirstContextEmpty s
+ HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsFunTy _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1165,19 +1167,21 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
-ppForAllPart :: RenderableBndrFlag flag =>
- Unicode -> Qualification -> ForallVisFlag -> [LHsTyVarBndr flag DocNameI] -> Html
-ppForAllPart unicode qual fvf tvs =
- hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++
- ppForAllSeparator unicode fvf
+ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
+ppForAllPart unicode qual tele = case tele of
+ HsForAllVis { hsf_vis_bndrs = bndrs } ->
+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++
+ spaceHtml +++ arrow unicode
+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->
+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts
- = ppForAllPart unicode qual fvf tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
+ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts
+ = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts
ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 0020fc4c..b45b6eab 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -19,6 +19,8 @@ module Haddock.Convert (
PrintRuntimeReps(..),
) where
+#include "HsVersions.h"
+
import GHC.Data.Bag ( emptyBag )
import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)
, PromotionFlag(..), DefMethSpec(..) )
@@ -44,7 +46,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
, liftedRepDataConKey )
import GHC.Types.Unique ( getUnique )
-import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut )
+import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
+ , filterByList, filterOut )
+import GHC.Utils.Outputable ( assertPanic )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
@@ -53,7 +57,7 @@ import Haddock.Types
import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
-import Data.Maybe ( catMaybes, maybeToList )
+import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check
@@ -395,7 +399,7 @@ synifyDataCon use_gadt_syntax dc =
ConDeclGADT { con_g_ext = []
, con_names = [name]
, con_forall = noLoc $ not $ null user_tvbndrs
- , con_qvars = map synifyInvisTyVar user_tvbndrs
+ , con_qvars = map synifyTyVarBndr user_tvbndrs
, con_mb_cxt = ctx
, con_args = hat
, con_res_ty = synifyType WithinType [] res_ty
@@ -404,7 +408,7 @@ synifyDataCon use_gadt_syntax dc =
ConDeclH98 { con_ext = noExtField
, con_name = name
, con_forall = noLoc False
- , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs
+ , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
, con_mb_cxt = ctx
, con_args = hat
, con_doc = Nothing }
@@ -450,27 +454,25 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = []
, hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn
-synifyTyVar = synifyTyVar' emptyVarSet
+synifyTyVar = synify_ty_var emptyVarSet ()
+
+synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
+synifyTyVarBndr = synifyTyVarBndr' emptyVarSet
-synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
-synifyInvisTyVar = synifyInvisTyVar' emptyVarSet
+synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
+synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
--- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind
+-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
-- signatures (even if they don't have the lifted type kind).
-synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn
-synifyTyVar' no_kinds tv
+synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
+synify_ty_var no_kinds flag tv
| isLiftedTypeKind kind || tv `elemVarSet` no_kinds
- = noLoc (UserTyVar noExtField () (noLoc name))
- | otherwise = noLoc (KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
+ = noLoc (UserTyVar noExtField flag (noLoc name))
+ | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
-synifyInvisTyVar' :: VarSet -> InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
-synifyInvisTyVar' no_kinds (Bndr tv spec) = case (synifyTyVar' no_kinds tv) of
- L l (UserTyVar ne _ n) -> L l (UserTyVar ne spec n)
- L l (KindedTyVar ne _ n k) -> L l (KindedTyVar ne spec n k)
-
-- | Annotate (with HsKingSig) a type if the first parameter is True
-- and if the type contains a free variable.
-- This is used to synify type patterns for poly-kinded tyvars in
@@ -626,39 +628,56 @@ synifyType _ vs (AppTy t1 t2) = let
s1 = synifyType WithinType vs t1
s2 = synifyType WithinType vs t2
in noLoc $ HsAppTy noExtField s1 s2
-synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty
+synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty
synifyType _ vs (FunTy VisArg t1 t2) = let
s1 = synifyType WithinType vs t1
s2 = synifyType WithinType vs t2
in noLoc $ HsFunTy noExtField s1 s2
synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
- synifyForAllType s argf vs forallty
+ case argf of
+ Required -> synifyVisForAllType vs forallty
+ Invisible _ -> synifySigmaType s vs forallty
synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t
synifyType s vs (CastTy t _) = synifyType s vs t
synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
--- | Process a 'Type' which starts with a forall or a constraint into
--- an 'HsType'
-synifyForAllType
+-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
+synifyVisForAllType
+ :: [TyVar] -- ^ free variables in the type to convert
+ -> Type -- ^ the forall type to convert
+ -> LHsType GhcRn
+synifyVisForAllType vs ty =
+ let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty
+
+ sTvs = map synifyTyVarBndr tvs
+
+ -- Figure out what the type variable order would be inferred in the
+ -- absence of an explicit forall
+ tvs' = orderedFVs (mkVarSet vs) [rho]
+
+ in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs
+ , hst_xforall = noExtField
+ , hst_body = synifyType WithinType (tvs' ++ vs) rho }
+
+-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
+-- into an 'HsType'
+synifySigmaType
:: SynifyTypeState -- ^ what to do with the 'forall'
- -> ArgFlag -- ^ the visibility of the @forall@
-> [TyVar] -- ^ free variables in the type to convert
-> Type -- ^ the forall type to convert
-> LHsType GhcRn
-synifyForAllType s argf vs ty =
- let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
- inv_tvs = map to_invis_bndr tvs
+synifySigmaType s vs ty =
+ let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
, hst_body = synifyType WithinType (tvs' ++ vs) tau }
- sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf
- , hst_bndrs = sTvs
+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
, hst_xforall = noExtField
, hst_body = noLoc sPhi }
- sTvs = map synifyInvisTyVar inv_tvs
+ sTvs = map synifyTyVarBndr tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
@@ -672,12 +691,7 @@ synifyForAllType s argf vs ty =
| not (null tvs) -> noLoc sTy
| otherwise -> noLoc sPhi
- ImplicitizeForAll -> implicitForAll [] vs inv_tvs ctx (synifyType WithinType) tau
-
- where
- to_invis_bndr :: TyVarBinder -> InvisTVBinder
- to_invis_bndr (Bndr tv Required) = Bndr tv SpecifiedSpec
- to_invis_bndr (Bndr tv (Invisible spec)) = Bndr tv spec
+ ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
-- | Put a forall in if there are any type variables which require
-- explicit kind annotations or if the inferred type variable order
@@ -701,13 +715,12 @@ implicitForAll tycons vs tvs ctx synInner tau
= HsQualTy { hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
, hst_body = synInner (tvs' ++ vs) tau }
- sTy = HsForAllTy { hst_fvf = ForallInvis
- , hst_bndrs = sTvs
+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
, hst_xforall = noExtField
, hst_body = noLoc sPhi }
no_kinds_needed = noKindTyVars tycons tau
- sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs
+ sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
@@ -850,22 +863,54 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this
invariant didn't hold.
-}
--- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
+-- | A version of 'TcType.tcSplitSigmaTy' that:
+--
+-- 1. Preserves type synonyms.
+-- 2. Returns 'InvisTVBinder's instead of 'TyVar's.
--
-- See Note [Invariant: Never expand type synonyms]
-tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type)
-tcSplitSigmaTySameVisPreserveSynonyms argf ty =
- case tcSplitForAllTysSameVisPreserveSynonyms argf ty of
+tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type)
+tcSplitSigmaTyPreserveSynonyms ty =
+ case tcSplitForAllTysInvisPreserveSynonyms ty of
(tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of
(theta, tau) -> (tvs, theta, tau)
-- | See Note [Invariant: Never expand type synonyms]
-tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type)
-tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
+tcSplitSomeForAllTysPreserveSynonyms ::
+ (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type)
+tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty []
+ where
+ split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs
+ | argf_pred argf = split ty' ty' (tvb:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
+
+-- | See Note [Invariant: Never expand type synonyms]
+tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
+tcSplitForAllTysReqPreserveSynonyms ty =
+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty
+ req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in
+ ASSERT( req_bndrs `equalLength` all_bndrs )
+ (req_bndrs, body)
where
- split _ (ForAllTy tvbndr@(Bndr _ argf) ty') tvs
- | argf `sameVis` supplied_argf = split ty' ty' (tvbndr:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder
+ mk_req_bndr_maybe (Bndr tv argf) = case argf of
+ Required -> Just $ Bndr tv ()
+ Invisible _ -> Nothing
+
+-- | See Note [Invariant: Never expand type synonyms]
+tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
+tcSplitForAllTysInvisPreserveSynonyms ty =
+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty
+ inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in
+ ASSERT( inv_bndrs `equalLength` all_bndrs )
+ (inv_bndrs, body)
+ where
+ mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder
+ mk_inv_bndr_maybe (Bndr tv argf) = case argf of
+ Invisible s -> Just $ Bndr tv s
+ Required -> Nothing
+
+-- | See Note [Invariant: Never expand type synonyms]
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 1239377d..73a2bac6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -34,8 +34,8 @@ import GHC
import GHC.Core.Class
import GHC.Driver.Session
import GHC.Types.SrcLoc ( advanceSrcLoc )
-import GHC.Types.Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
- isInvisibleArgFlag )
+import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
+ , tyVarKind, updateTyVarKind, isInvisibleArgFlag )
import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
@@ -178,6 +178,11 @@ 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 }
+
getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
getConArgsI d = con_args d
@@ -190,9 +195,8 @@ getGADTConType (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_fvf = ForallInvis
- , hst_xforall = noExtField
- , hst_bndrs = qtvs
+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = mkHsForAllInvisTeleI qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
@@ -245,9 +249,8 @@ 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_fvf = ForallInvis
- , hst_xforall = noExtField
- , hst_bndrs = qtvs
+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = mkHsForAllInvisTele qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
@@ -309,8 +312,8 @@ reparenTypePrec = go
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
go p (HsIParamTy x n ty)
= paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
- go p (HsForAllTy x fvf tvs ty)
- = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)
+ go p (HsForAllTy x tele ty)
+ = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)
go p (HsQualTy x ctxt ty)
= paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
go p (HsFunTy x ty1 ty2)
@@ -350,6 +353,15 @@ reparenType = reparenTypePrec PREC_TOP
reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType = fmap reparenType
+-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
+reparenHsForAllTelescope :: (XParTy a ~ NoExtField)
+ => HsForAllTelescope a -> HsForAllTelescope a
+reparenHsForAllTelescope (HsForAllVis x bndrs) =
+ HsForAllVis x (map (fmap reparenTyVar) bndrs)
+reparenHsForAllTelescope (HsForAllInvis x bndrs) =
+ HsForAllInvis x (map (fmap 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 (UserTyVar x flag n) = UserTyVar x flag n
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 5e09fec6..108e9f66 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -476,7 +476,7 @@ subordinates instMap decl = case decl of
extract_deriv_ty (L l ty) =
case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
- HsForAllTy{ hst_fvf = ForallInvis
+ HsForAllTy{ hst_tele = HsForAllInvis{}
, hst_body = L _ (HsDocTy _ _ doc) }
-> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 848acb1f..a0c118f8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -223,11 +223,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
- HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do
- tyvars' <- mapM renameLTyVarBndr tyvars
- ltype' <- renameLType ltype
- return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
- , hst_bndrs = tyvars', hst_body = ltype' })
+ HsForAllTy { hst_tele = tele, hst_body = ltype } -> do
+ tele' <- renameHsForAllTelescope tele
+ ltype' <- renameLType ltype
+ return (HsForAllTy { hst_xforall = noExtField
+ , hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
@@ -304,6 +304,13 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
; return (HsQTvs { hsq_ext = noExtField
, hsq_explicit = tvs' }) }
+renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
+renameHsForAllTelescope tele = case tele of
+ HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllVis x bndrs'
+ HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllInvis x bndrs'
+
renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))
= do { n' <- rename n
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index cbfea762..e137c258 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -206,12 +206,16 @@ freeVariables =
everythingWithState Set.empty Set.union query
where
query term ctx = case cast term :: Maybe (HsType GhcRn) of
- Just (HsForAllTy _ _ bndrs _) ->
- (Set.empty, Set.union ctx (bndrsNames bndrs))
+ 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 (HsForAllVis _ bndrs) = bndrsNames bndrs
+ teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
+
bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
@@ -244,9 +248,9 @@ data RenameEnv name = RenameEnv
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
-renameType (HsForAllTy x fvf bndrs lt) =
- HsForAllTy x fvf
- <$> mapM (located renameBinder) bndrs
+renameType (HsForAllTy x tele lt) =
+ HsForAllTy x
+ <$> renameForAllTelescope tele
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
@@ -291,11 +295,21 @@ renameLTypes = mapM renameLType
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
+renameForAllTelescope :: HsForAllTelescope GhcRn
+ -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)
+renameForAllTelescope (HsForAllVis x bndrs) =
+ HsForAllVis x <$> mapM renameLBinder bndrs
+renameForAllTelescope (HsForAllInvis x bndrs) =
+ HsForAllInvis x <$> mapM renameLBinder bndrs
+
renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname
renameBinder (KindedTyVar x fl lname lkind) =
KindedTyVar x fl <$> located renameName lname <*> located renameType lkind
+renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)
+renameLBinder = located renameBinder
+
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
renameName name = do
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e8670012..21c7d19b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -695,6 +695,10 @@ type instance XTyLit DocNameI = NoExtField
type instance XWildCardTy DocNameI = NoExtField
type instance XXType DocNameI = NewHsTypeX
+type instance XHsForAllVis DocNameI = NoExtField
+type instance XHsForAllInvis DocNameI = NoExtField
+type instance XXHsForAllTelescope DocNameI = NoExtCon
+
type instance XUserTyVar DocNameI = NoExtField
type instance XKindedTyVar DocNameI = NoExtField
type instance XXTyVarBndr DocNameI = NoExtCon
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 010bd8bc..d72b9004 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -138,9 +138,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
= L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
-- The mkEmptySigWcType is suspicious
where
- go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))
- = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField
- , hst_bndrs = tvs, hst_body = go ty })
+ go (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 }))
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 21:22:25 +0000