diff options
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Core/Type.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 64 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 138 | ||||
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 56 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 8 |
6 files changed, 111 insertions, 176 deletions
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 3f3a728824..680ce67bc7 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -3040,7 +3040,7 @@ There are a couple of places in GHC where we convert Core Types into forms that more closely resemble user-written syntax. These include: 1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) -2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) +2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) This conversion presents a challenge: how do we ensure that the resulting type has enough kind information so as not to be ambiguous? To better motivate this @@ -3080,8 +3080,8 @@ require a kind signature? It might require it when we need to fill in any of T's omitted arguments. By "omitted argument", we mean one that is dropped when reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the -omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, -which reifies specified arguments through visible kind application). +omitted arguments are only the inferred ones (e.g., in situations where +specified arguments are reified through visible kind application). Regardless, the key idea is that _some_ arguments are going to be omitted after reification, and the only mechanism we have at our disposal for filling them in is through explicit kind signatures. @@ -3178,7 +3178,7 @@ each form of tycon binder: injective_vars_of_binder(forall a. ...) = {a}.) There are some situations where using visible kind application is appropriate - (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH + and others where it is not (e.g., TH reification), so the `injective_vars_of_binder` function is parametrized by a Bool which decides if specified binders should be counted towards injective positions or not. diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index ccf98857f4..c475357807 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -95,6 +95,7 @@ import GHC.Types.Name( Name, NamedThing(getName) ) import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) +import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Type import GHC.Hs.Doc @@ -866,6 +867,8 @@ data HsType pass data NewHsTypeX = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. + -- See also Note [Typechecking NHsCoreTys] in + -- GHC.Tc.Gen.HsType. deriving Data -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None @@ -1870,32 +1873,43 @@ ppr_tylit (HsStrTy _ s) = text (show s) -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses -- under precedence @p@. -hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool -hsTypeNeedsParens p = go +hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool +hsTypeNeedsParens p = go_hs_ty where - go (HsForAllTy{}) = p >= funPrec - go (HsQualTy{}) = p >= funPrec - go (HsBangTy{}) = p > topPrec - go (HsRecTy{}) = False - go (HsTyVar{}) = False - go (HsFunTy{}) = p >= funPrec - go (HsTupleTy{}) = False - go (HsSumTy{}) = False - go (HsKindSig{}) = p >= sigPrec - go (HsListTy{}) = False - go (HsIParamTy{}) = p > topPrec - go (HsSpliceTy{}) = False - go (HsExplicitListTy{}) = False - go (HsExplicitTupleTy{}) = False - go (HsTyLit{}) = False - go (HsWildCardTy{}) = False - go (HsStarTy{}) = p >= starPrec - go (HsAppTy{}) = p >= appPrec - go (HsAppKindTy{}) = p >= appPrec - go (HsOpTy{}) = p >= opPrec - go (HsParTy{}) = False - go (HsDocTy _ (L _ t) _) = go t - go (XHsType{}) = False + go_hs_ty (HsForAllTy{}) = p >= funPrec + go_hs_ty (HsQualTy{}) = p >= funPrec + go_hs_ty (HsBangTy{}) = p > topPrec + go_hs_ty (HsRecTy{}) = False + go_hs_ty (HsTyVar{}) = False + go_hs_ty (HsFunTy{}) = p >= funPrec + go_hs_ty (HsTupleTy{}) = False + go_hs_ty (HsSumTy{}) = False + go_hs_ty (HsKindSig{}) = p >= sigPrec + go_hs_ty (HsListTy{}) = False + go_hs_ty (HsIParamTy{}) = p > topPrec + go_hs_ty (HsSpliceTy{}) = False + go_hs_ty (HsExplicitListTy{}) = False + go_hs_ty (HsExplicitTupleTy{}) = False + go_hs_ty (HsTyLit{}) = False + go_hs_ty (HsWildCardTy{}) = False + go_hs_ty (HsStarTy{}) = p >= starPrec + go_hs_ty (HsAppTy{}) = p >= appPrec + go_hs_ty (HsAppKindTy{}) = p >= appPrec + go_hs_ty (HsOpTy{}) = p >= opPrec + go_hs_ty (HsParTy{}) = False + go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t + go_hs_ty (XHsType (NHsCoreTy ty)) = go_core_ty ty + + go_core_ty (TyVarTy{}) = False + go_core_ty (AppTy{}) = p >= appPrec + go_core_ty (TyConApp _ args) + | null args = False + | otherwise = p >= appPrec + go_core_ty (ForAllTy{}) = p >= funPrec + go_core_ty (FunTy{}) = p >= funPrec + go_core_ty (LitTy{}) = False + go_core_ty (CastTy t _) = go_core_ty t + go_core_ty (CoercionTy{}) = False maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc -- See Note [Printing promoted type constructors] diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 1c8023946c..626a771be7 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -47,7 +47,6 @@ module GHC.Hs.Utils( nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - typeToLHsType, -- * Constructing general big tuples -- $big_tuples @@ -119,9 +118,7 @@ import GHC.Tc.Types.Evidence import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Core.TyCo.Rep -import GHC.Core.TyCon -import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) -import GHC.Core.Multiplicity ( pattern One, pattern Many ) +import GHC.Core.Multiplicity ( pattern Many ) import GHC.Builtin.Types ( unitTy ) import GHC.Tc.Utils.TcType import GHC.Core.DataCon @@ -680,139 +677,6 @@ mkClassOpSigs sigs = L loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig -typeToLHsType :: Type -> LHsType GhcPs --- ^ Converting a Type to an HsType RdrName --- This is needed to implement GeneralizedNewtypeDeriving. --- --- Note that we use 'getRdrName' extensively, which --- generates Exact RdrNames rather than strings. -typeToLHsType ty - = go ty - where - go :: Type -> LHsType GhcPs - go ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) - = case af of - VisArg -> nlHsFunTy (multToHsArrow mult) (go arg) (go res) - InvisArg | (theta, tau) <- tcSplitPhiTy ty - -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_xqual = noExtField - , hst_body = go tau }) - - go ty@(ForAllTy (Bndr _ argf) _) - = noLoc (HsForAllTy { hst_tele = tele - , hst_xforall = noExtField - , hst_body = go tau }) - where - (tele, tau) - | isVisibleArgFlag argf - = let (req_tvbs, tau') = tcSplitForAllTysReq ty in - (mkHsForAllVisTele (map go_tv req_tvbs), tau') - | otherwise - = let (inv_tvbs, tau') = tcSplitForAllTysInvis ty in - (mkHsForAllInvisTele (map go_tv inv_tvbs), tau') - go (TyVarTy tv) = nlHsTyVar (getRdrName tv) - go (LitTy (NumTyLit n)) - = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) - go (LitTy (StrTyLit s)) - = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) - go ty@(TyConApp tc args) - | tyConAppNeedsKindSig True tc (length args) - -- We must produce an explicit kind signature here to make certain - -- programs kind-check. See Note [Kind signatures in typeToLHsType]. - = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) - | otherwise = ty' - where - ty' :: LHsType GhcPs - ty' = go_app (noLoc $ HsTyVar noExtField prom $ noLoc $ getRdrName tc) - args (tyConArgFlags tc args) - - prom :: PromotionFlag - prom = if isPromotedDataCon tc then IsPromoted else NotPromoted - go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args) - where - head :: Type - args :: [Type] - (head, args) = splitAppTys ty - go (CastTy ty _) = go ty - go (CoercionTy co) = pprPanic "typeToLHsType" (ppr co) - - -- Source-language types have _invisible_ kind arguments, - -- so we must remove them here (#8563) - - go_app :: LHsType GhcPs -- The type being applied - -> [Type] -- The argument types - -> [ArgFlag] -- The argument types' visibilities - -> LHsType GhcPs - go_app head args arg_flags = - foldl' (\f (arg, flag) -> - let arg' = go arg in - case flag of - -- See Note [Explicit Case Statement for Specificity] - Invisible spec -> case spec of - InferredSpec -> f - SpecifiedSpec -> f `nlHsAppKindTy` arg' - Required -> f `nlHsAppTy` arg') - head (zip args arg_flags) - - go_tv :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs - go_tv (Bndr tv flag) = noLoc $ KindedTyVar noExtField - flag - (noLoc (getRdrName tv)) - (go (tyVarKind tv)) - --- | This is used to transform an arrow from Core's Type to surface --- syntax. There is a choice between being very explicit here, or trying to --- refold arrows into shorthands as much as possible. We choose to do the --- latter, for it should be more readable. It also helps printing Haskell'98 --- code into Haskell'98 syntax. -multToHsArrow :: Mult -> HsArrow GhcPs -multToHsArrow One = HsLinearArrow -multToHsArrow Many = HsUnrestrictedArrow -multToHsArrow ty = HsExplicitMult (typeToLHsType ty) - -{- -Note [Kind signatures in typeToLHsType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are types that typeToLHsType can produce which require explicit kind -signatures in order to kind-check. Here is an example from #14579: - - -- type P :: forall {k} {t :: k}. Proxy t - type P = 'Proxy - - -- type Wat :: forall a. Proxy a -> * - newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) - deriving Eq - - -- type Wat2 :: forall {a}. Proxy a -> * - type Wat2 = Wat - - -- type Glurp :: * -> * - newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) - deriving Eq - -The derived Eq instance for Glurp (without any kind signatures) would be: - - instance Eq a => Eq (Glurp a) where - (==) :: Glurp a -> Glurp a -> Bool - (==) = coerce @(Wat2 P -> Wat2 P -> Bool) - @(Glurp a -> Glurp a -> Bool) - (==) - -(Where the visible type applications use types produced by typeToLHsType.) - -The type P (in Wat2 P) has an underspecified kind, so we must ensure that -typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish -this, whenever we see an application of a tycon to some arguments, we use -the tyConAppNeedsKindSig function to determine if it requires an explicit kind -signature to resolve some ambiguity. (See Note -Note [When does a tycon application need an explicit kind signature?] for a -more detailed explanation of how this works.) - -Note that we pass True to tyConAppNeedsKindSig since we are generated code with -visible kind applications, so even specified arguments count towards injective -positions in the kind of the tycon. --} - {- ********************************************************************* * * --------- HsWrappers: type args, dict args, casts --------- diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 01b7896853..f0655f5b4e 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -591,7 +591,7 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt -- mean more tests (dynamically) nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt where - ascribeBool e = nlExprWithTySig e boolTy + ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {}) @@ -1890,7 +1890,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty -- -- op :: forall c. a -> [T x] -> c -> Int L loc $ ClassOpSig noExtField False [loc_meth_RDR] - $ mkLHsSigType $ typeToLHsType to_ty + $ mkLHsSigType $ nlHsCoreTy to_ty ) where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id @@ -1946,12 +1946,15 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) where - hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) + hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s -nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs +nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty where - hs_ty = mkLHsSigWcType (typeToLHsType s) + hs_ty = mkLHsSigWcType s + +nlHsCoreTy :: Type -> LHsType GhcPs +nlHsCoreTy = noLoc . XHsType . NHsCoreTy mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head (this includes diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 68d29f565e..22edf3c0b4 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -90,6 +90,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) import GHC.Core.Type import GHC.Builtin.Types.Prim +import GHC.Types.Name.Env import GHC.Types.Name.Reader( lookupLocalRdrOcc ) import GHC.Types.Var import GHC.Types.Var.Set @@ -106,6 +107,7 @@ import GHC.Types.SrcLoc import GHC.Settings.Constants ( mAX_CTUPLE_SIZE ) import GHC.Utils.Error( MsgDoc ) import GHC.Types.Unique +import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Types.Unique.Supply @@ -833,8 +835,17 @@ tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) = tc_infer_hs_type mode ty tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) - = return (ty, tcTypeKind ty) + +-- See Note [Typechecking NHsCoreTys] +tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) + = do env <- getLclEnv + let subst_prs = [ (nm, tv) + | ATyVar nm tv <- nameEnvElts (tcl_env env) ] + subst = mkTvSubst + (mkInScopeSet $ mkVarSet $ map snd subst_prs) + (listToUFM $ map (liftSnd mkTyVarTy) subst_prs) + ty' = substTy subst ty + return (ty', tcTypeKind ty') tc_infer_hs_type _ (HsExplicitListTy _ _ tys) | null tys -- this is so that we can use visible kind application with '[] @@ -847,6 +858,47 @@ tc_infer_hs_type mode other_ty ; ty' <- tc_hs_type mode other_ty kv ; return (ty', kv) } +{- +Note [Typechecking NHsCoreTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NHsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. +As such, there's not much to be done in order to typecheck an NHsCoreTy, +since it's already been typechecked to some extent. There is one thing that +we must do, however: we must substitute the type variables from the tcl_env. +To see why, consider GeneralizedNewtypeDeriving, which is one of the main +clients of NHsCoreTy (example adapted from #14579): + + newtype T a = MkT a deriving newtype Eq + +This will produce an InstInfo GhcPs that looks roughly like this: + + instance forall a_1. Eq a_1 => Eq (T a_1) where + (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an NHsCoreTy + @(T a_1 -> T a_1 -> Bool) -- So is this + (==) + +This is then fed into the renamer. Since all of the type variables in this +InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically +identical. Things get more interesting when the InstInfo is fed into the +typechecker, however. GHC will first generate fresh skolems to instantiate +the instance-bound type variables with. In the example above, we might generate +the skolem a_2 and use that to instantiate a_1, which extends the local type +environment (tcl_env) with [a_1 :-> a_2]. This gives us: + + instance forall a_2. Eq a_2 => Eq (T a_2) where ... + +To ensure that the body of this instance is well scoped, every occurrence of +the `a` type variable should refer to a_2, the new skolem. However, the +NHsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the +substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this +substitution to each NHsCoreTy and all is well: + + instance forall a_2. Eq a_2 => Eq (T a_2) where + (==) = coerce @( a_2 -> a_2 -> Bool) + @(T a_2 -> T a_2 -> Bool) + (==) +-} + ------------------------------------------ tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType tcLHsType hs_ty exp_kind diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index dd828bc277..dc8aeb1962 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1604,7 +1604,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys -> TcM (TcId, LHsBind GhcTc, Maybe Implication) tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name + = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name ; tcMethodBody clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags inline_prags @@ -1947,7 +1947,7 @@ mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] -mkDefMethBind :: Class -> [Type] -> Id -> Name +mkDefMethBind :: DFunId -> Class -> Id -> Name -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class -- So make a binding op = $dmop @t1 @t2 @@ -1955,7 +1955,7 @@ mkDefMethBind :: Class -> [Type] -> Id -> Name -- and t1,t2 are the instance types. -- See Note [Default methods in instances] for why we use -- visible type application here -mkDefMethBind clas inst_tys sel_id dm_name +mkDefMethBind dfun_id clas sel_id dm_name = do { dflags <- getDynFlags ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id @@ -1980,6 +1980,8 @@ mkDefMethBind clas inst_tys sel_id dm_name ; return (bind, inline_prags) } where + (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) + mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy $ noLoc $ XHsType $ NHsCoreTy ty)) |