Commit c26d299d authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Visible dependent quantification

This implements GHC proposal 35
(https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0035-forall-arrow.rst)
by adding the ability to write kinds with
visible dependent quantification (VDQ).

Most of the work for supporting VDQ was actually done _before_ this
patch. That is, GHC has been able to reason about kinds with VDQ for
some time, but it lacked the ability to let programmers directly
write these kinds in the source syntax. This patch is primarly about
exposing this ability, by:

* Changing `HsForAllTy` to add an additional field of type
  `ForallVisFlag` to distinguish between invisible `forall`s (i.e,
  with dots) and visible `forall`s (i.e., with arrows)
* Changing `Parser.y` accordingly

The rest of the patch mostly concerns adding validity checking to
ensure that VDQ is never used in the type of a term (as permitting
this would require full-spectrum dependent types). This is
accomplished by:

* Adding a `vdqAllowed` predicate to `TcValidity`.
* Introducing `splitLHsSigmaTyInvis`, a variant of `splitLHsSigmaTy`
  that only splits invisible `forall`s. This function is used in
  certain places (e.g., in instance declarations) to ensure that GHC
  doesn't try to split visible `forall`s (e.g., if it tried splitting
  `instance forall a -> Show (Blah a)`, then GHC would mistakenly
  allow that declaration!)

This also updates Template Haskell by introducing a new `ForallVisT`
constructor to `Type`.

