aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Convert.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
-rw-r--r--haddock-api/src/Haddock/Convert.hs66
1 files changed, 44 insertions, 22 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6a9598ed..0020fc4c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -47,6 +47,7 @@ import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend,dropList, filterByList, filterOut )
import GHC.Types.Var
import GHC.Types.Var.Set
+import GHC.Types.SrcLoc
import Haddock.Types
import Haddock.Interface.Specialize
@@ -85,6 +86,15 @@ tyThingToLHsDecl prr t = case t of
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
+ 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)
+ hsLTyVarBndrToType = mapLoc cvt
+
extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl fd rhs =
TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
@@ -210,8 +220,8 @@ synifyTyCon prr _coax tc
where
-- tyConTyVars doesn't work on fun/prim, but we can make them up:
mk_hs_tv realKind fakeTyVar
- | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar))
- | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
+ | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))
+ | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
conKind = defaultType prr (tyConKind tc)
tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
@@ -335,7 +345,7 @@ synifyFamilyResultSig Nothing kind
| isLiftedTypeKind kind = noLoc $ NoSig noExtField
| otherwise = noLoc $ KindSig noExtField (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -352,7 +362,7 @@ synifyDataCon use_gadt_syntax dc =
name = synifyName dc
-- con_qvars means a different thing depending on gadt-syntax
(_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
- user_tvs = dataConUserTyVars dc -- Used for GADT data constructors
+ user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
@@ -382,10 +392,10 @@ synifyDataCon use_gadt_syntax dc =
\hat ->
if use_gadt_syntax
then return $ noLoc $
- ConDeclGADT { con_g_ext = noExtField
+ ConDeclGADT { con_g_ext = []
, con_names = [name]
- , con_forall = noLoc $ not $ null user_tvs
- , con_qvars = synifyTyVars user_tvs
+ , con_forall = noLoc $ not $ null user_tvbndrs
+ , con_qvars = map synifyInvisTyVar user_tvbndrs
, con_mb_cxt = ctx
, con_args = hat
, con_res_ty = synifyType WithinType [] res_ty
@@ -394,7 +404,7 @@ synifyDataCon use_gadt_syntax dc =
ConDeclH98 { con_ext = noExtField
, con_name = name
, con_forall = noLoc False
- , con_ex_tvs = map synifyTyVar ex_tvs
+ , con_ex_tvs = map (synifyInvisTyVar . (mkTyCoVarBinder InferredSpec)) ex_tvs
, con_mb_cxt = ctx
, con_args = hat
, con_doc = Nothing }
@@ -439,20 +449,27 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs = HsQTvs { hsq_ext = []
, hsq_explicit = map synifyTyVar ktvs }
-synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
+synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn
synifyTyVar = synifyTyVar' emptyVarSet
+synifyInvisTyVar :: InvisTVBinder -> LHsTyVarBndr Specificity GhcRn
+synifyInvisTyVar = synifyInvisTyVar' emptyVarSet
+
-- | Like 'synifyTyVar', 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' :: VarSet -> TyVar -> LHsTyVarBndr () GhcRn
synifyTyVar' no_kinds tv
| isLiftedTypeKind kind || tv `elemVarSet` no_kinds
- = noLoc (UserTyVar noExtField (noLoc name))
- | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind))
+ = noLoc (UserTyVar noExtField () (noLoc name))
+ | otherwise = noLoc (KindedTyVar noExtField () (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.
@@ -631,6 +648,7 @@ synifyForAllType
-> LHsType GhcRn
synifyForAllType s argf vs ty =
let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty
+ inv_tvs = map to_invis_bndr tvs
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
, hst_body = synifyType WithinType (tvs' ++ vs) tau }
@@ -640,7 +658,7 @@ synifyForAllType s argf vs ty =
, hst_xforall = noExtField
, hst_body = noLoc sPhi }
- sTvs = map synifyTyVar tvs
+ sTvs = map synifyInvisTyVar inv_tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
@@ -654,8 +672,12 @@ synifyForAllType s argf vs ty =
| not (null tvs) -> noLoc sTy
| otherwise -> noLoc sPhi
- ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+ 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
-- | Put a forall in if there are any type variables which require
-- explicit kind annotations or if the inferred type variable order
@@ -663,14 +685,14 @@ synifyForAllType s argf vs ty =
implicitForAll
:: [TyCon] -- ^ type constructors that determine their args kinds
-> [TyVar] -- ^ free variables in the type to convert
- -> [TyVar] -- ^ type variable binders in the forall
+ -> [InvisTVBinder] -- ^ type variable binders in the forall
-> ThetaType -- ^ constraints right after the forall
-> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type
-> Type -- ^ inner type
-> LHsType GhcRn
implicitForAll tycons vs tvs ctx synInner tau
| any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy
- | tvs' /= tvs = noLoc sTy
+ | tvs' /= (binderVars tvs) = noLoc sTy
| otherwise = noLoc sPhi
where
sRho = synInner (tvs' ++ vs) tau
@@ -685,7 +707,7 @@ implicitForAll tycons vs tvs ctx synInner tau
, hst_body = noLoc sPhi }
no_kinds_needed = noKindTyVars tycons tau
- sTvs = map (synifyTyVar' no_kinds_needed) tvs
+ sTvs = map (synifyInvisTyVar' no_kinds_needed) tvs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
@@ -729,7 +751,7 @@ noKindTyVars _ _ = emptyVarSet
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+ let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
ts = maybeToList (tyConAppTyCon_maybe res_ty)
-- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
@@ -831,18 +853,18 @@ invariant didn't hold.
-- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.
--
-- See Note [Invariant: Never expand type synonyms]
-tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)
+tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], ThetaType, Type)
tcSplitSigmaTySameVisPreserveSynonyms argf ty =
case tcSplitForAllTysSameVisPreserveSynonyms argf ty of
(tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of
(theta, tau) -> (tvs, theta, tau)
-- | See Note [Invariant: Never expand type synonyms]
-tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)
+tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVarBinder], Type)
tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []
where
- split _ (ForAllTy (Bndr tv argf) ty') tvs
- | argf `sameVis` supplied_argf = split ty' ty' (tv:tvs)
+ split _ (ForAllTy tvbndr@(Bndr _ argf) ty') tvs
+ | argf `sameVis` supplied_argf = split ty' ty' (tvbndr:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]