summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Decls.hs4
-rw-r--r--compiler/GHC/Hs/Extension.hs5
-rw-r--r--compiler/GHC/Hs/Instances.hs5
-rw-r--r--compiler/GHC/Hs/Pat.hs2
-rw-r--r--compiler/GHC/Hs/Types.hs131
-rw-r--r--compiler/GHC/HsToCore/Quote.hs6
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs48
-rw-r--r--compiler/GHC/Parser/PostProcess.hs4
-rw-r--r--compiler/GHC/Rename/Bind.hs2
-rw-r--r--compiler/GHC/Rename/Expr.hs2
-rw-r--r--compiler/GHC/Rename/HsType.hs107
-rw-r--r--compiler/GHC/Rename/Module.hs4
-rw-r--r--compiler/GHC/Rename/Pat.hs8
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs16
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs2
-rw-r--r--compiler/GHC/ThToHs.hs4
-rw-r--r--testsuite/tests/hiefile/should_compile/hie007.hs3
18 files changed, 246 insertions, 109 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index f0ffd06307..8044b37cc4 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -2244,7 +2244,7 @@ type LRuleBndr pass = Located (RuleBndr pass)
-- | Rule Binder
data RuleBndr pass
= RuleBndr (XCRuleBndr pass) (Located (IdP pass))
- | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
+ | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)
| XRuleBndr !(XXRuleBndr pass)
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -2256,7 +2256,7 @@ type instance XCRuleBndr (GhcPass _) = NoExtField
type instance XRuleBndrSig (GhcPass _) = NoExtField
type instance XXRuleBndr (GhcPass _) = NoExtCon
-collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
+collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 0de2ac35a6..02106ab060 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -685,6 +685,11 @@ type family XXHsWildCardBndrs x b
-- -------------------------------------
+type family XHsPS x
+type family XXHsPatSigType x
+
+-- -------------------------------------
+
type family XForAllTy x
type family XQualTy x
type family XTyVar x
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 6eca193bb8..f30e07a50e 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -386,6 +386,11 @@ deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)
+-- deriving instance (DataIdLR p p) => Data (HsPatSigType p)
+deriving instance Data (HsPatSigType GhcPs)
+deriving instance Data (HsPatSigType GhcRn)
+deriving instance Data (HsPatSigType GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
deriving instance Data (HsTyVarBndr GhcPs)
deriving instance Data (HsTyVarBndr GhcRn)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 50d3cf4aef..7b279ef3e1 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -240,7 +240,7 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| SigPat (XSigPat p) -- After typechecker: Type
(LPat p) -- Pattern with a type signature
- (LHsSigWcType (NoGhcTc p)) -- Signature can bind both
+ (HsPatSigType (NoGhcTc p)) -- Signature can bind both
-- kind and type vars
-- ^ Pattern with a type signature
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index fd782c6348..f7a595d0f0 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -23,6 +23,7 @@ module GHC.Hs.Types (
LHsQTyVars(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
+ HsPatSigType(..), HsPSRn(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
HsContext, LHsContext, noLHsContext,
@@ -47,7 +48,7 @@ module GHC.Hs.Types (
mkAnonWildCardTy, pprAnonWildCard,
- mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
+ mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
@@ -59,7 +60,7 @@ module GHC.Hs.Types (
splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
- ignoreParens, hsSigType, hsSigWcType,
+ ignoreParens, hsSigType, hsSigWcType, hsPatSigType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
hsTyKindSig,
hsConDetailsArgs,
@@ -184,6 +185,13 @@ is a bit complicated. Here's how it works.
f :: _a -> _
The enclosing HsWildCardBndrs binds the wildcards _a and _.
+* HsSigPatType describes types that appear in pattern signatures and
+ the signatures of term-level binders in RULES. Like
+ HsWildCardBndrs/HsImplicitBndrs, they track the names of wildcard
+ variables and implicitly bound type variables. Unlike
+ HsImplicitBndrs, however, HsSigPatTypes do not obey the
+ forall-or-nothing rule. See Note [Pattern signature binders and scoping].
+
* The explicit presence of these wrappers specifies, in the HsSyn,
exactly where implicit quantification is allowed, and where
wildcards are allowed.
@@ -225,13 +233,15 @@ Note carefully:
Here _a is an ordinary forall'd binder, but (With NamedWildCards)
_b is a named wildcard. (See the comments in #10982)
-* Named wildcards are bound by the HsWildCardBndrs construct, which wraps
- types that are allowed to have wildcards. Unnamed wildcards however are left
- unchanged until typechecking, where we give them fresh wild tyavrs and
- determine whether or not to emit hole constraints on each wildcard
- (we don't if it's a visible type/kind argument or a type family pattern).
- See related notes Note [Wildcards in visible kind application]
- and Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType
+* Named wildcards are bound by the HsWildCardBndrs (for types that obey the
+ forall-or-nothing rule) and HsPatSigType (for type signatures in patterns
+ and term-level binders in RULES), which wrap types that are allowed to have
+ wildcards. Unnamed wildcards, however are left unchanged until typechecking,
+ where we give them fresh wild tyvars and determine whether or not to emit
+ hole constraints on each wildcard (we don't if it's a visible type/kind
+ argument or a type family pattern). See related notes
+ Note [Wildcards in visible kind application] and
+ Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType.
* After type checking is done, we report what types the wildcards
got unified with.
@@ -399,6 +409,33 @@ type instance XHsWC GhcTc b = [Name]
type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon
+-- | Types that can appear in pattern signatures, as well as the signatures for
+-- term-level binders in RULES.
+-- See @Note [Pattern signature binders and scoping]@.
+--
+-- This is very similar to 'HsSigWcType', but with
+-- slightly different semantics: see @Note [HsType binders]@.
+-- See also @Note [The wildcard story for types]@.
+data HsPatSigType pass
+ = HsPS { hsps_ext :: XHsPS pass -- ^ After renamer: 'HsPSRn'
+ , hsps_body :: LHsType pass -- ^ Main payload (the type itself)
+ }
+ | XHsPatSigType !(XXHsPatSigType pass)
+
+-- | The extension field for 'HsPatSigType', which is only used in the
+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.
+data HsPSRn = HsPSRn
+ { hsps_nwcs :: [Name] -- ^ Wildcard names
+ , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names
+ }
+ deriving Data
+
+type instance XHsPS GhcPs = NoExtField
+type instance XHsPS GhcRn = HsPSRn
+type instance XHsPS GhcTc = HsPSRn
+
+type instance XXHsPatSigType (GhcPass _) = NoExtCon
+
-- | Located Haskell Signature Type
type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only
@@ -419,6 +456,9 @@ hsSigType = hsImplicitBody
hsSigWcType :: LHsSigWcType pass -> LHsType pass
hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
+hsPatSigType :: HsPatSigType pass -> LHsType pass
+hsPatSigType = hsps_body
+
dropWildCards :: LHsSigWcType pass -> LHsSigType pass
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = hswc_body sig_ty
@@ -441,6 +481,71 @@ we get
, hst_body = blah }
The implicit kind variable 'k' is bound by the HsIB;
the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
+
+Note [Pattern signature binders and scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the pattern signatures like those on `t` and `g` in:
+
+ f = let h = \(t :: (b, b) ->
+ \(g :: forall a. a -> b) ->
+ ...(t :: (Int,Int))...
+ in woggle
+
+* The `b` in t's pattern signature is implicitly bound and scopes over
+ the signature and the body of the lambda. It stands for a type (any type);
+ indeed we subsequently discover that b=Int.
+ (See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.)
+* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by
+ t's pattern signature.
+* The `a` in `forall a` scopes only over the type `a -> b`, not over the body
+ of the lambda.
+* There is no forall-or-nothing rule for pattern signatures, which is why the
+ type `forall a. a -> b` is permitted in `g`'s pattern signature, even though
+ `b` is not explicitly bound.
+ See Note [forall-or-nothing rule] in GHC.Rename.HsType.
+
+Similar scoping rules apply to term variable binders in RULES, like in the
+following example:
+
+ {-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-}
+
+Just like in pattern signatures, the `b` in t's signature is implicitly bound
+and scopes over the remainder of the RULE. As a result, the `b` in g's
+signature is an occurrence. Moreover, the `a` in `forall a` scopes only over
+the type `a -> b`, and the forall-or-nothing rule does not apply.
+
+While quite similar, RULE term binder signatures behave slightly differently
+from pattern signatures in two ways:
+
+1. Unlike in pattern signatures, where type variables can stand for any type,
+ type variables in RULE term binder signatures are skolems.
+ See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for
+ more on this point.
+
+ In this sense, type variables in pattern signatures are quite similar to
+ named wildcards, as both can refer to arbitrary types. The main difference
+ lies in error reporting: if a named wildcard `_a` in a pattern signature
+ stands for Int, then by default GHC will emit a warning stating as much.
+ Changing `_a` to `a`, on the other hand, will cause it not to be reported.
+2. In the `h` RULE above, only term variables are explicitly bound, so any free
+ type variables in the term variables' signatures are implicitly bound.
+ This is just like how the free type variables in pattern signatures are
+ implicitly bound. If a RULE explicitly binds both term and type variables,
+ however, then free type variables in term signatures are /not/ implicitly
+ bound. For example, this RULE would be ill scoped:
+
+ {-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b).
+ h2 t g = ... #-}
+
+ This is because `b` and `c` occur free in the signature for `t`, but only
+ `b` was explicitly bound, leaving `c` out of scope. If the RULE had started
+ with `forall b c.`, then it would have been accepted.
+
+The types in pattern signatures and RULE term binder signatures are represented
+in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of
+type HsPSRn) tracks the names of named wildcards and implicitly bound type
+variables so that they can be brought into scope during renaming and
+typechecking.
-}
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
@@ -451,6 +556,10 @@ mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_ext = noExtField }
+mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs
+mkHsPatSigType x = HsPS { hsps_ext = noExtField
+ , hsps_body = x }
+
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
@@ -1408,6 +1517,10 @@ instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
+instance OutputableBndrId p
+ => Outputable (HsPatSigType (GhcPass p)) where
+ ppr (HsPS { hsps_body = ty }) = ppr ty
+
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 166127f9d1..395f1adfb0 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -821,7 +821,7 @@ repRuleD (L loc (HsRule { rd_name = n
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig _ n sig))
- | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
+ | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig
= unLoc n : vars
repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
@@ -830,7 +830,7 @@ repRuleBndr (L _ (RuleBndr _ n))
; rep2 ruleVarName [n'] }
repRuleBndr (L _ (RuleBndrSig _ n sig))
= do { MkC n' <- lookupLBinder n
- ; MkC ty' <- repLTy (hsSigWcType sig)
+ ; MkC ty' <- repLTy (hsPatSigType sig)
; rep2 typedRuleVarName [n', ty'] }
repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1935,7 +1935,7 @@ repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat _ p t) = do { p' <- repLP p
- ; t' <- repLTy (hsSigWcType t)
+ ; t' <- repLTy (hsPatSigType t)
; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index ddb29ce63d..6b469160e2 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -413,35 +413,9 @@ bar (x :: forall a. a -> a) = ... -- a is not in scope here
-- ^ a is in scope here (pattern body)
bax (x :: a) = ... -- a is in scope here
-Because of HsWC and HsIB pass on their scope to their children
-we must wrap the LHsType in pattern signatures in a
-Shielded explicitly, so that the HsWC/HsIB scope is not passed
-on the the LHsType
--}
-
-data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
-
-type family ProtectedSig a where
- ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
- GhcRn
- (Shielded (LHsType GhcRn)))
- ProtectedSig GhcTc = NoExtField
-
-class ProtectSig a where
- protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
-
-instance (HasLoc a) => HasLoc (Shielded a) where
- loc (SH _ a) = loc a
-
-instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
- toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
-instance ProtectSig GhcTc where
- protectSig _ _ = noExtField
-
-instance ProtectSig GhcRn where
- protectSig sc (HsWC a (HsIB b sig)) =
- HsWC a (HsIB b (SH sc sig))
+This case in handled in the instance for HsPatSigType
+-}
class HasLoc a where
-- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
@@ -770,8 +744,6 @@ instance ( a ~ GhcPass p
, ToHie (RContext (HsRecFields a (PScoped (LPat a))))
, ToHie (LHsExpr a)
, ToHie (TScoped (LHsSigWcType a))
- , ProtectSig a
- , ToHie (TScoped (ProtectedSig a))
, HasType (LPat a)
, Data (HsSplice a)
, IsPass p
@@ -832,9 +804,12 @@ instance ( a ~ GhcPass p
SigPat _ pat sig ->
[ toHie $ PS rsp scope pscope pat
, let cscope = mkLScope pat in
- toHie $ TS (ResolvedScopes [cscope, scope, pscope])
- (protectSig @a cscope sig)
- -- See Note [Scoping Rules for SigPat]
+ case ghcPass @p of
+ GhcPs -> pure []
+ GhcTc -> pure []
+ GhcRn ->
+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
+ sig
]
XPat e -> case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
@@ -856,6 +831,13 @@ instance ( a ~ GhcPass p
L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
scoped_fds = listScopes pscope fds
+instance ToHie (TScoped (HsPatSigType GhcRn)) where
+ toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
+ , toHie body
+ ]
+ -- See Note [Scoping Rules for SigPat]
+
instance ( ToHie body
, ToHie (LGRHS a body)
, ToHie (RScoped (LHsLocalBinds a))
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 94137f07ba..b9bff61599 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -874,7 +874,7 @@ mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
mkRuleBndrs = fmap (fmap cvt_one)
where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v
cvt_one (RuleTyTmVar v (Just sig)) =
- RuleBndrSig noExtField v (mkLHsSigWcType sig)
+ RuleBndrSig noExtField v (mkHsPatSigType sig)
-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs]
@@ -2033,7 +2033,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))
mkHsTySigPV l b sig = do
p <- checkLPat b
- return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig)))
+ return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
return (L l (PatBuilderPat (ListPat noExtField ps)))
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index fe7fb78b08..a2566220b6 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -955,7 +955,7 @@ renameSig _ (IdSig _ x)
renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
- ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
+ ; (new_ty, fvs) <- rnHsSigWcType doc ty
; return (TypeSig noExtField new_vs new_ty, fvs) }
renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 6ec473134d..65d119ab12 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -316,7 +316,7 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
, fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig _ expr pty)
- = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
+ = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 537b2a47f0..f3727221a0 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -13,7 +13,7 @@ module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType,
- HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
+ HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
@@ -71,11 +71,11 @@ import Control.Monad ( unless, when )
{-
These type renamers are in a separate module, rather than in (say) GHC.Rename.Module,
-to break several loop.
+to break several loops.
*********************************************************
* *
- HsSigWcType (i.e with wildcards)
+ HsSigWcType and HsPatSigType (i.e with wildcards)
* *
*********************************************************
-}
@@ -85,46 +85,77 @@ data HsSigWcTypeScoping
-- ^ Always bind any free tyvars of the given type, regardless of whether we
-- have a forall at the top.
--
- -- For pattern type sigs and rules we /do/ want to bring those type
+ -- For pattern type sigs, we /do/ want to bring those type
-- variables into scope, even if there's a forall at the top which usually
-- stops that happening, e.g:
--
- -- > \ (x :: forall a. a-> b) -> e
+ -- > \ (x :: forall a. a -> b) -> e
--
-- Here we do bring 'b' into scope.
+ --
+ -- RULES can also use 'AlwaysBind', such as in the following example:
+ --
+ -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-}
+ --
+ -- This only applies to RULES that do not explicitly bind their type
+ -- variables. If a RULE explicitly quantifies its type variables, then
+ -- 'NeverBind' is used instead. See also
+ -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Types".
| BindUnlessForall
- -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'
+ -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'.
+ -- This is only ever used in places where the \"@forall@-or-nothing\" rule
+ -- is in effect. See @Note [forall-or-nothing rule]@.
| NeverBind
- -- ^ Never bind any free tyvars
-
-rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+ -- ^ Never bind any free tyvars. This is used for RULES that have both
+ -- explicit type and term variable binders, e.g.:
+ --
+ -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-}
+ --
+ -- The presence of the type variable binder @forall a.@ implies that the
+ -- free variables in the types of the term variable binders @x@ and @y@
+ -- are /not/ bound. In the example above, there are no such free variables,
+ -- but if the user had written @(y :: b)@ instead of @y@ in the term
+ -- variable binders, then @b@ would be rejected for being out of scope.
+ -- See also @Note [Pattern signature binders and scoping]@ in
+ -- "GHC.Hs.Types".
+
+rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType scoping doc sig_ty
- = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
- return (sig_ty', emptyFVs)
-
-rnHsSigWcTypeScoped :: HsSigWcTypeScoping
- -> HsDocContext -> LHsSigWcType GhcPs
- -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
+rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
+ = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body ->
+ let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body }
+ wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in
+ pure (wc_ty, emptyFVs)
+
+rnHsPatSigType :: HsSigWcTypeScoping
+ -> HsDocContext -> HsPatSigType GhcPs
+ -> (HsPatSigType GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
-- Used for
--- - Signatures on binders in a RULE
--- - Pattern type signatures
+-- - Pattern type signatures, which are only allowed with ScopedTypeVariables
+-- - Signatures on binders in a RULE, which are allowed even if
+-- ScopedTypeVariables isn't enabled
-- Wildcards are allowed
--- type signatures on binders only allowed with ScopedTypeVariables
-rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
+--
+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Types
+rnHsPatSigType scoping ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
- ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
- ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
- }
-
-rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
- -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
+ ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)
+ ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $
+ \nwcs imp_tvs body ->
+ do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
+ sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body }
+ ; thing_inside sig_ty'
+ } }
+
+-- The workhorse for rnHsSigWcType and rnHsPatSigType.
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsType GhcPs
+ -> ([Name] -- Wildcard names
+ -> [Name] -- Implicitly bound type variable names
+ -> LHsType GhcRn
+ -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
--- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type scoping ctxt
- (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
- thing_inside
+rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside
= do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
@@ -134,10 +165,7 @@ rn_hs_sig_wc_type scoping ctxt
NeverBind -> []
; rnImplicitBndrs implicit_bndrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
- ib_ty' = HsIB { hsib_ext = vars
- , hsib_body = hs_ty' }
- ; (res, fvs2) <- thing_inside sig_ty'
+ ; (res, fvs2) <- thing_inside wcs vars hs_ty'
; return (res, fvs1 `plusFV` fvs2) } }
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
@@ -321,8 +349,9 @@ rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
-- therefore an indication that the user is trying to be fastidious, so
-- we don't implicitly bind any variables.
--- | See note Note [forall-or-nothing rule]. This tiny little function is used
--- (rather than its small body inlined) to indicate we implementing that rule.
+-- | See Note [forall-or-nothing rule]. This tiny little function is used
+-- (rather than its small body inlined) to indicate that we are implementing
+-- that rule.
forAllOrNothing :: Bool
-- ^ True <=> explicit forall
-- E.g. f :: forall a. a->b
@@ -1396,8 +1425,8 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
* *
***************************************************** -}
-unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
-unexpectedTypeSigErr ty
+unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> SDoc
+unexpectedPatSigTypeErr ty
= hang (text "Illegal type signature:" <+> quotes (ppr ty))
2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index a4ca8a5165..2a09849e52 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -957,7 +957,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; (mds', ty', fvs)
<- rnLDerivStrategy DerivDeclCtx mds $
- rnHsSigWcType BindUnlessForall DerivDeclCtx ty
+ rnHsSigWcType DerivDeclCtx ty
; warnNoDerivStrat mds' loc
; return (DerivDecl noExtField ty' mds' overlap, fvs) }
where
@@ -1028,7 +1028,7 @@ bindRuleTmVars doc tyvs vars names thing_inside
go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
(n : ns) thing_inside
- = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
+ = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars')
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 1e2bf09f45..09e2ea8cbe 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -218,9 +218,6 @@ matchNameMaker ctxt = LamMk report_unused
ThPatQuote -> False
_ -> True
-rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
-rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
-
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
newPatLName name_maker rdr_name@(L loc _)
= do { name <- newPatName name_maker rdr_name
@@ -410,9 +407,12 @@ rnPatAndThen mk (SigPat x pat sig)
-- f ((Just (x :: a) :: Maybe a)
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here
-- ~~~~~~~~~~~~~~~^ the same `a' then used here
- = do { sig' <- rnHsSigCps sig
+ = do { sig' <- rnHsPatSigTypeAndThen sig
; pat' <- rnLPatAndThen mk pat
; return (SigPat x pat' sig' ) }
+ where
+ rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
+ rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig)
rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 9342c367b3..cd48e5416f 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -3338,7 +3338,7 @@ Result works fine, but it may eventually bite us.
********************************************************************* -}
tcHsPatSigType :: UserTypeCtxt
- -> LHsSigWcType GhcRn -- The type signature
+ -> HsPatSigType GhcRn -- The type signature
-> TcM ( [(Name, TcTyVar)] -- Wildcards
, [(Name, TcTyVar)] -- The new bit of type environment, binding
-- the scoped type variables
@@ -3346,13 +3346,13 @@ tcHsPatSigType :: UserTypeCtxt
-- Used for type-checking type signatures in
-- (a) patterns e.g f (x::Int) = e
-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x
+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Types
--
-- This may emit constraints
-- See Note [Recipe for checking a signature]
-tcHsPatSigType ctxt sig_ty
- | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
- , HsIB { hsib_ext = sig_ns
- , hsib_body = hs_ty } <- ib_ty
+tcHsPatSigType ctxt
+ (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
+ , hsps_body = hs_ty })
= addSigCtxt ctxt hs_ty $
do { sig_tkv_prs <- mapM new_implicit_tv sig_ns
; (wcs, sig_ty)
@@ -3385,12 +3385,12 @@ tcHsPatSigType ctxt sig_ty
; tv <- case ctxt of
RuleSigCtxt {} -> newSkolemTyVar name kind
_ -> newPatSigTyVar name kind
- -- See Note [Pattern signature binders]
+ -- See Note [Typechecking pattern signature binders]
-- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
; return (name, tv) }
-{- Note [Pattern signature binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Typechecking pattern signature binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [Type variables in the type environment] in GHC.Tc.Utils.
Consider
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 2f7d2e7721..bd9afd766f 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -690,7 +690,7 @@ because they won't be in scope when we do the desugaring
-}
tcPatSig :: Bool -- True <=> pattern binding
- -> LHsSigWcType GhcRn
+ -> HsPatSigType GhcRn
-> ExpSigmaType
-> TcM (TcType, -- The type to use for "inside" the signature
[(Name,TcTyVar)], -- The new bit of type environment, binding
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 708218abe5..3ed75ac49b 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -230,7 +230,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
= do { let ctxt = RuleSigCtxt name
; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
; let id = mkLocalId name id_ty
- -- See Note [Pattern signature binders] in GHC.Tc.Gen.HsType
+ -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
-- The type variables scope over subsequent bindings; yuk
; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index b0d797885b..e1d1c97410 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -830,7 +830,7 @@ cvtRuleBndr (RuleVar n)
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
- ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' }
+ ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkHsPatSigType ty' }
---------------------------------------------------
-- Declarations
@@ -1307,7 +1307,7 @@ cvtp (ListP ps) = do { ps' <- cvtPats ps
; return
$ ListPat noExtField ps'}
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
- ; return $ SigPat noExtField p' (mkLHsSigWcType t') }
+ ; return $ SigPat noExtField p' (mkHsPatSigType t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noExtField e' p'}
diff --git a/testsuite/tests/hiefile/should_compile/hie007.hs b/testsuite/tests/hiefile/should_compile/hie007.hs
index 3f0103bf2a..a99e6340c6 100644
--- a/testsuite/tests/hiefile/should_compile/hie007.hs
+++ b/testsuite/tests/hiefile/should_compile/hie007.hs
@@ -64,3 +64,6 @@ thud f x =
(x :: a, y) :: (a, b)
where
y = (f :: a -> b) x :: b
+
+rankn :: (forall a1. a1 -> b) -> a2 -> b
+rankn (g :: forall a1. a1 -> b) x = g x :: b
View Lorry Controller Status