diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 66 |
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] |