Fixes #16326. Also fixes #15658 by documenting this feature in the
users' guide.
parent f838809f
......@@ -62,7 +62,7 @@ module Var (
-- * ArgFlags
ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis,
AnonArgFlag(..),
AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag,
-- * TyVar's
VarBndr(..), TyCoVarBinder, TyVarBinder,
......@@ -425,15 +425,17 @@ instance Binary ArgFlag where
1 -> return Specified
_ -> return Inferred
-- The non-dependent version of ArgFlag, namely AnonArgFlag,
-- appears here partly so that it's together with its friend ArgFlag,
-- | The non-dependent version of 'ArgFlag'.
-- Appears here partly so that it's together with its friend ArgFlag,
-- but also because it is used in IfaceType, rather early in the
-- compilation chain
-- See Note [AnonArgFlag vs. ForallVisFlag]
data AnonArgFlag
= VisArg -- Used for (->): an ordinary non-dependent arrow
-- The argument is visible in source code
| InvisArg -- Used for (=>): a non-dependent predicate arrow
-- The argument is invisible in source code
= VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow.
-- The argument is visible in source code.
| InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow.
-- The argument is invisible in source code.
deriving (Eq, Ord, Data)
instance Outputable AnonArgFlag where
......@@ -450,6 +452,47 @@ instance Binary AnonArgFlag where
0 -> return VisArg
_ -> return InvisArg
-- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible
-- (e.g., @forall a b -> {...}@, with an arrow)?
-- See Note [AnonArgFlag vs. ForallVisFlag]
data ForallVisFlag
= ForallVis -- ^ A visible @forall@ (with an arrow)
| ForallInvis -- ^ An invisible @forall@ (with a dot)
deriving (Eq, Ord, Data)
instance Outputable ForallVisFlag where
ppr f = text $ case f of
ForallVis -> "ForallVis"
ForallInvis -> "ForallInvis"
-- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'.
argToForallVisFlag :: ArgFlag -> ForallVisFlag
argToForallVisFlag Required = ForallVis
argToForallVisFlag Specified = ForallInvis
argToForallVisFlag Inferred = ForallInvis
{-
Note [AnonArgFlag vs. ForallVisFlag]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The AnonArgFlag and ForallVisFlag data types are quite similar at a first
glance:
data AnonArgFlag = VisArg | InvisArg
data ForallVisFlag = ForallVis | ForallInvis
Both data types keep track of visibility of some sort. AnonArgFlag tracks
whether a FunTy has a visible argument (->) or an invisible predicate argument
(=>). ForallVisFlag tracks whether a `forall` quantifier is visible
(forall a -> {...}) or invisible (forall a. {...}).
Given their similarities, it's tempting to want to combine these two data types
into one, but they actually represent distinct concepts. AnonArgFlag reflects a
property of *Core* types, whereas ForallVisFlag reflects a property of the GHC
AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag
is all about surface syntax. Therefore, they are kept as separate data types.
-}
{- *********************************************************************
* *
* VarBndr, TyCoVarBinder
......
......@@ -1144,18 +1144,21 @@ repLTys tys = mapM repLTy tys
repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
repLTy ty = repTy (unLoc ty)
repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
repForall :: ForallVisFlag -> HsType GhcRn -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
repForall fvf ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
= addHsTyVarBinds tvs $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau
; repTForall bndrs ctxt1 ty1 }
; case fvf of
ForallVis -> repTForallVis bndrs ty1 -- forall a -> {...}
ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}
}
repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty
repTy ty@(HsQualTy {}) = repForall ForallInvis ty
repTy (HsTyVar _ _ (dL->L _ n))
| isLiftedTypeKindTyConName n = repTStar
......@@ -2467,6 +2470,10 @@ repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
repTForall (MkC tvars) (MkC ctxt) (MkC ty)
= rep2 forallTName [tvars, ctxt, ty]
repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ
-> DsM (Core TH.TypeQ)
repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
repTvar (MkC s) = rep2 varTName [s]
......
......@@ -1386,7 +1386,7 @@ instance ToHie (LHsType GhcRn) where
instance ToHie (TScoped (LHsType GhcRn)) where
toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
HsForAllTy _ bndrs body ->
HsForAllTy _ _ bndrs body ->
[ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
, toHie body
]
......
......@@ -1405,11 +1405,18 @@ cvtTypeKind ty_str ty
; let pcxt = parenthesizeHsContext funPrec cxt'
; ty' <- cvtType ty
; loc <- getL
; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty
; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty
rho_ty = mkHsQualTy cxt loc pcxt ty'
; return hs_ty }
ForallVisT tvs ty
| null tys'
-> do { tvs' <- cvtTvs tvs
; ty' <- cvtType ty
; loc <- getL
; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }
SigT ty ki
-> do { ty' <- cvtType ty
; ki' <- cvtKind ki
......@@ -1638,7 +1645,8 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy
{ hst_bndrs = univs'
{ hst_fvf = ForallInvis
, hst_bndrs = univs'
, hst_xforall = noExt
, hst_body = cL l cxtTy }
cxtTy = HsQualTy { hst_ctxt = cL l []
......@@ -1692,15 +1700,19 @@ mkHsForAllTy :: [TH.TyVarBndr]
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit forall
-> ForallVisFlag
-- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)
-- or invisible (e.g., @forall a.@)
-> LHsQTyVars GhcPs
-- ^ The converted type variable binders
-> LHsType GhcPs
-- ^ The converted rho type
-> LHsType GhcPs
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
mkHsForAllTy tvs loc fvf tvs' rho_ty
| null tvs = rho_ty
| otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
| otherwise = cL loc $ HsForAllTy { hst_fvf = fvf
, hst_bndrs = hsQTvExplicit tvs'
, hst_xforall = noExt
, hst_body = rho_ty }
......
......@@ -1457,7 +1457,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args]
= sep [ppr_mbDoc doc, pprHsForAll ForallInvis 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
......@@ -1470,7 +1470,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 (hsq_explicit qvars) cxt,
<+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
......@@ -1777,7 +1777,7 @@ pprHsFamInstLHS :: (OutputableBndrId (GhcPass p))
-> LHsContext (GhcPass p)
-> SDoc
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
= hsep [ pprHsExplicitForAll bndrs
= hsep [ pprHsExplicitForAll ForallInvis bndrs
, pprLHsContext mb_ctxt
, pp_pats typats ]
where
......
......@@ -19,7 +19,7 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..),
LHsQTyVars(..), HsQTvsRn(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
......@@ -56,7 +56,8 @@ module HsTypes (
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitLHsForAllTy, splitLHsForAllTyInvis,
splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType,
......@@ -142,13 +143,18 @@ is a bit complicated. Here's how it works.
* In a HsType,
HsForAllTy represents an /explicit, user-written/ 'forall'
e.g. forall a b. ...
e.g. forall a b. {...} or
forall a b -> {...}
HsQualTy represents an /explicit, user-written/ context
e.g. (Eq a, Show a) => ...
The context can be empty if that's what the user wrote
These constructors represent what the user wrote, no more
and no less.
* The ForallVisFlag 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).
* HsTyVarBndr describes a quantified type variable written by the
user. For example
f :: forall a (b :: *). blah
......@@ -512,8 +518,10 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
-- | Haskell Type
data HsType pass
= HsForAllTy -- See Note [HsType binders]
{ hst_xforall :: XForAllTy pass,
hst_bndrs :: [LHsTyVarBndr pass]
{ hst_xforall :: XForAllTy pass
, hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or
-- `forall a. {...}`?
, hst_bndrs :: [LHsTyVarBndr pass]
-- Explicit, user-supplied 'forall a b c'
, hst_body :: LHsType pass -- body type
}
......@@ -1137,6 +1145,13 @@ The SrcSpan is the span of the original HsPar
-}
--------------------------------
-- | Decompose a pattern synonym type signature into its constituent parts.
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsPatSynTy :: LHsType pass
-> ( [LHsTyVarBndr pass] -- universals
, LHsContext pass -- required constraints
......@@ -1145,11 +1160,18 @@ splitLHsPatSynTy :: LHsType pass
, LHsType pass) -- body type
splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
where
(univs, ty1) = splitLHsForAllTy ty
(univs, ty1) = splitLHsForAllTyInvis ty
(reqs, ty2) = splitLHsQualTy ty1
(exis, ty3) = splitLHsForAllTy ty2
(exis, ty3) = splitLHsForAllTyInvis ty2
(provs, ty4) = splitLHsQualTy ty3
-- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
-- into its constituent parts.
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsSigmaTy :: LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy ty
......@@ -1157,22 +1179,82 @@ splitLHsSigmaTy ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
-- | Like 'splitLHsSigmaTy', but only splits type variable binders that were
-- quantified invisibly (e.g., @forall a.@, with a dot).
--
-- This function is used to split apart certain types, such as instance
-- declaration types, which disallow visible @forall@s. For instance, if GHC
-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that
-- declaration would mistakenly be accepted!
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsSigmaTyInvis :: LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTyInvis ty
| (tvs, ty1) <- splitLHsForAllTyInvis ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
-- | Decompose a type of the form @forall <tvs>. body@) into its constituent
-- parts.
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy body = ([], body)
-- | Like 'splitLHsForAllTy', but only splits type variable binders that
-- were quantified invisibly (e.g., @forall a.@, with a dot).
--
-- This function is used to split apart certain types, such as instance
-- declaration types, which disallow visible @forall@s. For instance, if GHC
-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that
-- declaration would mistakenly be accepted!
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall a. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTyInvis lty@(L _ ty) =
case ty of
HsParTy _ ty' -> splitLHsForAllTyInvis ty'
HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' }
| fvf' == ForallInvis
-> (tvs', body')
_ -> ([], lty)
-- | Decompose a type of the form @context => body@ into its constituent parts.
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(context => <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body)
splitLHsQualTy body = (noLHsContext, body)
-- | Decompose a type class instance type (of the form
-- @forall <tvs>. context => instance_head@) into its constituent parts.
--
-- Note that this function looks through parentheses, so it will work on types
-- such as @(forall <tvs>. <...>)@. The downside to this is that it is not
-- generally possible to take the returned types and reconstruct the original
-- type (parentheses and all) from them.
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
-- Split up an instance decl type, returning the pieces
splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
, hsib_body = inst_ty })
| (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty
| (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty
= (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
-- Return implicitly bound type and kind vars
-- For an instance decl, all of them are in scope
......@@ -1180,7 +1262,7 @@ splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy"
getLHsInstDeclHead :: LHsSigType pass -> LHsType pass
getLHsInstDeclHead inst_ty
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
| (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty)
= body_ty
getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
......@@ -1326,10 +1408,11 @@ instance (p ~ GhcPass pass,Outputable thing)
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
-- | Prints a forall; When passed an empty list, prints @forall.@ only when
-- @-dppr-debug@
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
pprHsForAll :: (OutputableBndrId (GhcPass p))
=> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
=> ForallVisFlag -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
......@@ -1340,20 +1423,31 @@ pprHsForAll = pprHsForAllExtra Nothing
-- 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 (GhcPass p))
=> Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
=> Maybe SrcSpan -> ForallVisFlag
-> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
pprHsForAllExtra extra fvf qtvs cxt
= pp_forall <+> pprLHsContextExtra (isJust extra) cxt
where
pp_forall | null qtvs = whenPprDebug (forAllLit <> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
pp_forall | null qtvs = whenPprDebug (forAllLit <> separator)
| otherwise = forAllLit <+> interppSP qtvs <> separator
separator = ppr_forall_separator fvf
-- | Version of 'pprHsForall' or 'pprHsForallExtra' that will always print
-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print
-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
=> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
pprHsExplicitForAll Nothing = empty
=> 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
pprLHsContext :: (OutputableBndrId (GhcPass p))
=> LHsContext (GhcPass p) -> SDoc
......@@ -1413,8 +1507,8 @@ ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAll tvs noLHsContext, ppr_mono_lty ty]
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 (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
= sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
......
......@@ -658,9 +658,10 @@ typeToLHsType ty
, hst_xqual = noExt
, hst_body = go tau })
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
go ty@(ForAllTy (Bndr _ argf) _)
| (tvs, tau) <- tcSplitForAllTysSameVis argf ty
= noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf
, hst_bndrs = map go_tv tvs
, hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
......
......@@ -21,7 +21,8 @@ module IfaceType (
IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..),
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..),
ForallVisFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
......
......@@ -1852,6 +1852,10 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
: '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
forall_vis_flag :: { (AddAnn, ForallVisFlag) }
: '.' { (mj AnnDot $1, ForallInvis) }
| '->' { (mj AnnRarrow $1, ForallVis) }
-- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
......@@ -1865,12 +1869,15 @@ ktypedoc :: { LHsType GhcPs }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall $1 >>
: 'forall' tv_bndrs forall_vis_flag ctype
{% let (fv_ann, fv_flag) = $3 in
hintExplicitForall $1 *>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
HsForAllTy { hst_fvf = fv_flag
, hst_bndrs = $2
, hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1, mj AnnDot $3] }
[mu AnnForall $1,fv_ann] }
| context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
......@@ -1892,12 +1899,15 @@ ctype :: { LHsType GhcPs }
-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
ctypedoc :: { LHsType GhcPs }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall $1 >>
: 'forall' tv_bndrs forall_vis_flag ctypedoc
{% let (fv_ann, fv_flag) = $3 in
hintExplicitForall $1 *>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
HsForAllTy { hst_fvf = fv_flag
, hst_bndrs = $2
, hst_xforall = noExt
, hst_body = $4 })
[mu AnnForall $1,mj AnnDot $3] }
[mu AnnForall $1,fv_ann] }
| context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
......
......@@ -692,7 +692,7 @@ mkGadtDecl names ty
, anns1 ++ anns2)
where
(ty'@(dL->L l _),anns1) = peel_parens ty []
(tvs, rho) = splitLHsForAllTy ty'
(tvs, rho) = splitLHsForAllTyInvis ty'
(mcxt, tau, anns2) = split_rho rho []
split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
......
......@@ -96,9 +96,9 @@ templateHaskellNames = [
-- PatSynArgs (for pattern synonyms)
prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type
forallTName, varTName, conTName, infixTName, appTName, appKindTName,
equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName,
arrowTName, listTName, sigTName, litTName,
forallTName, forallVisTName, varTName, conTName, infixTName, appTName,
appKindTName, equalityTName, tupleTName, unboxedTupleTName,
unboxedSumTName, arrowTName, listTName, sigTName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, implicitParamTName,
-- TyLit
......@@ -429,12 +429,13 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey
recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ...
forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName,
unboxedSumTName, arrowTName, listTName, appTName, appKindTName,
sigTName, equalityTName, litTName, promotedTName,
forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,
unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName,
appKindTName, sigTName, equalityTName, litTName, promotedTName,
promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, implicitParamTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
tupleTName = libFun (fsLit "tupleT") tupleTIdKey
......@@ -950,79 +951,80 @@ infixPatSynIdKey = mkPreludeMiscIdUnique 381
recordPatSynIdKey = mkPreludeMiscIdUnique 382
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey,
sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,
unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,
appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 390
varTIdKey = mkPreludeMiscIdUnique 391
conTIdKey = mkPreludeMiscIdUnique 392
tupleTIdKey = mkPreludeMiscIdUnique 393
unboxedTupleTIdKey = mkPreludeMiscIdUnique 394
unboxedSumTIdKey = mkPreludeMiscIdUnique 395
arrowTIdKey = mkPreludeMiscIdUnique 396
listTIdKey = mkPreludeMiscIdUnique 397
appTIdKey = mkPreludeMiscIdUnique 398
appKindTIdKey = mkPreludeMiscIdUnique 399
sigTIdKey = mkPreludeMiscIdUnique 400
equalityTIdKey = mkPreludeMiscIdUnique 401
litTIdKey = mkPreludeMiscIdUnique 402
promotedTIdKey = mkPreludeMiscIdUnique 403
promotedTupleTIdKey = mkPreludeMiscIdUnique 404
promotedNilTIdKey = mkPreludeMiscIdUnique 405
promotedConsTIdKey = mkPreludeMiscIdUnique 406
wildCardTIdKey = mkPreludeMiscIdUnique 407
implicitParamTIdKey = mkPreludeMiscIdUnique 408
infixTIdKey = mkPreludeMiscIdUnique 409
forallVisTIdKey = mkPreludeMiscIdUnique 391
varTIdKey = mkPreludeMiscIdUnique 392
conTIdKey = mkPreludeMiscIdUnique 393
tupleTIdKey = mkPreludeMiscIdUnique 394
unboxedTupleTIdKey = mkPreludeMiscIdUnique 395
unboxedSumTIdKey = mkPreludeMiscIdUnique 396
arrowTIdKey = mkPreludeMiscIdUnique 397
listTIdKey = mkPreludeMiscIdUnique 398
appTIdKey = mkPreludeMiscIdUnique 399