summaryrefslogtreecommitdiff
path: root/compiler/GHC/Hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Hs')
-rw-r--r--compiler/GHC/Hs/Decls.hs8
-rw-r--r--compiler/GHC/Hs/Extension.hs6
-rw-r--r--compiler/GHC/Hs/Instances.hs5
-rw-r--r--compiler/GHC/Hs/Type.hs135
-rw-r--r--compiler/GHC/Hs/Utils.hs25
5 files changed, 108 insertions, 71 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index f800d934b6..fe5eaa84e7 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -1639,7 +1639,9 @@ pprConDecl (ConDeclH98 { con_name = L _ con
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc })
- = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args]
+ = sep [ ppr_mbDoc doc
+ , pprHsForAll (mkHsForAllInvisTele ex_tvs) cxt
+ , ppr_details args ]
where
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
@@ -1652,7 +1654,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
- <+> (sep [pprHsForAll ForallInvis qvars cxt,
+ <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
@@ -1938,7 +1940,7 @@ pprHsFamInstLHS :: (OutputableBndrId p)
-> LHsContext (GhcPass p)
-> SDoc
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
- = hsep [ pprHsExplicitForAll ForallInvis bndrs
+ = hsep [ pprHsExplicitForAll bndrs
, pprLHsContext mb_ctxt
, pp_pats typats ]
where
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 02106ab060..a667f92892 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -716,6 +716,12 @@ type family XXType x
-- ---------------------------------------------------------------------
+type family XHsForAllVis x
+type family XHsForAllInvis x
+type family XXHsForAllTelescope x
+
+-- ---------------------------------------------------------------------
+
type family XUserTyVar x
type family XKindedTyVar x
type family XXTyVarBndr x
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 99d627965d..e49406d484 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -400,6 +400,11 @@ deriving instance Data (HsPatSigType GhcPs)
deriving instance Data (HsPatSigType GhcRn)
deriving instance Data (HsPatSigType GhcTc)
+-- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p)
+deriving instance Data (HsForAllTelescope GhcPs)
+deriving instance Data (HsForAllTelescope GhcRn)
+deriving instance Data (HsForAllTelescope GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs)
deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 9d08a370c9..d09de98950 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -9,6 +9,7 @@ GHC.Hs.Type: Abstract syntax: user-defined types
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
@@ -19,7 +20,7 @@ GHC.Hs.Type: Abstract syntax: user-defined types
module GHC.Hs.Type (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
- HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..),
+ HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
@@ -51,6 +52,7 @@ module GHC.Hs.Type (
mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
+ mkHsForAllVisTele, mkHsForAllInvisTele,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
@@ -163,7 +165,7 @@ is a bit complicated. Here's how it works.
These constructors represent what the user wrote, no more
and no less.
-* The ForallVisFlag field of HsForAllTy represents whether a forall is
+* The ForAllTelescope field of HsForAllTy represents whether a forall is
invisible (e.g., forall a b. {...}, with a dot) or visible
(e.g., forall a b -> {...}, with an arrow).
@@ -329,6 +331,28 @@ type LHsKind pass = Located (HsKind pass)
-- LHsQTyVars
-- The explicitly-quantified binders in a data/type declaration
+-- | The type variable binders in an 'HsForAllTy'.
+-- See also @Note [Variable Specificity and Forall Visibility]@ in
+-- "GHC.Tc.Gen.HsType".
+data HsForAllTelescope pass
+ = HsForAllVis -- ^ A visible @forall@ (e.g., @forall a -> {...}@).
+ -- These do not have any notion of specificity, so we use
+ -- '()' as a placeholder value.
+ { hsf_xvis :: XHsForAllVis pass
+ , hsf_vis_bndrs :: [LHsTyVarBndr () pass]
+ }
+ | HsForAllInvis -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),
+ -- where each binder has a 'Specificity'.
+ { hsf_xinvis :: XHsForAllInvis pass
+ , hsf_invis_bndrs :: [LHsTyVarBndr Specificity pass]
+ }
+ | XHsForAllTelescope !(XXHsForAllTelescope pass)
+
+type instance XHsForAllVis (GhcPass _) = NoExtField
+type instance XHsForAllInvis (GhcPass _) = NoExtField
+
+type instance XXHsForAllTelescope (GhcPass _) = NoExtCon
+
-- | Located Haskell Type Variable Binder
type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass)
-- See Note [HsType binders]
@@ -352,6 +376,16 @@ type instance XHsQTvs GhcTc = HsQTvsRn
type instance XXLHsQTyVars (GhcPass _) = NoExtCon
+mkHsForAllVisTele ::
+ [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
+mkHsForAllVisTele vis_bndrs =
+ HsForAllVis { hsf_xvis = noExtField, hsf_vis_bndrs = vis_bndrs }
+
+mkHsForAllInvisTele ::
+ [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)
+mkHsForAllInvisTele invis_bndrs =
+ HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
+
mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }
@@ -475,7 +509,7 @@ E.g. For a signature like
f :: forall (a::k). blah
we get
HsIB { hsib_vars = [k]
- , hsib_body = HsForAllTy { hst_bndrs = [(a::*)]
+ , hsib_body = HsForAllTy { hst_tele = HsForAllInvis [(a::*)]
, hst_body = blah }
The implicit kind variable 'k' is bound by the HsIB;
the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
@@ -643,30 +677,12 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where
getName (UserTyVar _ _ v) = unLoc v
getName (KindedTyVar _ _ v _) = unLoc v
-{- Note [Specificity in HsForAllTy]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-All type variables in a `HsForAllTy` type are annotated with their
-`Specificity`. The meaning of this `Specificity` depends on the visibility of
-the binder `hst_fvf`:
-
-* In an invisible forall type, the `Specificity` denotes whether type variables
- are `Specified` (`forall a. ...`) or `Inferred` (`forall {a}. ...`). For more
- information, see Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
- in GHC.Core.TyCo.Rep.
-
-* In a visible forall type, the `Specificity` has no particular meaning. We
- uphold the convention that all visible forall types use `Specified` binders.
--}
-
-- | Haskell Type
data HsType pass
= HsForAllTy -- See Note [HsType binders]
{ hst_xforall :: XForAllTy pass
- , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or
- -- `forall a. {...}`?
- , hst_bndrs :: [LHsTyVarBndr Specificity pass]
+ , hst_tele :: HsForAllTelescope pass
-- Explicit, user-supplied 'forall a {b} c'
- -- see Note [Specificity in HsForAllTy]
, hst_body :: LHsType pass -- body type
}
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
@@ -1076,8 +1092,8 @@ hsWcScopedTvs sig_ty
, HsIB { hsib_ext = vars
, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
- L _ (HsForAllTy { hst_fvf = ForallInvis -- See Note [hsScopedTvs vis_flag]
- , hst_bndrs = tvs }) ->
+ L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}) ->
+ -- See Note [hsScopedTvs vis_flag]
vars ++ nwcs ++ hsLTyVarNames tvs
_ -> nwcs
@@ -1086,8 +1102,8 @@ hsScopedTvs :: LHsSigType GhcRn -> [Name]
hsScopedTvs sig_ty
| HsIB { hsib_ext = vars
, hsib_body = sig_ty2 } <- sig_ty
- , L _ (HsForAllTy { hst_fvf = ForallInvis -- See Note [hsScopedTvs vis_flag]
- , hst_bndrs = tvs }) <- sig_ty2
+ , L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }})
+ <- sig_ty2 -- See Note [hsScopedTvs vis_flag]
= vars ++ hsLTyVarNames tvs
| otherwise
= []
@@ -1134,9 +1150,10 @@ The conclusion of these discussions can be summarized as follows:
> vfn :: forall x y -> tau(x,y)
> vfn x y = \a b -> ... -- bad!
-We cement this design by pattern-matching on ForallInvis in hsScopedTvs:
+We cement this design by pattern-matching on HsForAllInvis in hsScopedTvs:
- hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ...
+ hsScopedTvs (HsForAllTy { hst_tele = HsForAllInvis { hst_bndrs = ... }
+ , ... }) = ...
At the moment, GHC does not support visible 'forall' in terms. Nevertheless,
it is still possible to write erroneous programs that use visible 'forall's in
@@ -1145,12 +1162,12 @@ terms, such as this example:
x :: forall a -> a -> a
x = x
-If we do not pattern-match on ForallInvis in hsScopedTvs, then `a` would
+If we do not pattern-match on HsForAllInvis in hsScopedTvs, then `a` would
erroneously be brought into scope over the body of `x` when renaming it.
Although the typechecker would later reject this (see `GHC.Tc.Validity.vdqAllowed`),
it is still possible for this to wreak havoc in the renamer before it gets to
that point (see #17687 for an example of this).
-Bottom line: nip problems in the bud by matching on ForallInvis from the start.
+Bottom line: nip problems in the bud by matching on HsForAllInvis from the start.
-}
---------------------
@@ -1380,7 +1397,8 @@ splitLHsGADTPrefixTy ty
where
-- NB: We do not use splitLHsForAllTyInvis below, since that looks through
-- parentheses...
- split_forall (L _ (HsForAllTy { hst_fvf = ForallInvis, hst_bndrs = bndrs
+ split_forall (L _ (HsForAllTy { hst_tele =
+ HsForAllInvis { hsf_invis_bndrs = bndrs }
, hst_body = rho }))
= (Just bndrs, rho)
split_forall sigma
@@ -1410,8 +1428,8 @@ splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsTy
splitLHsForAllTyInvis lty@(L _ ty) =
case ty of
HsParTy _ ty' -> splitLHsForAllTyInvis ty'
- HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' }
- | fvf' == ForallInvis
+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs' }
+ , hst_body = body' }
-> (tvs', body')
_ -> ([], lty)
@@ -1577,6 +1595,13 @@ instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
+instance OutputableBndrId p
+ => Outputable (HsForAllTelescope (GhcPass p)) where
+ ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =
+ text "HsForAllVis:" <+> ppr bndrs
+ ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =
+ text "HsForAllInvis:" <+> ppr bndrs
+
instance (OutputableBndrId p, OutputableBndrFlag flag)
=> Outputable (HsTyVarBndr flag (GhcPass p)) where
ppr = pprTyVarBndr
@@ -1598,8 +1623,8 @@ pprAnonWildCard = char '_'
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
-pprHsForAll :: (OutputableBndrId p, OutputableBndrFlag flag)
- => ForallVisFlag -> [LHsTyVarBndr flag (GhcPass p)]
+pprHsForAll :: OutputableBndrId p
+ => HsForAllTelescope (GhcPass p)
-> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
@@ -1610,32 +1635,30 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (OutputableBndrId p, OutputableBndrFlag flag)
- => Maybe SrcSpan -> ForallVisFlag
- -> [LHsTyVarBndr flag (GhcPass p)]
+pprHsForAllExtra :: forall p. OutputableBndrId p
+ => Maybe SrcSpan
+ -> HsForAllTelescope (GhcPass p)
-> LHsContext (GhcPass p) -> SDoc
-pprHsForAllExtra extra fvf qtvs cxt
- = pp_forall <+> pprLHsContextExtra (isJust extra) cxt
+pprHsForAllExtra extra tele cxt
+ = pp_tele tele <+> pprLHsContextExtra (isJust extra) cxt
where
- pp_forall | null qtvs = whenPprDebug (forAllLit <> separator)
- | otherwise = forAllLit <+> interppSP qtvs <> separator
+ pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc
+ pp_tele tele = case tele of
+ HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs
+ HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs
- separator = ppr_forall_separator fvf
+ pp_forall :: forall flag. OutputableBndrFlag flag =>
+ SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc
+ pp_forall separator qtvs
+ | null qtvs = whenPprDebug (forAllLit <> separator)
+ | otherwise = forAllLit <+> interppSP qtvs <> separator
-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print
-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
pprHsExplicitForAll :: (OutputableBndrId p)
- => ForallVisFlag
- -> Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc
-pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs
- <> ppr_forall_separator fvf
-pprHsExplicitForAll _ Nothing = empty
-
--- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for
--- invisible @forall@s (e.g., @forall a.@).
-ppr_forall_separator :: ForallVisFlag -> SDoc
-ppr_forall_separator ForallVis = space <> arrow
-ppr_forall_separator ForallInvis = dot
+ => Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc
+pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
+pprHsExplicitForAll Nothing = empty
pprLHsContext :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
@@ -1695,8 +1718,8 @@ ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
-ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })
- = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty]
+ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })
+ = sep [pprHsForAll tele noLHsContext, ppr_mono_lty ty]
ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
= sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 387536c2f2..7ca2d0025b 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -694,11 +694,17 @@ typeToLHsType ty
, hst_body = go tau })
go ty@(ForAllTy (Bndr _ argf) _)
- | (tvs, tau) <- tcSplitForAllTysSameVis argf ty
- = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf
- , hst_bndrs = map go_tv tvs
+ = 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)
@@ -723,7 +729,7 @@ typeToLHsType ty
args :: [Type]
(head, args) = splitAppTys ty
go (CastTy ty _) = go ty
- go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
+ go (CoercionTy co) = pprPanic "typeToLHsType" (ppr co)
-- Source-language types have _invisible_ kind arguments,
-- so we must remove them here (#8563)
@@ -743,14 +749,9 @@ typeToLHsType ty
Required -> f `nlHsAppTy` arg')
head (zip args arg_flags)
- argf_to_spec :: ArgFlag -> Specificity
- argf_to_spec Required = SpecifiedSpec
- -- see Note [Specificity in HsForAllTy] in GHC.Hs.Type
- argf_to_spec (Invisible s) = s
-
- go_tv :: TyVarBinder -> LHsTyVarBndr Specificity GhcPs
- go_tv (Bndr tv argf) = noLoc $ KindedTyVar noExtField
- (argf_to_spec argf)
+ go_tv :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
+ go_tv (Bndr tv flag) = noLoc $ KindedTyVar noExtField
+ flag
(noLoc (getRdrName tv))
(go (tyVarKind tv))
View Lorry Controller Status