Commit a31218f7 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari
Browse files

Use HsForAllTelescope to avoid inferred, visible foralls

Currently, `HsForAllTy` permits the combination of `ForallVis` and
`Inferred`, but you can't actually typecheck code that uses it
(e.g., `forall {a} ->`). This patch refactors `HsForAllTy` to use a
new `HsForAllTelescope` data type that makes a type-level distinction
between visible and invisible `forall`s such that visible `forall`s
do not track `Specificity`. That part of the patch is actually quite
small; the rest is simply changing consumers of `HsType` to
accommodate this new type.

Fixes #18235. Bumps the `haddock` submodule.
parent 7a773f16
......@@ -34,7 +34,7 @@ module GHC.Core.TyCo.Rep (
KindOrType, Kind,
KnotTied,
PredType, ThetaType, -- Synonyms
ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),
ArgFlag(..), AnonArgFlag(..),
-- * Coercions
Coercion(..),
......
......@@ -15,7 +15,7 @@ module GHC.Core.Type (
-- $type_classification
-- $representation_types
TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),
TyThing(..), Type, ArgFlag(..), AnonArgFlag(..),
Specificity(..),
KindOrType, PredType, ThetaType,
Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,
......@@ -44,7 +44,8 @@ module GHC.Core.Type (
mkSpecForAllTy, mkSpecForAllTys,
mkVisForAllTys, mkTyCoInvForAllTy,
mkInfForAllTy, mkInfForAllTys,
splitForAllTys, splitForAllTysSameVis,
splitForAllTys, splitSomeForAllTys,
splitForAllTysReq, splitForAllTysInvis,
splitForAllVarBndrs,
splitForAllTy_maybe, splitForAllTy,
splitForAllTy_ty_maybe, splitForAllTy_co_maybe,
......@@ -271,7 +272,7 @@ import GHC.Data.List.SetOps
import GHC.Types.Unique ( nonDetCmpUnique )
import GHC.Data.Maybe ( orElse )
import Data.Maybe ( isJust )
import Data.Maybe ( isJust, mapMaybe )
import Control.Monad ( guard )
-- $type_classification
......@@ -1576,19 +1577,47 @@ splitForAllTys ty = split ty ty []
split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if
-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility
-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided
-- as an argument to this function.
-- Furthermore, each returned tyvar is annotated with its argf.
splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVarBinder], Type)
splitForAllTysSameVis supplied_argf ty = split ty ty []
-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if @argf_pred argf@
-- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and
-- @argf_pred@ is a predicate over visibilities provided as an argument to this
-- function. Furthermore, each returned tyvar is annotated with its @argf@.
splitSomeForAllTys :: (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type)
splitSomeForAllTys argf_pred ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
split _ (ForAllTy (Bndr tv argf) ty) tvs
| argf `sameVis` supplied_argf = split ty ty ((Bndr tv argf):tvs)
split _ (ForAllTy tvb@(Bndr _ argf) ty) tvs
| argf_pred argf = split ty ty (tvb:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Required' type
-- variable binders. Furthermore, each returned tyvar is annotated with '()'.
splitForAllTysReq :: Type -> ([ReqTVBinder], Type)
splitForAllTysReq ty =
let (all_bndrs, body) = splitSomeForAllTys 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
-- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Invisible' type
-- variable binders. Furthermore, each returned tyvar is annotated with its
-- 'Specificity'.
splitForAllTysInvis :: Type -> ([InvisTVBinder], Type)
splitForAllTysInvis ty =
let (all_bndrs, body) = splitSomeForAllTys 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
-- | Like splitForAllTys, but split only for tyvars.
-- This always succeeds, even if it returns only an empty list. Note that the
-- result type returned may have free variables that were bound by a forall.
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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]
......
......@@ -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))
......
......@@ -196,7 +196,7 @@ subordinates instMap decl = case decl of
extract_deriv_ty (L l ty) =
case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
HsForAllTy{ hst_fvf = ForallInvis
HsForAllTy{ hst_tele = HsForAllInvis{}
, hst_body = L _ (HsDocTy _ _ doc) }
-> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
......
......@@ -1265,7 +1265,7 @@ repLTy ty = repTy (unLoc ty)
-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
-- In other words, the argument to this function is always an
-- @HsForAllTy ForallInvis@ or @HsQualTy@.
-- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@.
-- Types headed by visible foralls (which are desugared to ForallVisT) are
-- handled separately in repTy.
repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
......@@ -1278,14 +1278,13 @@ repForallT ty
}
repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =
case fvf of
ForallInvis -> repForallT ty
ForallVis -> let tvs' = map ((<$>) (setHsTyVarBndrFlag ())) tvs
-- see Note [Specificity in HsForAllTy] in GHC.Hs.Type
in addHsTyVarBinds tvs' $ \bndrs ->
do body1 <- repLTy body
repTForallVis bndrs body1
repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
case tele of
HsForAllInvis{} -> repForallT ty
HsForAllVis { hsf_vis_bndrs = tvs } ->
addHsTyVarBinds tvs $ \bndrs ->
do body1 <- repLTy body
repTForallVis bndrs body1
repTy ty@(HsQualTy {}) = repForallT ty
repTy (HsTyVar _ _ (L _ n))
......
......@@ -1633,8 +1633,13 @@ 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 ->
[ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
HsForAllTy _ tele body ->
let scope = mkScope $ getLoc body in
[ case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
toHie $ tvScopes tsc scope bndrs
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
toHie $ tvScopes tsc scope bndrs
, toHie body
]
HsQualTy _ ctx body ->
......
......@@ -31,8 +31,7 @@ module GHC.Iface.Type (
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllSpecBndr,
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..),
ForallVisFlag(..), ShowForAllFlag(..),
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
mkIfaceTyConKind,
ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr,
......
......@@ -1890,9 +1890,16 @@ 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) }
| '->' { (mu AnnRarrow $1, ForallVis) }
forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) }
: 'forall' tv_bndrs '.' {% do { hintExplicitForall $1
; pure $ sLL $1 $>
( [mu AnnForall $1, mu AnnDot $3]
, mkHsForAllInvisTele $2 ) }}
| 'forall' tv_bndrs '->' {% do { hintExplicitForall $1
; req_tvbs <- fromSpecTyVarBndrs $2
; pure $ sLL $1 $> $
( [mu AnnForall $1, mu AnnRarrow $3]
, mkHsForAllVisTele req_tvbs ) }}
-- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation
ktype :: { LHsType GhcPs }
......@@ -1907,15 +1914,12 @@ ktypedoc :: { LHsType GhcPs }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
: 'forall' tv_bndrs forall_vis_flag ctype
{% let (fv_ann, fv_flag) = $3 in
hintExplicitForall $1 *>
ams (sLL $1 $> $
HsForAllTy { hst_fvf = fv_flag
, hst_bndrs = $2
, hst_xforall = noExtField
, hst_body = $4 })
[mu AnnForall $1,fv_ann] }
: forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in
ams (sLL $1 $> $
HsForAllTy { hst_tele = forall_tele
, hst_xforall = noExtField
, hst_body = $2 })
forall_anns }
| context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
......@@ -1937,15 +1941,12 @@ ctype :: { LHsType GhcPs }
-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
ctypedoc :: { LHsType GhcPs }
: 'forall' tv_bndrs forall_vis_flag ctypedoc
{% let (fv_ann, fv_flag) = $3 in
hintExplicitForall $1 *>
ams (sLL $1 $> $
HsForAllTy { hst_fvf = fv_flag
, hst_bndrs = $2
, hst_xforall = noExtField
, hst_body = $4 })
[mu AnnForall $1,fv_ann] }
: forall_telescope ctypedoc {% let (forall_anns, forall_tele) = unLoc $1 in
ams (sLL $1 $> $
HsForAllTy { hst_tele = forall_tele
, hst_xforall = noExtField
, hst_body = $2 })
forall_anns }
| context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
>> return (sLL $1 $> $
HsQualTy { hst_ctxt = $1
......
......@@ -23,6 +23,7 @@ module GHC.Rename.HsType (
checkPrecMatch, checkSectionPrec,