diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 242 |
1 files changed, 160 insertions, 82 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 1a1e95bd..980af379 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -19,44 +19,49 @@ module Haddock.Convert ( PrintRuntimeReps(..), ) where -import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) +#include "HsVersions.h" + +import GHC.Data.Bag ( emptyBag ) +import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) , PromotionFlag(..), DefMethSpec(..) ) -import Class -import CoAxiom -import ConLike +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike import Data.Either (lefts, rights) -import DataCon -import FamInstEnv +import GHC.Core.DataCon +import GHC.Core.FamInstEnv import GHC.Hs -import Name -import NameSet ( emptyNameSet ) -import RdrName ( mkVarUnqual ) -import PatSyn -import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) -import TcType -import TyCon -import Type -import TyCoRep -import TysPrim ( alphaTyVars ) -import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName +import GHC.Types.Name +import GHC.Types.Name.Set ( emptyNameSet ) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Core.PatSyn +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon ) -import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey +import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) -import Unique ( getUnique ) -import Util ( chkAppend, dropList, filterByList, filterOut ) -import Var -import VarSet +import GHC.Types.Unique ( getUnique ) +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 +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) 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 --- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the +-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the -- motivation. data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show @@ -85,6 +90,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) @@ -127,7 +141,7 @@ tyThingToLHsDecl prr t = case t of , tcdATs = atFamDecls , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point - , tcdCExt = placeHolderNamesTc } + , tcdCExt = emptyNameSet } | otherwise -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField @@ -137,7 +151,7 @@ tyThingToLHsDecl prr t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] - (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) @@ -190,7 +204,7 @@ synifyTyCon prr _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv - tyVarKinds + (map scaledThing tyVarKinds) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -205,12 +219,12 @@ synifyTyCon prr _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDExt = DataDeclRn False placeHolderNamesTc } + , tcdDExt = DataDeclRn False emptyNameSet } 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 @@ -298,7 +312,7 @@ synifyTyCon _prr coax tc DataDecl { tcdLName = name, tcdTyVars = tyvars , tcdFixity = synifyFixity name , tcdDataDefn = defn - , tcdDExt = DataDeclRn False placeHolderNamesTc } + , tcdDExt = DataDeclRn False emptyNameSet } dataConErrs -> Left $ unlines dataConErrs -- | In this module, every TyCon being considered has come from an interface @@ -334,7 +348,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 @@ -351,7 +365,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 @@ -359,7 +373,7 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType [] ty + let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExtField bang' tySyn) @@ -372,19 +386,19 @@ synifyDataCon use_gadt_syntax dc = hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon linear_tys + (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon a b + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) _ -> Left "synifyDataCon: infix with non-2 args?" -- finally we get synifyDataCon's result! in hs_arg_tys >>= \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 synifyTyVarBndr user_tvbndrs , con_mb_cxt = ctx , con_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -393,7 +407,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 (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } @@ -438,21 +452,26 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } -synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn -synifyTyVar = synifyTyVar' emptyVarSet +synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn +synifyTyVar = synify_ty_var emptyVarSet () + +synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr = synifyTyVarBndr' emptyVarSet --- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv + +-- | 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 - -- | 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 @@ -620,38 +639,57 @@ synifyType _ vs ty@(AppTy {}) = let filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' -synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty -synifyType _ vs (FunTy VisArg t1 t2) = let +synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty +synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 - in noLoc $ HsFunTy noExtField s1 s2 + w' = synifyMult vs w + in noLoc $ HsFunTy noExtField w' 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 +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 synifyTyVar tvs + sTvs = map synifyTyVarBndr tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -667,21 +705,20 @@ synifyForAllType s argf vs ty = 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 -- would be different. 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 @@ -690,13 +727,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 (synifyTyVar' 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 @@ -725,7 +761,7 @@ noKindTyVars ts ty = let args = map (noKindTyVars ts) xs func = case f of TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) - , xsKinds `eqTypes` map typeKind xs + , map scaledThing xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var TyConApp t ks | t `elem` ts @@ -734,13 +770,23 @@ noKindTyVars ts ty _ -> noKindTyVars ts f in unionVarSets (func : args) noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t -noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet` + noKindTyVars ts t1 `unionVarSet` + noKindTyVars ts t2 noKindTyVars ts (CastTy t _) = noKindTyVars ts t noKindTyVars _ _ = emptyVarSet +synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn +synifyMult vs t = case t of + One -> HsLinearArrow NormalSyntax + Many -> HsUnrestrictedArrow NormalSyntax + ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) + + + 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 "() =>", @@ -811,7 +857,7 @@ synifyFamInst fi opaque = do eta_expanded_lhs -- eta-expand lhs types, because sometimes data/newtype -- instances are eta-reduced; See Trac #9692 - -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC + -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC | DataFamilyInst rep_tc <- fam_flavor = let (_, rep_tc_args) = splitTyConApp fam_rhs etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc @@ -839,22 +885,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 -> ([TyVar], 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 -> ([TyVar], Type) -tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty [] +tcSplitSomeForAllTysPreserveSynonyms :: + (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type) +tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] where - split _ (ForAllTy (Bndr tv argf) ty') tvs - | argf `sameVis` supplied_argf = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + 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 + 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) @@ -867,5 +945,5 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] -- | See Note [Invariant: Never expand type synonyms] tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) -tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res) tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing |