From e07e383a3250cb27a9128ad8d5c68def5c3df336 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sun, 5 Jul 2020 16:15:01 -0400
Subject: [PATCH] Replace HsImplicitBndrs with HsOuterTyVarBndrs
This refactors the GHC AST to remove `HsImplicitBndrs` and replace it with
`HsOuterTyVarBndrs`, a type which records whether the outermost quantification
in a type is explicit (i.e., with an outermost, invisible `forall`) or
implicit. As a result of this refactoring, it is now evident in the AST where
the `forall`-or-nothing rule applies: it's all the places that use
`HsOuterTyVarBndrs`. See the revamped `Note [forall-or-nothing rule]` in
`GHC.Hs.Type` (previously in `GHC.Rename.HsType`).
Moreover, the places where `ScopedTypeVariables` brings lexically scoped type
variables into scope are a subset of the places that adhere to the
`forall`-or-nothing rule, so this also makes places that interact with
`ScopedTypeVariables` easier to find. See the revamped
`Note [Lexically scoped type variables]` in `GHC.Hs.Type` (previously in
`GHC.Tc.Gen.Sig`).
`HsOuterTyVarBndrs` are used in type signatures (see `HsOuterSigTyVarBndrs`)
and type family equations (see `HsOuterFamEqnTyVarBndrs`). The main difference
between the former and the latter is that the former cares about specificity
but the latter does not.
There are a number of knock-on consequences:
* There is now a dedicated `HsSigType` type, which is the combination of
`HsOuterSigTyVarBndrs` and `HsType`. `LHsSigType` is now an alias for an
`XRec` of `HsSigType`.
* Working out the details led us to a substantial refactoring of
the handling of explicit (user-written) and implicit type-variable
bindings in `GHC.Tc.Gen.HsType`.
Instead of a confusing family of higher order functions, we now
have a local data type, `SkolemInfo`, that controls how these
binders are kind-checked.
It remains very fiddly, not fully satisfying. But it's better
than it was.
Fixes #16762. Bumps the Haddock submodule.
Co-authored-by: Simon Peyton Jones <simonpj@microsoft.com>
Co-authored-by: Richard Eisenberg <rae@richarde.dev>
Co-authored-by: Zubin Duggal <zubin@cmi.ac.in>
---
compiler/GHC/Core/Coercion.hs | 4 +-
compiler/GHC/Hs/Decls.hs | 86 +-
compiler/GHC/Hs/Extension.hs | 12 +-
compiler/GHC/Hs/Instances.hs | 13 +-
compiler/GHC/Hs/Type.hs | 549 +++++---
compiler/GHC/Hs/Utils.hs | 19 +-
compiler/GHC/HsToCore/Docs.hs | 30 +-
compiler/GHC/HsToCore/Quote.hs | 217 ++--
compiler/GHC/Iface/Ext/Ast.hs | 80 +-
compiler/GHC/Parser.y | 82 +-
compiler/GHC/Parser/PostProcess.hs | 36 +-
compiler/GHC/Parser/PostProcess/Haddock.hs | 30 +-
compiler/GHC/Rename/HsType.hs | 193 ++-
compiler/GHC/Rename/Module.hs | 148 +--
compiler/GHC/Rename/Names.hs | 3 +-
compiler/GHC/Rename/Utils.hs | 11 +-
compiler/GHC/Tc/Deriv.hs | 19 +-
compiler/GHC/Tc/Deriv/Generate.hs | 23 +-
compiler/GHC/Tc/Errors.hs | 11 +-
compiler/GHC/Tc/Gen/Bind.hs | 2 +-
compiler/GHC/Tc/Gen/Head.hs | 2 +-
compiler/GHC/Tc/Gen/HsType.hs | 805 +++++++-----
compiler/GHC/Tc/Gen/Pat.hs | 12 +
compiler/GHC/Tc/Gen/Sig.hs | 119 +-
compiler/GHC/Tc/Module.hs | 14 +-
compiler/GHC/Tc/Solver.hs | 50 +-
compiler/GHC/Tc/Solver/Canonical.hs | 2 +-
compiler/GHC/Tc/TyCl.hs | 170 +--
compiler/GHC/Tc/TyCl/Class.hs | 10 +-
compiler/GHC/Tc/TyCl/Instance.hs | 39 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 104 +-
compiler/GHC/Tc/Types/Constraint.hs | 57 +-
compiler/GHC/Tc/Types/Origin.hs | 5 +-
compiler/GHC/Tc/Utils/Env.hs | 4 +-
compiler/GHC/Tc/Utils/Instantiate.hs | 29 +-
compiler/GHC/Tc/Utils/Monad.hs | 4 +-
compiler/GHC/Tc/Utils/Unify.hs | 15 +-
compiler/GHC/Tc/Validity.hs | 2 +-
compiler/GHC/ThToHs.hs | 126 +-
compiler/GHC/Utils/Monad.hs | 7 +
ghc/GHCi/UI.hs | 6 +-
.../should_fail/BadTelescope5.stderr | 7 +-
.../tests/dependent/should_fail/T14066.stderr | 2 +-
.../should_fail/TypeSkolEscape.stderr | 2 +-
.../should_compile_flag_haddock/T17544.stderr | 1101 +++++++++--------
.../T17544_kw.stderr | 29 +-
.../should_compile/DumpParsedAst.stderr | 303 +++--
.../should_compile/DumpRenamedAst.stderr | 598 +++++----
.../parser/should_compile/KindSigs.stderr | 231 ++--
.../tests/parser/should_compile/T15323.stderr | 17 +-
.../partial-sigs/should_compile/T16762d.hs | 14 +
.../tests/partial-sigs/should_compile/all.T | 1 +
.../partial-sigs/should_fail/T14040a.stderr | 42 +-
.../tests/patsyn/should_fail/T11039.stderr | 2 +-
.../tests/patsyn/should_fail/T11667.stderr | 2 +-
.../tests/patsyn/should_fail/T15694.stderr | 3 +-
testsuite/tests/polykinds/T11142.stderr | 2 +-
testsuite/tests/polykinds/T11516.stderr | 2 +-
testsuite/tests/polykinds/T11520.stderr | 8 +-
testsuite/tests/polykinds/T15787.stderr | 4 +-
testsuite/tests/polykinds/T16221a.stderr | 2 +-
testsuite/tests/polykinds/T16762.hs | 11 +
testsuite/tests/polykinds/T16762.stderr | 7 +
testsuite/tests/polykinds/T16762a.hs | 12 +
testsuite/tests/polykinds/T16762a.stderr | 6 +
testsuite/tests/polykinds/T16762b.hs | 8 +
testsuite/tests/polykinds/T16762b.stderr | 4 +
testsuite/tests/polykinds/T16762c.hs | 10 +
testsuite/tests/polykinds/T16762c.stderr | 7 +
testsuite/tests/polykinds/T7278.stderr | 4 +-
.../tests/polykinds/TyVarTvKinds3.stderr | 4 +-
testsuite/tests/polykinds/all.T | 4 +
testsuite/tests/printer/T18791.stderr | 4 +-
.../saks/should_fail/saks_fail020.stderr | 12 +-
.../typecheck/should_fail/T12102b.stderr | 3 +-
.../tests/typecheck/should_fail/T13909.stderr | 8 +-
.../tests/typecheck/should_fail/T15629.stderr | 10 +-
.../tests/typecheck/should_fail/T15799.stderr | 10 +-
.../tests/typecheck/should_fail/T16517.stderr | 8 +-
utils/haddock | 2 +-
80 files changed, 3171 insertions(+), 2485 deletions(-)
create mode 100644 testsuite/tests/partial-sigs/should_compile/T16762d.hs
create mode 100644 testsuite/tests/polykinds/T16762.hs
create mode 100644 testsuite/tests/polykinds/T16762.stderr
create mode 100644 testsuite/tests/polykinds/T16762a.hs
create mode 100644 testsuite/tests/polykinds/T16762a.stderr
create mode 100644 testsuite/tests/polykinds/T16762b.hs
create mode 100644 testsuite/tests/polykinds/T16762b.stderr
create mode 100644 testsuite/tests/polykinds/T16762c.hs
create mode 100644 testsuite/tests/polykinds/T16762c.stderr
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 56d893888699..16d8f427e988 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -1190,7 +1190,7 @@ mkGReflLeftCo r ty co
mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
mkCoherenceLeftCo r ty co co2
| isGReflCo co = co2
- | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2
+ | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2
-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
-- produces @co' :: ty' ~r (ty |> co)
@@ -1199,7 +1199,7 @@ mkCoherenceLeftCo r ty co co2
mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
mkCoherenceRightCo r ty co co2
| isGReflCo co = co2
- | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)
+ | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)
-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
mkKindCo :: Coercion -> Coercion
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 2024b61b8125..dcb810ed7eba 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -50,8 +50,7 @@ module GHC.Hs.Decls (
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,
- FamInstEqn, LFamInstEqn, FamEqn(..),
- TyFamInstEqn, LTyFamInstEqn, HsTyPats,
+ FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,
LClsInstDecl, ClsInstDecl(..),
-- ** Standalone deriving declarations
@@ -759,8 +758,7 @@ tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))
-tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
- (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }})
= ln
tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))
@@ -1467,15 +1465,9 @@ data ConDecl pass
-- The following fields describe the type after the '::'
-- See Note [GADT abstract syntax]
- , con_forall :: XRec pass Bool -- ^ True <=> explicit forall
- -- False => hsq_explicit is empty
- --
- -- The 'XRec' is used to anchor API
- -- annotations, AnnForall and AnnDot.
- , con_qvars :: [LHsTyVarBndr Specificity pass]
- -- Whether or not there is an /explicit/ forall, we still
- -- need to capture the implicitly-bound type/kind variables
-
+ , con_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass)
+ -- ^ The outermost type variable binders, be they explicit or implicit.
+ -- The 'XRec' is used to anchor API annotations, AnnForall and AnnDot.
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
, con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix
, con_res_ty :: LHsType pass -- ^ Result type
@@ -1502,10 +1494,7 @@ data ConDecl pass
}
| XConDecl !(XXConDecl pass)
-type instance XConDeclGADT GhcPs = NoExtField
-type instance XConDeclGADT GhcRn = [Name] -- Implicitly bound type variables
-type instance XConDeclGADT GhcTc = NoExtField
-
+type instance XConDeclGADT (GhcPass _) = NoExtField
type instance XConDeclH98 (GhcPass _) = NoExtField
type instance XXConDecl (GhcPass _) = NoExtCon
@@ -1733,11 +1722,11 @@ pprConDecl (ConDeclH98 { con_name = L _ con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe noLHsContext mcxt
-pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
+pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,
+ <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixConGADT args) = map ppr args
@@ -1796,26 +1785,23 @@ type HsTyPats pass = [LHsTypeArg pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The feqn_pats field of FamEqn (family instance equation) stores the LHS type
(and kind) patterns. Any type (and kind) variables contained
-in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs
-in FamInstEqn depending on whether or not an explicit forall is present. In
-the case of an explicit forall, the hsib_vars only includes kind variables not
-bound in the forall. Otherwise, all type (and kind) variables are bound in
-the hsib_vars. In the latter case, note that in particular
+in these type patterns are bound in the feqn_bndrs field.
+Note that in particular:
-* The hsib_vars *includes* any anonymous wildcards. For example
+* The feqn_bndrs *include* any anonymous wildcards. For example
type instance F a _ = a
- The hsib_vars will be {a, _}. Remember that each separate wildcard
- '_' gets its own unique. In this context wildcards behave just like
+ The feqn_bndrs will be HsOuterImplicit {a, _}. Remember that each separate
+ wildcard '_' gets its own unique. In this context wildcards behave just like
an ordinary type variable, only anonymous.
-* The hsib_vars *includes* type variables that are already in scope
+* The feqn_bndrs *include* type variables that are already in scope
Eg class C s t where
type F t p :: *
instance C w (a,b) where
type F (a,b) x = x->a
- The hsib_vars of the F decl are {a,b,x}, even though the F decl
- is nested inside the 'instance' decl.
+ The feqn_bndrs of the F decl is HsOuterImplicit {a,b,x}, even though the
+ F decl is nested inside the 'instance' decl.
However after the renamer, the uniques will match up:
instance C w7 (a8,b9) where
@@ -1827,7 +1813,9 @@ c.f. Note [TyVar binders for associated decls]
-}
-- | Type Family Instance Equation
-type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
+type TyFamInstEqn pass = FamEqn pass (LHsType pass)
+ -- Here, the @pats@ are type patterns (with kind and type bndrs).
+ -- See Note [Family instance declaration binders]
-- | Type family default declarations.
-- A convenient synonym for 'TyFamInstDecl'.
@@ -1855,7 +1843,7 @@ type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)
-- | Data Family Instance Declaration
newtype DataFamInstDecl pass
- = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
+ = DataFamInstDecl { dfid_eqn :: FamEqn pass (HsDataDefn pass) }
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',
-- 'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance',
@@ -1867,14 +1855,6 @@ newtype DataFamInstDecl pass
----------------- Family instances (common types) -------------
--- | Located Family Instance Equation
-type LFamInstEqn pass rhs = XRec pass (FamInstEqn pass rhs)
-
--- | Family Instance Equation
-type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)
- -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
- -- See Note [Family instance declaration binders]
-
-- | Family Equation
--
-- One equation in a type family instance declaration, data family instance
@@ -1885,7 +1865,7 @@ data FamEqn pass rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass rhs
, feqn_tycon :: LIdP pass
- , feqn_bndrs :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars
+ , feqn_bndrs :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars
, feqn_pats :: HsTyPats pass
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, feqn_rhs :: rhs
@@ -1974,11 +1954,11 @@ pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel
ppr_fam_inst_eqn :: (OutputableBndrId p)
=> TyFamInstEqn (GhcPass p) -> SDoc
-ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon
- , feqn_bndrs = bndrs
- , feqn_pats = pats
- , feqn_fixity = fixity
- , feqn_rhs = rhs }})
+ppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon
+ , feqn_bndrs = bndrs
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })
= pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs
instance OutputableBndrId p
@@ -1987,12 +1967,12 @@ instance OutputableBndrId p
pprDataFamInstDecl :: (OutputableBndrId p)
=> TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ tycon
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =
+ (FamEqn { feqn_tycon = L _ tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
- , feqn_rhs = defn }}})
+ , feqn_rhs = defn })})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
@@ -2000,19 +1980,19 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
-- pp_data_defn pretty-prints the kind sig. See #14817.
pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =
+ (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})
= ppr nd
pprHsFamInstLHS :: (OutputableBndrId p)
=> IdP (GhcPass p)
- -> Maybe [LHsTyVarBndr () (GhcPass p)]
+ -> HsOuterFamEqnTyVarBndrs (GhcPass p)
-> HsTyPats (GhcPass p)
-> LexicalFixity
-> LHsContext (GhcPass p)
-> SDoc
pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
- = hsep [ pprHsExplicitForAll bndrs
+ = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs
, pprLHsContext mb_ctxt
, pp_pats typats ]
where
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index b0216fe5674c..4310d1a5dd43 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -732,9 +732,15 @@ type family XHsQTvs x
type family XXLHsQTyVars x
-- -------------------------------------
--- HsImplicitBndrs type families
-type family XHsIB x b
-type family XXHsImplicitBndrs x b
+-- HsOuterTyVarBndrs type families
+type family XHsOuterImplicit x
+type family XHsOuterExplicit x flag
+type family XXHsOuterTyVarBndrs x
+
+-- -------------------------------------
+-- HsSigType type families
+type family XHsSig x
+type family XXHsSigType x
-- -------------------------------------
-- HsWildCardBndrs type families
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 76ce16948b33..7515c37fb56a 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -403,10 +403,15 @@ deriving instance Data (LHsQTyVars GhcPs)
deriving instance Data (LHsQTyVars GhcRn)
deriving instance Data (LHsQTyVars GhcTc)
--- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
-deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
-deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)
-deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)
+-- deriving instance (Data flag, DataIdLR p p) => Data (HsOuterTyVarBndrs p)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcPs)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcRn)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSigType p)
+deriving instance Data (HsSigType GhcPs)
+deriving instance Data (HsSigType GhcRn)
+deriving instance Data (HsSigType GhcTc)
-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing)
deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 1ae23c779df0..ad950883f4c5 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
@@ -26,10 +27,10 @@ module GHC.Hs.Type (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
- HsImplicitBndrs(..),
+ HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
HsWildCardBndrs(..),
HsPatSigType(..), HsPSRn(..),
- LHsSigType, LHsSigWcType, LHsWcType,
+ HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
HsContext, LHsContext, noLHsContext,
HsTyLit(..),
@@ -54,11 +55,14 @@ module GHC.Hs.Type (
mkAnonWildCardTy, pprAnonWildCard,
- mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,
- mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
+ hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
+ mkHsOuterImplicit, mkHsOuterExplicit,
+ mkHsImplicitSigType, mkHsExplicitSigType,
+ mkHsWildCardBndrs, mkHsPatSigType,
+ mkEmptyWildCardBndrs,
mkHsForAllVisTele, mkHsForAllInvisTele,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,
- isHsKindedTyVar, hsTvbAllKinded, isLHsInvisForAllTy,
+ isHsKindedTyVar, hsTvbAllKinded,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
@@ -68,12 +72,13 @@ module GHC.Hs.Type (
splitLHsSigmaTyInvis, splitLHsGadtTy,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
- ignoreParens, hsSigType, hsSigWcType, hsPatSigType,
+ ignoreParens, hsSigWcType, hsPatSigType,
hsTyKindSig,
setHsTyVarBndrFlag, hsTyVarBndrFlag,
-- Printing
- pprHsType, pprHsForAll, pprHsExplicitForAll,
+ pprHsType, pprHsForAll,
+ pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,
pprLHsContext,
hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
) where
@@ -90,6 +95,7 @@ import GHC.Types.Id ( Id )
import GHC.Types.SourceText
import GHC.Types.Name( Name, NamedThing(getName) )
import GHC.Types.Name.Reader ( RdrName )
+import GHC.Types.Var ( VarBndr )
import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) )
import GHC.Core.TyCo.Rep ( Type(..) )
@@ -162,9 +168,14 @@ The system for recording type and kind-variable binders in HsTypes
is a bit complicated. Here's how it works.
* In a HsType,
- HsForAllTy represents an /explicit, user-written/ 'forall'
+ HsForAllTy represents an /explicit, user-written/ 'forall' that
+ is nested within another HsType
e.g. forall a b. {...} or
forall a b -> {...}
+
+ Note that top-level 'forall's are represented with a
+ different AST form. See the description of HsOuterTyVarBndrs
+ below.
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
@@ -181,14 +192,20 @@ is a bit complicated. Here's how it works.
here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has
a list of LHsTyVarBndrs.
-* HsImplicitBndrs is a wrapper that gives the implicitly-quantified
- kind and type variables of the wrapped thing. It is filled in by
- the renamer. For example, if the user writes
- f :: a -> a
- the HsImplicitBinders binds the 'a' (not a HsForAllTy!).
- NB: this implicit quantification is purely lexical: we bind any
- type or kind variables that are not in scope. The type checker
- may subsequently quantify over further kind variables.
+* HsOuterTyVarBndrs is used to represent the outermost quantified type
+ variables in a type that obeys the forall-or-nothing rule. An
+ HsOuterTyVarBndrs can be one of the following:
+
+ HsOuterImplicit (implicit quantification, added by renamer)
+ f :: a -> a -- Desugars to f :: forall {a}. a -> a
+ HsOuterExplicit (explicit user quantifiation):
+ f :: forall a. a -> a
+
+ See Note [forall-or-nothing rule].
+
+* An HsSigType is an LHsType with an accompanying HsOuterTyVarBndrs that
+ represents the presence (or absence) of its outermost 'forall'.
+ See Note [Representing type signatures].
* HsWildCardBndrs is a wrapper that binds the wildcard variables
of the wrapped thing. It is filled in by the renamer
@@ -197,9 +214,9 @@ is a bit complicated. Here's how it works.
* 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
+ HsWildCardBndrs/HsOuterTyVarBndrs, they track the names of wildcard
variables and implicitly bound type variables. Unlike
- HsImplicitBndrs, however, HsSigPatTypes do not obey the
+ HsOuterTyVarBndrs, 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,
@@ -402,28 +419,71 @@ emptyLHsQTvs :: LHsQTyVars GhcRn
emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }
------------------------------------------------
--- HsImplicitBndrs
--- Used to quantify the implicit binders of a type
--- * Implicit binders of a type signature (LHsSigType/LHsSigWcType)
+-- HsOuterTyVarBndrs
+-- Used to quantify the outermost type variable binders of a type that obeys
+-- the forall-or-nothing rule. These are used to represent the outermost
+-- quantification in:
+-- * Type signatures (LHsSigType/LHsSigWcType)
-- * Patterns in a type/data family instance (HsTyPats)
+--
+-- We support two forms:
+-- HsOuterImplicit (implicit quantification, added by renamer)
+-- f :: a -> a -- Desugars to f :: forall {a}. a -> a
+-- type instance F (a,b) = a->b
+-- HsOuterExplicit (explicit user quantifiation):
+-- f :: forall a. a -> a
+-- type instance forall a b. F (a,b) = a->b
+--
+-- In constrast, when the user writes /visible/ quanitification
+-- T :: forall k -> k -> Type
+-- we use use HsOuterImplicit, wrapped around a HsForAllTy
+-- for the visible quantification
+--
+-- See Note [forall-or-nothing] rule
+
+-- | The outermost type variables in a type that obeys the @forall@-or-nothing
+-- rule. See @Note [forall-or-nothing rule]@.
+data HsOuterTyVarBndrs flag pass
+ = HsOuterImplicit -- ^ Implicit forall, e.g.,
+ -- @f :: a -> b -> b@
+ { hso_ximplicit :: XHsOuterImplicit pass
+ }
+ | HsOuterExplicit -- ^ Explicit forall, e.g.,
+ -- @f :: forall a b. a -> b -> b@
+ { hso_xexplicit :: XHsOuterExplicit pass flag
+ , hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc pass)]
+ }
+ | XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass)
--- | Haskell Implicit Binders
-data HsImplicitBndrs pass thing -- See Note [HsType binders]
- = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name]
- -- Implicitly-bound kind & type vars
- -- Order is important; see
- -- Note [Ordering of implicit variables]
- -- in GHC.Rename.HsType
+-- | Used for signatures, e.g.,
+--
+-- @
+-- f :: forall a {b}. blah
+-- @
+--
+-- We use 'Specificity' for the 'HsOuterTyVarBndrs' @flag@ to allow
+-- distinguishing between specified and inferred type variables.
+type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity
- , hsib_body :: thing -- Main payload (type or list of types)
- }
- | XHsImplicitBndrs !(XXHsImplicitBndrs pass thing)
+-- | Used for type-family instance equations, e.g.,
+--
+-- @
+-- type instance forall a. F [a] = Tree a
+-- @
+--
+-- The notion of specificity is irrelevant in type family equations, so we use
+-- @()@ for the 'HsOuterTyVarBndrs' @flag@.
+type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs ()
+
+type instance XHsOuterImplicit GhcPs = NoExtField
+type instance XHsOuterImplicit GhcRn = [Name]
+type instance XHsOuterImplicit GhcTc = [TyVar]
-type instance XHsIB GhcPs _ = NoExtField
-type instance XHsIB GhcRn _ = [Name]
-type instance XHsIB GhcTc _ = [Name]
+type instance XHsOuterExplicit GhcPs _ = NoExtField
+type instance XHsOuterExplicit GhcRn _ = NoExtField
+type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag]
-type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon
+type instance XXHsOuterTyVarBndrs (GhcPass _) = NoExtCon
-- | Haskell Wildcard Binders
data HsWildCardBndrs pass thing
@@ -475,7 +535,7 @@ type instance XHsPS GhcTc = HsPSRn
type instance XXHsPatSigType (GhcPass _) = NoExtCon
-- | Located Haskell Signature Type
-type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only
+type LHsSigType pass = Located (HsSigType pass) -- Implicit only
-- | Located Haskell Wildcard Type
type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only
@@ -483,16 +543,22 @@ type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only
-- | Located Haskell Signature Wildcard Type
type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
--- See Note [Representing type signatures]
-
-hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing
-hsImplicitBody (HsIB { hsib_body = body }) = body
+-- | A type signature that obeys the @forall@-or-nothing rule. In other
+-- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its
+-- outermost type variable quantification.
+-- See @Note [Representing type signatures]@.
+data HsSigType pass
+ = HsSig { sig_ext :: XHsSig pass
+ , sig_bndrs :: HsOuterSigTyVarBndrs pass
+ , sig_body :: LHsType pass
+ }
+ | XHsSigType !(XXHsSigType pass)
-hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
-hsSigType = hsImplicitBody
+type instance XHsSig (GhcPass _) = NoExtField
+type instance XXHsSigType (GhcPass _) = NoExtCon
hsSigWcType :: LHsSigWcType pass -> LHsType pass
-hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
+hsSigWcType = sig_body . unLoc . hswc_body
hsPatSigType :: HsPatSigType pass -> LHsType pass
hsPatSigType = hsps_body
@@ -501,24 +567,97 @@ dropWildCards :: LHsSigWcType pass -> LHsSigType pass
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = hswc_body sig_ty
-{- Note [Representing type signatures]
+{-
+Note [forall-or-nothing rule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Free variables in signatures are usually bound in an implicit 'forall' at the
+beginning of user-written signatures. However, if the signature has an
+explicit, invisible forall at the beginning, this is disabled. This is referred
+to as the forall-or-nothing rule.
+
+The idea is nested foralls express something which is only expressible
+explicitly, while a top level forall could (usually) be replaced with an
+implicit binding. Top-level foralls alone ("forall.") are therefore an
+indication that the user is trying to be fastidious, so we don't implicitly
+bind any variables.
+
+Note that this rule only applies to outermost /in/visible 'forall's, and not
+outermost visible 'forall's. See #18660 for more on this point.
+
+Here are some concrete examples to demonstrate the forall-or-nothing rule in
+action:
+
+ type F1 :: a -> b -> b -- Legal; a,b are implicitly quantified.
+ -- Equivalently: forall a b. a -> b -> b
+
+ type F2 :: forall a b. a -> b -> b -- Legal; explicitly quantified
+
+ type F3 :: forall a. a -> b -> b -- Illegal; the forall-or-nothing rule says that
+ -- if you quantify a, you must also quantify b
+
+ type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/
+ -- quantifer, so the "nothing" part of the forall-or-nothing
+ -- rule applies, and b is therefore implicitly quantified.
+ -- Equivalently: forall b. forall a -> b -> b
+
+ type F5 :: forall b. forall a -> b -> c -- Illegal; the forall-or-nothing rule says that
+ -- if you quantify b, you must also quantify c
+
+ type F6 :: forall a -> forall b. b -> c -- Legal: just like F4.
+
+For a complete list of all places where the forall-or-nothing rule applies, see
+"The `forall`-or-nothing rule" section of the GHC User's Guide.
+
+Any type that obeys the forall-or-nothing rule is represented in the AST with
+an HsOuterTyVarBndrs:
+
+* If the type has an outermost, invisible 'forall', it uses HsOuterExplicit,
+ which contains a list of the explicitly quantified type variable binders in
+ `hso_bndrs`. After typechecking, HsOuterExplicit also stores a list of the
+ explicitly quantified `InvisTVBinder`s in
+ `hso_xexplicit :: XHsOuterExplicit GhcTc`.
+
+* Otherwise, it uses HsOuterImplicit. HsOuterImplicit is used for different
+ things depending on the phase:
+
+ * After parsing, it does not store anything in particular.
+ * After renaming, it stores the implicitly bound type variable `Name`s in
+ `hso_ximplicit :: XHsOuterImplicit GhcRn`.
+ * After typechecking, it stores the implicitly bound `TyVar`s in
+ `hso_ximplicit :: XHsOuterImplicit GhcTc`.
+
+ NB: this implicit quantification is purely lexical: we bind any
+ type or kind variables that are not in scope. The type checker
+ may subsequently quantify over further kind variables.
+ See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig.
+
+HsOuterTyVarBndrs GhcTc is used in the typechecker as an intermediate data type
+for storing the outermost TyVars/InvisTVBinders in a type.
+See GHC.Tc.Gen.HsType.bindOuterTKBndrsX for an example of this.
+
+Note [Representing type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-HsSigType is used to represent an explicit user type signature
-such as f :: a -> a
- or g (x :: a -> a) = x
+HsSigType is used to represent an explicit user type signature. These are
+used in a variety of places. Some examples include:
+
+* Type signatures (e.g., f :: a -> a)
+* Standalone kind signatures (e.g., type G :: a -> a)
+* GADT constructor types (e.g., data T where MkT :: a -> T)
+
+A HsSigType is the combination of an HsOuterSigTyVarBndrs and an LHsType:
-A HsSigType is just a HsImplicitBndrs wrapping a LHsType.
- * The HsImplicitBndrs binds the /implicitly/ quantified tyvars
- * The LHsType binds the /explicitly/ quantified tyvars
+* The HsOuterSigTyVarBndrs binds the /explicitly/ quantified type variables
+ when the type signature has an outermost, user-written 'forall' (i.e,
+ the HsOuterExplicit constructor is used). If there is no outermost 'forall',
+ then it binds the /implicitly/ quantified type variables instead (i.e.,
+ the HsOuterImplicit constructor is used).
+* The LHsType represents the rest of the type.
E.g. For a signature like
- f :: forall (a::k). blah
+ f :: forall k (a::k). blah
we get
- HsIB { hsib_vars = [k]
- , 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
+ HsSig { sig_bndrs = HsOuterExplicit { hso_bndrs = [k, (a :: k)] }
+ , sig_body = blah }
Note [Pattern signature binders and scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -539,8 +678,7 @@ Consider the pattern signatures like those on `t` and `g` in:
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.
+ `b` is not explicitly bound. See Note [forall-or-nothing rule].
Similar scoping rules apply to term variable binders in RULES, like in the
following example:
@@ -584,11 +722,94 @@ 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.
+
+Note [Lexically scoped type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ScopedTypeVariables extension does two things:
+
+* It allows the use of type signatures in patterns
+ (e.g., `f (x :: a -> a) = ...`). See
+ Note [Pattern signature binders and scoping] for more on this point.
+* It brings lexically scoped type variables into scope for certain type
+ signatures with outermost invisible 'forall's.
+
+This Note concerns the latter bullet point. Per the
+"Lexically scoped type variables" section of the GHC User's Guide, the
+following forms of type signatures can have lexically scoped type variables:
+
+* In declarations with type signatures, e.g.,
+
+ f :: forall a. a -> a
+ f x = e @a
+
+ Here, the 'forall a' brings 'a' into scope over the body of 'f'.
+
+ Note that ScopedTypeVariables does /not/ interact with standalone kind
+ signatures, only type signatures.
+
+* In explicit type annotations in expressions, e.g.,
+
+ id @a :: forall a. a -> a
+
+* In instance declarations, e.g.,
+
+ instance forall a. C [a] where
+ m = e @a
+
+ Note that unlike the examples above, the use of an outermost 'forall' isn't
+ required to bring 'a' into scope. That is, the following would also work:
+
+ instance forall a. C [a] where
+ m = e @a
+
+Note that all of the types above obey the forall-or-nothing rule. As a result,
+the places in the AST that can have lexically scoped type variables are a
+subset of the places that use HsOuterTyVarBndrs
+(See Note [forall-or-nothing rule].)
+
+Some other observations about lexically scoped type variables:
+
+* Only type variables bound by an /invisible/ forall can be lexically scoped.
+ See Note [hsScopedTvs and visible foralls].
+* The lexically scoped type variables may be a strict subset of the type
+ variables brought into scope by a type signature.
+ See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig.
-}
-mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
-mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField
- , hsib_body = x }
+hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]
+hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs
+hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs
+
+hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)
+ -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
+hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
+hsOuterExplicitBndrs (HsOuterImplicit{}) = []
+
+mapHsOuterImplicit :: (XHsOuterImplicit pass -> XHsOuterImplicit pass)
+ -> HsOuterTyVarBndrs flag pass
+ -> HsOuterTyVarBndrs flag pass
+mapHsOuterImplicit f (HsOuterImplicit{hso_ximplicit = imp}) =
+ HsOuterImplicit{hso_ximplicit = f imp}
+mapHsOuterImplicit _ hso@(HsOuterExplicit{}) = hso
+mapHsOuterImplicit _ hso@(XHsOuterTyVarBndrs{}) = hso
+
+mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs
+mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}
+
+mkHsOuterExplicit :: [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
+mkHsOuterExplicit bndrs = HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = bndrs }
+
+mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs
+mkHsImplicitSigType body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = mkHsOuterImplicit, sig_body = body }
+
+mkHsExplicitSigType :: [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs
+ -> HsSigType GhcPs
+mkHsExplicitSigType bndrs body =
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = mkHsOuterExplicit bndrs, sig_body = body }
mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
@@ -598,12 +819,6 @@ 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
-mkEmptyImplicitBndrs x = HsIB { hsib_ext = []
- , hsib_body = x }
-
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
, hswc_ext = [] }
@@ -1156,30 +1371,22 @@ gives
---------------------
hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
--- Get the lexically-scoped type variables of a HsSigType
--- - the explicitly-given forall'd type variables
+-- Get the lexically-scoped type variables of an LHsSigWcType:
+-- - the explicitly-given forall'd type variables;
+-- see Note [Lexically scoped type variables]
-- - the named wildcards; see Note [Scoping of named wildcards]
-- because they scope in the same way
-hsWcScopedTvs sig_ty
- | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty
- , HsIB { hsib_ext = vars
- , hsib_body = sig_ty2 } <- sig_ty1
- = case sig_ty2 of
- L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}) ->
- -- See Note [hsScopedTvs vis_flag]
- vars ++ nwcs ++ hsLTyVarNames tvs
- _ -> nwcs
+hsWcScopedTvs sig_wc_ty
+ | HsWC { hswc_ext = nwcs, hswc_body = sig_ty } <- sig_wc_ty
+ , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty
+ = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)
+ -- See Note [hsScopedTvs and visible foralls]
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
-hsScopedTvs sig_ty
- | HsIB { hsib_ext = vars
- , hsib_body = sig_ty2 } <- sig_ty
- , L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }})
- <- sig_ty2 -- See Note [hsScopedTvs vis_flag]
- = vars ++ hsLTyVarNames tvs
- | otherwise
- = []
+hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs}))
+ = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)
+ -- See Note [hsScopedTvs and visible foralls]
{- Note [Scoping of named wildcards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1194,8 +1401,8 @@ although there is no explicit forall, the "_a" scopes over the definition.
I don't know if this is a good idea, but there it is.
-}
-{- Note [hsScopedTvs vis_flag]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [hsScopedTvs and visible foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-XScopedTypeVariables can be defined in terms of a desugaring to
-XTypeAbstractions (GHC Proposal #50):
@@ -1223,10 +1430,22 @@ 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 HsForAllInvis in hsScopedTvs:
+This design choice is reflected in the design of HsOuterSigTyVarBndrs, which are
+used in every place that ScopedTypeVariables takes effect:
- hsScopedTvs (HsForAllTy { hst_tele = HsForAllInvis { hst_bndrs = ... }
- , ... }) = ...
+ data HsOuterTyVarBndrs flag pass
+ = HsOuterImplicit { ... }
+ | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] }
+ | ...
+ type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity
+
+The HsOuterExplicit constructor is only used in type signatures with outermost,
+/invisible/ 'forall's. Any other type—including those with outermost,
+/visible/ 'forall's—will use HsOuterImplicit. Therefore, when we determine
+which type variables to bring into scope over the body of a function
+(in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in
+an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we
+do not bring any type variables into scope over the body of a function at all.
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
@@ -1235,12 +1454,13 @@ terms, such as this example:
x :: forall a -> a -> a
x = x
-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 HsForAllInvis from the start.
+Previous versions of GHC would bring `a` into scope over the body of `x` in the
+hopes that the typechecker would error out later
+(see `GHC.Tc.Validity.vdqAllowed`). However, this can wreak havoc in the
+renamer before GHC gets to that point (see #17687 for an example of this).
+Bottom line: nip problems in the bud by refraining from bringing any type
+variables in an HsOuterImplicit into scope over the body of a function, even
+if they correspond to a visible 'forall'.
-}
---------------------
@@ -1293,13 +1513,6 @@ ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
ignoreParens ty = ty
--- | Is this type headed by an invisible @forall@? This is used to determine
--- if the type variables in a type should be implicitly quantified.
--- See @Note [forall-or-nothing rule]@ in "GHC.Rename.HsType".
-isLHsInvisForAllTy :: LHsType (GhcPass p) -> Bool
-isLHsInvisForAllTy (L _ (HsForAllTy{hst_tele = HsForAllInvis{}})) = True
-isLHsInvisForAllTy _ = False
-
{-
************************************************************************
* *
@@ -1420,15 +1633,26 @@ The SrcSpan is the span of the original HsPar
-- 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 (GhcPass p)
- -> ( [LHsTyVarBndr Specificity (GhcPass p)] -- universals
- , LHsContext (GhcPass p) -- required constraints
- , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials
- , LHsContext (GhcPass p) -- provided constraints
- , LHsType (GhcPass p)) -- body type
+splitLHsPatSynTy ::
+ LHsSigType (GhcPass p)
+ -> ( [LHsTyVarBndr Specificity (NoGhcTc (GhcPass p))] -- universals
+ , LHsContext (GhcPass p) -- required constraints
+ , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials
+ , LHsContext (GhcPass p) -- provided constraints
+ , LHsType (GhcPass p)) -- body type
splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
where
- (univs, ty1) = splitLHsForAllTyInvis ty
+ split_sig_ty ::
+ LHsSigType (GhcPass p)
+ -> ([LHsTyVarBndr Specificity (NoGhcTc (GhcPass p))], LHsType (GhcPass p))
+ split_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ case outer_bndrs of
+ -- NB: Use ignoreParens here in order to be consistent with the use of
+ -- splitLHsForAllTyInvis below, which also looks through parentheses.
+ HsOuterImplicit{} -> ([], ignoreParens body)
+ HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)
+
+ (univs, ty1) = split_sig_ty ty
(reqs, ty2) = splitLHsQualTy ty1
(exis, ty3) = splitLHsForAllTyInvis ty2
(provs, ty4) = splitLHsQualTy ty3
@@ -1454,31 +1678,11 @@ splitLHsSigmaTyInvis ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
--- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
--- into its constituent parts.
--- 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!
---
--- Unlike 'splitLHsSigmaTyInvis', this function does not look through
--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").
-splitLHsSigmaTyInvis_KP ::
- LHsType (GhcPass pass)
- -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
-splitLHsSigmaTyInvis_KP ty
- | (mb_tvbs, ty1) <- splitLHsForAllTyInvis_KP ty
- , (mb_ctxt, ty2) <- splitLHsQualTy_KP ty1
- = (mb_tvbs, mb_ctxt, ty2)
-
-- | Decompose a GADT type into its constituent parts.
--- Returns @(mb_tvbs, mb_ctxt, body)@, where:
+-- Returns @(outer_bndrs, mb_ctxt, body)@, where:
--
--- * @mb_tvbs@ are @Just@ the leading @forall@s, if they are provided.
--- Otherwise, they are @Nothing@.
+-- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost
+-- type variable binders. Otherwise, they are 'HsOuterImplicit'.
--
-- * @mb_ctxt@ is @Just@ the context, if it is provided.
-- Otherwise, it is @Nothing@.
@@ -1489,9 +1693,16 @@ splitLHsSigmaTyInvis_KP ty
-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
-- "GHC.Hs.Decls" for why this is important.
splitLHsGadtTy ::
- LHsType (GhcPass pass)
- -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
-splitLHsGadtTy = splitLHsSigmaTyInvis_KP
+ LHsSigType GhcPs
+ -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)
+splitLHsGadtTy (L _ sig_ty)
+ | (outer_bndrs, rho_ty) <- split_bndrs sig_ty
+ , (mb_ctxt, tau_ty) <- splitLHsQualTy_KP rho_ty
+ = (outer_bndrs, mb_ctxt, tau_ty)
+ where
+ split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
+ split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =
+ (outer_bndrs, body_ty)
-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
-- parts. Only splits type variable binders that
@@ -1569,22 +1780,17 @@ splitLHsQualTy_KP body = (Nothing, body)
-- for why this is important.
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
-splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
- , hsib_body = inst_ty })
- | (mb_tvs, mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty
- = (itkvs ++ maybe [] hsLTyVarNames mb_tvs, fromMaybe noLHsContext mb_cxt, body_ty)
- -- Because of the forall-or-nothing rule (see Note [forall-or-nothing rule]
- -- in GHC.Rename.HsType), at least one of itkvs (the implicitly bound type
- -- variables) or mb_tvs (the explicitly bound type variables) will be
- -- empty. Still, if ScopedTypeVariables is enabled, we must bring one or
- -- the other into scope over the bodies of the instance methods, so we
- -- simply combine them into a single list.
+splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =
+ (hsOuterTyVarNames outer_bndrs, ctxt, body_ty)
+ where
+ (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty
+ ctxt = fromMaybe noLHsContext mb_cxt
-- | Decompose a type class instance type (of the form
-- @forall <tvs>. context => instance_head@) into the @instance_head@.
getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
-getLHsInstDeclHead (HsIB { hsib_body = inst_ty })
- | (_mb_tvs, _mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty
+getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))
+ | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty
= body_ty
-- | Decompose a type class instance type (of the form
@@ -1620,8 +1826,8 @@ For example, GHC will accept the following:
mempty = Identity (mempty @a)
Moreover, the type in the top of an instance declaration must obey the
-forall-or-nothing rule (see Note [forall-or-nothing rule] in
-GHC.Rename.HsType). If instance types allowed nested `forall`s, this could
+forall-or-nothing rule (see Note [forall-or-nothing rule]).
+If instance types allowed nested `forall`s, this could
result in some strange interactions. For example, consider the following:
class C a where
@@ -1793,6 +1999,10 @@ instance OutputableBndrFlag Specificity where
pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]
pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k]
+instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where
+ ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =
+ pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body
+
instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
@@ -1803,6 +2013,16 @@ instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
+instance (OutputableBndrFlag flag, OutputableBndrId p)
+ => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where
+ ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) =
+ text "HsOuterImplicit:" <+> case ghcPass @p of
+ GhcPs -> ppr imp_tvs
+ GhcRn -> ppr imp_tvs
+ GhcTc -> ppr imp_tvs
+ ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =
+ text "HsOuterExplicit:" <+> ppr exp_tvs
+
instance OutputableBndrId p
=> Outputable (HsForAllTelescope (GhcPass p)) where
ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =
@@ -1814,10 +2034,6 @@ instance (OutputableBndrId p, OutputableBndrFlag flag)
=> Outputable (HsTyVarBndr flag (GhcPass p)) where
ppr = pprTyVarBndr
-instance Outputable thing
- => Outputable (HsImplicitBndrs (GhcPass p) thing) where
- ppr (HsIB { hsib_body = ty }) = ppr ty
-
instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
@@ -1829,6 +2045,22 @@ instance OutputableBndrId p
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
+-- | Prints the explicit @forall@ in a type family equation if one is written.
+-- If there is no explicit @forall@, nothing is printed.
+pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p
+ => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc
+pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty
+pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =
+ forAllLit <+> interppSP qtvs <> dot
+
+-- | Prints the outermost @forall@ in a type signature if one is written.
+-- If there is no outermost @forall@, nothing is printed.
+pprHsOuterSigTyVarBndrs :: OutputableBndrId p
+ => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc
+pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty
+pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =
+ pprHsForAll (mkHsForAllInvisTele bndrs) noLHsContext
+
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
pprHsForAll :: forall p. OutputableBndrId p
@@ -1848,13 +2080,6 @@ pprHsForAll tele cxt
| 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)
- => Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc
-pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
-pprHsExplicitForAll Nothing = empty
-
pprLHsContext :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
pprLHsContext lctxt
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index da55ebf89e02..e530110cda2c 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -69,7 +69,7 @@ module GHC.Hs.Utils(
-- * Types
mkHsAppTy, mkHsAppKindTy,
- mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
+ hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,
nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
-- * Stmts
@@ -657,11 +657,17 @@ chunkify xs
* *
********************************************************************* -}
-mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
-mkLHsSigType ty = mkHsImplicitBndrs ty
+-- | Convert an 'LHsType' to an 'LHsSigType'.
+hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
+hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of
+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
+ , hst_body = body }
+ -> mkHsExplicitSigType bndrs body
+ _ -> mkHsImplicitSigType lty
-mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
-mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
+-- | Convert an 'LHsType' to an 'LHsSigWcType'.
+hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
+hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType
mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
-> [LSig GhcRn]
@@ -1222,8 +1228,7 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
hsDataFamInstBinders :: IsPass p
=> DataFamInstDecl (GhcPass p)
-> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
-hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_rhs = defn }}})
+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 38162298c4b2..72e4fe99c3cf 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -141,7 +141,7 @@ sigNameNoLoc _ = []
-- instanceMap.
getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
- ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+ ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc ty
-- The Names of data and type family instances have their SrcSpan's attached
-- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
-- its SrcSpan attached here:
@@ -149,12 +149,12 @@ getInstLoc = \case
-- type instance Foo Int = Bool
-- ^^^
DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
+ { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
TyFamInstD _ (TyFamInstDecl
- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
+ { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l
-- | Get all subordinate declarations inside a declaration, and their docs.
-- A subordinate declaration is something like the associate type or data
@@ -164,12 +164,12 @@ subordinates :: Map RealSrcSpan Name
-> [(Name, [(HsDocString)], Map Int (HsDocString))]
subordinates instMap decl = case decl of
InstD _ (ClsInstD _ d) -> do
- DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ DataFamInstDecl { dfid_eqn =
FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
+ , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn
- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+ InstD _ (DataFamInstD _ (DataFamInstDecl d))
-> dataSubs (feqn_rhs d)
TyClD _ d | isClassDecl d -> classSubs d
| isDataDecl d -> dataSubs (tcdDataDefn d)
@@ -205,12 +205,8 @@ subordinates instMap decl = case decl of
DctMulti _ tys -> mapMaybe extract_deriv_ty tys
extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty (HsIB{hsib_body = L l ty}) =
+ extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =
case ty of
- -- deriving (forall a. C a {- ^ Doc comment -})
- HsForAllTy{ hst_tele = HsForAllInvis{}
- , hst_body = L _ (HsDocTy _ _ doc) }
- -> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
HsDocTy _ _ doc -> Just (l, doc)
_ -> Nothing
@@ -259,10 +255,10 @@ classDecls class_ = filterDecls . collectDocs . sortLocated $ decls
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
declTypeDocs = \case
- SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty))
- SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty))
- SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty))
- ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty))
+ SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty))
+ SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty)
+ SigD _ (PatSynSig _ _ ty) -> sigTypeDocs (unLoc ty)
+ ForD _ (ForeignImport _ _ ty _) -> sigTypeDocs (unLoc ty)
TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
_ -> M.empty
@@ -289,6 +285,10 @@ typeDocs = go 0
HsDocTy _ _ doc -> M.singleton n (unLoc doc)
_ -> M.empty
+-- | Extract function argument docs from inside types.
+sigTypeDocs :: HsSigType GhcRn -> Map Int HsDocString
+sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
+
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index fef9d4c0945b..16d17fd82e70 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -360,7 +360,6 @@ get_scoped_tvs (L _ signature)
= []
get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
-get_scoped_tvs_from_sig sig
-- Collect both implicit and explicit quantified variables, since
-- the types in instance heads, as well as `via` types in DerivingVia, can
-- bring implicitly quantified type variables into scope, e.g.,
@@ -369,10 +368,8 @@ get_scoped_tvs_from_sig sig
-- m = n @a
--
-- See also Note [Scoped type variables in quotes]
- | HsIB { hsib_ext = implicit_vars
- , hsib_body = hs_ty } <- sig
- , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
- = implicit_vars ++ hsLTyVarNames explicit_vars
+get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =
+ hsOuterTyVarNames outer_bndrs
{- Notes
@@ -508,7 +505,11 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD (L loc kisig) =
case kisig of
- StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
+ StandaloneKindSig _ v ki -> do
+ MkC th_v <- lookupLOcc v
+ MkC th_ki <- repHsSigType ki
+ dec <- rep2 kiSigDName [th_v, th_ki]
+ pure (loc, dec)
-------------------------
repDataDefn :: Core TH.Name
@@ -689,27 +690,21 @@ repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst eqn1 }
repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
-repTyFamEqn (HsIB { hsib_ext = var_names
- , hsib_body = FamEqn { feqn_tycon = tc_name
- , feqn_bndrs = mb_bndrs
- , feqn_pats = tys
- , feqn_fixity = fixity
- , feqn_rhs = rhs }})
+repTyFamEqn (FamEqn { feqn_tycon = tc_name
+ , feqn_bndrs = outer_bndrs
+ , feqn_pats = tys
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName
- repTyVarBndr
- mb_bndrs
- ; tys1 <- case fixity of
+ ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
+ do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
; rhs1 <- repLTy rhs
- ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
+ ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _:HsValArg _:_) = return tys
checkTys _ = panic "repTyFamEqn:checkTys"
@@ -726,26 +721,20 @@ repTyArgs f (HsArgPar _ : as) = repTyArgs f as
repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repDataFamInstD (DataFamInstDecl { dfid_eqn =
- (HsIB { hsib_ext = var_names
- , hsib_body = FamEqn { feqn_tycon = tc_name
- , feqn_bndrs = mb_bndrs
+ FamEqn { feqn_tycon = tc_name
+ , feqn_bndrs = outer_bndrs
, feqn_pats = tys
, feqn_fixity = fixity
- , feqn_rhs = defn }})})
+ , feqn_rhs = defn }})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName
- repTyVarBndr
- mb_bndrs
- ; tys1 <- case fixity of
+ ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
+ do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
- ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
+ ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }
where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _: HsValArg _: _) = return tys
@@ -892,26 +881,28 @@ repC (L _ (ConDeclH98 { con_name = con
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
}
-repC (L _ (ConDeclGADT { con_g_ext = imp_tvs
- , con_names = cons
- , con_qvars = exp_tvs
+repC (L _ (ConDeclGADT { con_names = cons
+ , con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt
, con_g_args = args
, con_res_ty = res_ty }))
- | null imp_tvs && null exp_tvs -- No implicit or explicit variables
+ | null_outer_imp_tvs && null_outer_exp_tvs
+ -- No implicit or explicit variables
, Nothing <- mcxt -- No context
-- ==> no need for a forall
= repGadtDataCons cons args res_ty
| otherwise
- = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs ->
+ = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->
-- See Note [Don't quantify implicit type variables in quotes]
do { c' <- repGadtDataCons cons args res_ty
; ctxt' <- repMbContext mcxt
- ; if null exp_tvs && isNothing mcxt
+ ; if null_outer_exp_tvs && isNothing mcxt
then return c'
- else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
-
+ else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }
+ where
+ null_outer_imp_tvs = nullOuterImplicit outer_bndrs
+ null_outer_exp_tvs = nullOuterExplicit outer_bndrs
repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repMbContext Nothing = repContext []
@@ -962,7 +953,7 @@ repDerivClause (L _ (HsDerivingClause
DctMulti _ tys -> rep_deriv_tys tys
rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
- rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)
+ rep_deriv_tys = repListM typeTyConName repHsSigType
rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
-> MetaM ([GenSymBind], [Core (M TH.Dec)])
@@ -1014,12 +1005,19 @@ rep_sig (L loc (CompleteMatchSig _ _st cls mty))
rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
-> MetaM (Core [M TH.TyVarBndrSpec])
rep_ty_sig_tvs explicit_tvs
- = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv name } in
- repListM tyVarBndrSpecTyConName rep_in_scope_tv
+ = repListM tyVarBndrSpecTyConName repTyVarBndr
explicit_tvs
- -- NB: Don't pass any implicit type variables to repList above
- -- See Note [Don't quantify implicit type variables in quotes]
+
+-- Desugar the outer type variable binders in an 'LHsSigType', making
+-- sure not to gensym them.
+-- See Note [Scoped type variables in quotes]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn
+ -> MetaM (Core [M TH.TyVarBndrSpec])
+rep_ty_sig_outer_tvs (HsOuterImplicit{}) =
+ coreListM tyVarBndrSpecTyConName []
+rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =
+ rep_ty_sig_tvs explicit_tvs
-- Desugar a top-level type signature. Unlike 'repHsSigType', this
-- deliberately avoids gensymming the type variables.
@@ -1039,15 +1037,14 @@ rep_ty_sig mk_sig loc sig_ty nm
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig' :: LHsSigType GhcRn
-> MetaM (Core (M TH.Type))
-rep_ty_sig' sig_ty
- | HsIB { hsib_body = hs_ty } <- sig_ty
- , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
- = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs
+rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
+ | (ctxt, tau) <- splitLHsQualTy body
+ = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs
; th_ctxt <- repLContext ctxt
- ; th_ty <- repLTy ty
- ; if null explicit_tvs && null (unLoc ctxt)
- then return th_ty
- else repTForall th_explicit_tvs th_ctxt th_ty }
+ ; th_tau <- repLTy tau
+ ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)
+ then return th_tau
+ else repTForall th_explicit_tvs th_ctxt th_tau }
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1058,8 +1055,7 @@ rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-- see Note [Scoped type variables in quotes]
-- and Note [Don't quantify implicit type variables in quotes]
rep_patsyn_ty_sig loc sig_ty nm
- | HsIB { hsib_body = hs_ty } <- sig_ty
- , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
+ | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty
= do { nm1 <- lookupLOcc nm
; th_univs <- rep_ty_sig_tvs univs
; th_exis <- rep_ty_sig_tvs exis
@@ -1167,6 +1163,56 @@ rep_flag :: Specificity -> MetaM (Core TH.Specificity)
rep_flag SpecifiedSpec = rep2_nw specifiedSpecName []
rep_flag InferredSpec = rep2_nw inferredSpecName []
+addHsOuterFamEqnTyVarBinds ::
+ HsOuterFamEqnTyVarBndrs GhcRn
+ -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
+addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
+ elt_ty <- wrapName tyVarBndrUnitTyConName
+ case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} ->
+ addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
+ thing_inside $ coreNothingList elt_ty
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
+ thing_inside $ coreJustList elt_ty th_exp_bndrs
+ where
+ mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
+ , hsq_explicit = exp_tvs }
+
+addHsOuterSigTyVarBinds ::
+ HsOuterSigTyVarBndrs GhcRn
+ -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
+addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} ->
+ do th_nil <- coreListM tyVarBndrSpecTyConName []
+ addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ addHsTyVarBinds exp_bndrs thing_inside
+
+-- | If a type implicitly quantifies its outermost type variables, return
+-- 'True' if the list of implicitly bound type variables is empty. If a type
+-- explicitly quantifies its outermost type variables, always return 'True'.
+--
+-- This is used in various places to determine if a Template Haskell 'Type'
+-- should be headed by a 'ForallT' or not.
+nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
+nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs
+nullOuterImplicit (HsOuterExplicit{}) = True
+ -- Vacuously true, as there is no implicit quantification
+
+-- | If a type explicitly quantifies its outermost type variables, return
+-- 'True' if the list of explicitly bound type variables is empty. If a type
+-- implicitly quantifies its outermost type variables, always return 'True'.
+--
+-- This is used in various places to determine if a Template Haskell 'Type'
+-- should be headed by a 'ForallT' or not.
+nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
+nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
+nullOuterExplicit (HsOuterImplicit{}) = True
+ -- Vacuously true, as there is no outermost explicit quantification
+
addSimpleTyVarBinds :: [Name] -- the binders to be added
-> MetaM (Core (M a)) -- action in the ext env
-> MetaM (Core (M a))
@@ -1182,12 +1228,10 @@ addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
addHsTyVarBinds exp_tvs thing_inside
= do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
; term <- addBinds fresh_exp_names $
- do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr
- (exp_tvs `zip` fresh_exp_names)
+ do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
+ exp_tvs
; thing_inside kbs }
; wrapGenSyms fresh_exp_names term }
- where
- mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
-> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
@@ -1226,25 +1270,11 @@ addTyClTyVarBinds tvs m
-- This makes things work for family declarations
; term <- addBinds freshNames $
- do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr
+ do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
(hsQTvExplicit tvs)
; m kbs }
; wrapGenSyms freshNames term }
- where
- mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ())))
- mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv v }
-
--- Produce kinded binder constructors from the Haskell tyvar binders
---
-repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn
- -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag')))
-repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm
- = repPlainTV nm fl
-repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm
- = do { ki' <- repLTy ki
- ; repKindedTV nm fl ki' }
-- | Represent a type variable binder
repTyVarBndr :: RepTV flag flag'
@@ -1267,17 +1297,14 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
repCtxt preds
repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigType (HsIB { hsib_ext = implicit_tvs
- , hsib_body = body })
- | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body
- = addSimpleTyVarBinds implicit_tvs $
- -- See Note [Don't quantify implicit type variables in quotes]
- addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
+repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
+ | (ctxt, tau) <- splitLHsQualTy body
+ = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->
do { th_ctxt <- repLContext ctxt
- ; th_ty <- repLTy ty
- ; if null explicit_tvs && null (unLoc ctxt)
- then return th_ty
- else repTForall th_explicit_tvs th_ctxt th_ty }
+ ; th_tau <- repLTy tau
+ ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)
+ then pure th_tau
+ else repTForall th_outer_bndrs th_ctxt th_tau }
-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
@@ -2923,23 +2950,11 @@ coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
------------------- Maybe Lists ------------------
--- Lookup the name and wrap it with the m variable
-repMaybeListM :: Name -> (a -> MetaM (Core b))
- -> Maybe [a] -> MetaM (Core (Maybe [b]))
-repMaybeListM tc_name f xs = do
- elt_ty <- wrapName tc_name
- repMaybeListT elt_ty f xs
-
-
-repMaybeListT :: Type -> (a -> MetaM (Core b))
- -> Maybe [a] -> MetaM (Core (Maybe [b]))
-repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty
-repMaybeListT elt_ty f (Just args)
- = do { args1 <- mapM f args
- ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+coreJustList :: Type -> Core [a] -> Core (Maybe [a])
+coreJustList elt_ty = coreJust' (mkListTy elt_ty)
-coreNothingList :: Type -> MetaM (Core (Maybe [a]))
-coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)
+coreNothingList :: Type -> Core (Maybe [a])
+coreNothingList elt_ty = coreNothing' (mkListTy elt_ty)
------------ Literals & Variables -------------------
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index c06373eb6256..70bb33b7d008 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -512,27 +512,12 @@ This case in handled in the instance for HsPatSigType
-}
class HasLoc a where
- -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
- -- know what their implicit bindings are scoping over
+ -- ^ conveniently calculate locations for things without locations attached
loc :: a -> SrcSpan
-instance HasLoc thing => HasLoc (TScoped thing) where
- loc (TS _ a) = loc a
-
instance HasLoc thing => HasLoc (PScoped thing) where
loc (PS _ _ _ a) = loc a
-instance HasLoc (LHsQTyVars GhcRn) where
- loc (HsQTvs _ vs) = loc vs
-
-instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
- loc (HsIB _ a) = loc a
- loc _ = noSrcSpan
-
-instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
- loc (HsWC _ a) = loc a
- loc _ = noSrcSpan
-
instance HasLoc (Located a) where
loc (L l _) = l
@@ -541,9 +526,11 @@ instance HasLoc a => HasLoc [a] where
loc xs = foldl1' combineSrcSpans $ map loc xs
instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where
- loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
- loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
- [loc a, loc tvs, loc b, loc c]
+ loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of
+ HsOuterImplicit{} ->
+ foldl1' combineSrcSpans [loc a, loc b, loc c]
+ HsOuterExplicit{hso_bndrs = tvs} ->
+ foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]
instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
loc (HsValArg tm) = loc tm
@@ -1477,9 +1464,9 @@ instance (ToHie rhs, HasLoc rhs)
instance (ToHie rhs, HasLoc rhs)
=> ToHie (FamEqn GhcRn rhs) where
- toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
+ toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $
[ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
- , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+ , toHie $ TVS (ResolvedScopes []) scope outer_bndrs
, toHie pats
, toHie rhs
]
@@ -1517,7 +1504,7 @@ instance ToHie (Located (HsDerivingClause GhcRn)) where
instance ToHie (Located (DerivClauseTys GhcRn)) where
toHie (L span dct) = concatM $ makeNode dct span : case dct of
- DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]
+ DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]
DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
instance ToHie (Located (DerivStrategy GhcRn)) where
@@ -1525,7 +1512,7 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
StockStrategy -> []
AnyclassStrategy -> []
NewtypeStrategy -> []
- ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
+ ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]
instance ToHie (Located OverlapMode) where
toHie (L span _) = locOnly span
@@ -1535,11 +1522,15 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where
instance ToHie (Located (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
- ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
+ ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs
, con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->
[ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
- , concatM $ [ bindingsOnly bindings
- , toHie $ tvScopes resScope NoScope exp_vars ]
+ , case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_vars} ->
+ bindingsOnly $ map (C $ TyVarBind (mkScope outer_bndrs_loc) resScope)
+ imp_vars
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ toHie $ tvScopes resScope NoScope exp_bndrs
, toHie ctx
, toHie args
, toHie typ
@@ -1552,7 +1543,6 @@ instance ToHie (Located (ConDecl GhcRn)) where
RecConGADT x -> mkLScope x
tyScope = mkLScope typ
resScope = ResolvedScopes [ctxScope, rhsScope]
- bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars
ConDeclH98 { con_name = name, con_ex_tvs = qvars
, con_mb_cxt = ctx, con_args = dets } ->
[ toHie $ C (Decl ConDec $ getRealSpan span) name
@@ -1576,21 +1566,17 @@ instance ToHie (Located [Located (ConDeclField GhcRn)]) where
, toHie decls
]
-instance ( HasLoc thing
- , ToHie (TScoped thing)
- ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
- toHie (TS sc (HsIB ibrn a)) = concatM $
- [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsSigType GhcRn)))) where
+ toHie (TS sc (HsWC names a)) = concatM $
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
, toHie $ TS sc a
]
where span = loc a
-instance ( HasLoc thing
- , ToHie (TScoped thing)
- ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
+instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsType GhcRn)))) where
toHie (TS sc (HsWC names a)) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
- , toHie $ TS sc a
+ , toHie a
]
where span = loc a
@@ -1650,18 +1636,26 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
, toHie $ fmap (C Use) typ
]
-instance ToHie (Located (HsType GhcRn)) where
- toHie x = toHie $ TS (ResolvedScopes []) x
+instance ToHie (TScoped (Located (HsSigType GhcRn))) where
+ toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNode t span :
+ [ toHie (TVS tsc (mkScope span) bndrs)
+ , toHie body
+ ]
+
+instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where
+ toHie (TVS tsc sc bndrs) = case bndrs of
+ HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs
+ HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs
-instance ToHie (TScoped (Located (HsType GhcRn))) where
- toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
+instance ToHie (Located (HsType GhcRn)) where
+ toHie (L span t) = concatM $ makeNode t span : case t of
HsForAllTy _ tele body ->
let scope = mkScope $ getLoc body in
[ case tele of
HsForAllVis { hsf_vis_bndrs = bndrs } ->
- toHie $ tvScopes tsc scope bndrs
+ toHie $ tvScopes (ResolvedScopes []) scope bndrs
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
- toHie $ tvScopes tsc scope bndrs
+ toHie $ tvScopes (ResolvedScopes []) scope bndrs
, toHie body
]
HsQualTy _ ctx body ->
@@ -1677,7 +1671,7 @@ instance ToHie (TScoped (Located (HsType GhcRn))) where
]
HsAppKindTy _ ty ki ->
[ toHie ty
- , toHie $ TS (ResolvedScopes []) ki
+ , toHie ki
]
HsFunTy _ w a b ->
[ toHie (arrowToHsType w)
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 10727e1e17c2..fc0ad8a007d9 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1231,7 +1231,7 @@ ty_decl :: { LTyClDecl GhcPs }
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
- : 'type' sks_vars '::' ktype
+ : 'type' sks_vars '::' sigktype
{% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4)
[mj AnnType $1,mu AnnDcolon $3] }
@@ -1251,7 +1251,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
+ ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1261,7 +1261,7 @@ inst_decl :: { LInstDecl GhcPs }
(mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
-- data/newtype instance declaration
- | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
+ | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
@@ -1269,7 +1269,7 @@ inst_decl :: { LInstDecl GhcPs }
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration
- | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
+ | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
@@ -1298,7 +1298,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs }
[mj AnnNewtype $1] }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' ktype {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))
+ : 'via' sigktype {% ams (sLL $1 $> (ViaStrategy $2))
[mj AnnVia $1] }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
@@ -1361,12 +1361,12 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: 'forall' tv_bndrs '.' type '=' ktype
{% do { hintExplicitForall $1
- ; tvb <- fromSpecTyVarBndrs $2
- ; (eqn,ann) <- mkTyFamInstEqn (Just tvb) $4 $6
+ ; tvbs <- fromSpecTyVarBndrs $2
+ ; (eqn,ann) <- mkTyFamInstEqn (mkHsOuterExplicit tvbs) $4 $6
; return (sLL $1 $>
(mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
| type '=' ktype
- {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
+ {% do { (eqn,ann) <- mkTyFamInstEqn mkHsOuterImplicit $1 $3
; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
@@ -1432,14 +1432,14 @@ at_decl_inst :: { LInstDecl GhcPs }
(mj AnnType $1:$2++(fst $ unLoc $3)) }
-- data/newtype instance declaration, with optional 'instance' keyword
- | data_or_newtype opt_instance capi_ctype tycl_hdr_inst constrs maybe_derivings
+ | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6))
((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration, with optional 'instance' keyword
- | data_or_newtype opt_instance capi_ctype tycl_hdr_inst opt_kind_sig
+ | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
{% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
@@ -1490,23 +1490,23 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
}
| type { sL1 $1 (Nothing, $1) }
-tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs)) }
+datafam_inst_hdr :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) }
: 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1
>> fromSpecTyVarBndrs $2
>>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)
>> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
- , (Just $4, Just tvbs, $6)))
+ , (Just $4, mkHsOuterExplicit tvbs, $6)))
)
}
| 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1
; tvbs <- fromSpecTyVarBndrs $2
; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]
- , (Nothing, Just tvbs, $4)))
+ , (Nothing, mkHsOuterExplicit tvbs, $4)))
} }
| context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> (return (sLL $1 $>([], (Just $1, Nothing, $3))))
+ >> (return (sLL $1 $>([], (Just $1, mkHsOuterImplicit, $3))))
}
- | type { sL1 $1 ([], (Nothing, Nothing, $1)) }
+ | type { sL1 $1 ([], (Nothing, mkHsOuterImplicit, $1)) }
capi_ctype :: { Maybe (Located CType) }
@@ -1529,7 +1529,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
: 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 (hsSigType $>)
+ ; ams (sLL $1 $>
(DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4))
[mj AnnDeriving $1, mj AnnInstance $3] } }
@@ -1602,7 +1602,7 @@ where_decls :: { Located ([AddAnn]
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
- {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4))
+ {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4)
[mj AnnPattern $1, mu AnnDcolon $3] }
-----------------------------------------------------------------------------
@@ -1620,7 +1620,7 @@ decl_cls : at_decl_cls { $1 }
do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType $4)
+ ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $4)
[mj AnnDefault $1,mu AnnDcolon $3] } }
decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1941,9 +1941,9 @@ fspec :: { Located ([AddAnn]
,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }
: STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3]
,(L (getLoc $1)
- (getStringLiteral $1), $2, mkLHsSigType $4)) }
+ (getStringLiteral $1), $2, $4)) }
| var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2]
- ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
+ ,(noLoc (StringLiteral NoSourceText nilFS), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
@@ -1953,14 +1953,26 @@ fspec :: { Located ([AddAnn]
opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
: {- empty -} { ([],Nothing) }
- | '::' sigtype { ([mu AnnDcolon $1],Just $2) }
+ | '::' ctype { ([mu AnnDcolon $1],Just $2) }
opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
: {- empty -} { ([], Nothing) }
| '::' gtycon { ([mu AnnDcolon $1], Just $2) }
-sigtype :: { LHsType GhcPs }
- : ctype { $1 }
+-- Like ktype, but for types that obey the forall-or-nothing rule.
+-- See Note [forall-or-nothing rule] in GHC.Hs.Type.
+sigktype :: { LHsSigType GhcPs }
+ : sigtype { $1 }
+ | ctype '::' kind {% ams (sLL $1 $> $ mkHsImplicitSigType $
+ sLL $1 $> $ HsKindSig noExtField $1 $3)
+ [mu AnnDcolon $2] }
+
+-- Like ctype, but for types that obey the forall-or-nothing rule.
+-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the
+-- logic in ctype here, we simply reuse the ctype production and perform
+-- surgery on the LHsType it returns to turn it into an LHsSigType.
+sigtype :: { LHsSigType GhcPs }
+ : ctype { hsTypeToHsSigType $1 }
sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
: sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1)
@@ -1969,9 +1981,9 @@ sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
| var { sL1 $1 [$1] }
sigtypes1 :: { (OrdList (LHsSigType GhcPs)) }
- : sigtype { unitOL (mkLHsSigType $1) }
+ : sigtype { unitOL $1 }
| sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return (unitOL (mkLHsSigType $1) `appOL` $3) }
+ >> return (unitOL $1 `appOL` $3) }
-----------------------------------------------------------------------------
-- Types
@@ -1996,7 +2008,6 @@ ktype :: { LHsType GhcPs }
: ctype { $1 }
| ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3)
[mu AnnDcolon $2] }
-
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
: forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in
@@ -2162,13 +2173,13 @@ atype :: { LHsType GhcPs }
-- e.g. (Foo a, Gaz b) => Wibble a b
-- It's kept as a single type for convenience.
inst_type :: { LHsSigType GhcPs }
- : sigtype { mkLHsSigType $1 }
+ : sigtype { $1 }
deriv_types :: { [LHsSigType GhcPs] }
- : ktype { [mkLHsSigType $1] }
+ : sigktype { [$1] }
- | ktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return (mkLHsSigType $1 : $3) }
+ | sigktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2)
+ >> return ($1 : $3) }
comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty
: comma_types1 { $1 }
@@ -2381,8 +2392,9 @@ deriving :: { LHsDerivingClause GhcPs }
[mj AnnDeriving $1] }
deriv_clause_types :: { LDerivClauseTys GhcPs }
- : qtycon { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in
- sL1 $1 (DctSingle noExtField (mkLHsSigType tc)) }
+ : qtycon { let { tc = sL1 $1 $ mkHsImplicitSigType $
+ sL1 $1 $ HsTyVar noExtField NotPromoted $1 } in
+ sL1 $1 (DctSingle noExtField tc) }
| '(' ')' {% ams (sLL $1 $> (DctMulti noExtField []))
[mop $1,mcp $2] }
| '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2))
@@ -2466,11 +2478,11 @@ sigdecl :: { LHsDecl GhcPs }
; v <- checkValSigLhs $1
; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
; return (sLL $1 $> $ SigD noExtField $
- TypeSig noExtField [v] (mkLHsSigWcType $3))} }
+ TypeSig noExtField [v] (mkHsWildCardBndrs $3))} }
| var ',' sig_vars '::' sigtype
{% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3))
- (mkLHsSigWcType $5)
+ (mkHsWildCardBndrs $5)
; addAnnotation (gl $1) AnnComma (gl $2)
; ams ( sLL $1 $> $ SigD noExtField sig )
[mu AnnDcolon $4] } }
@@ -2556,7 +2568,7 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }
exp :: { ECP }
- : infixexp '::' sigtype
+ : infixexp '::' ctype
{ ECP $
unECP $1 >>= \ $1 ->
rejectPragmaPV $1 >>
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index e95abd65973f..1b4151cfb757 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -24,7 +24,7 @@ module GHC.Parser.PostProcess (
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
- mkFamDecl, mkLHsSigType,
+ mkFamDecl,
mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -250,12 +250,12 @@ mkTySynonym loc lhs rhs
mkStandaloneKindSig
:: SrcSpan
-> Located [Located RdrName] -- LHS
- -> LHsKind GhcPs -- RHS
+ -> LHsSigType GhcPs -- RHS
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
- ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
+ ; return $ L loc $ StandaloneKindSig noExtField v rhs }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
@@ -267,25 +267,24 @@ mkStandaloneKindSig loc lhs rhs =
[v] -> return v
_ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)
-mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]
+mkTyFamInstEqn :: HsOuterFamEqnTyVarBndrs GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn bndrs lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (mkHsImplicitBndrs
- (FamEqn { feqn_ext = noExtField
- , feqn_tycon = tc
- , feqn_bndrs = bndrs
- , feqn_pats = tparams
- , feqn_fixity = fixity
- , feqn_rhs = rhs }),
+ ; return (FamEqn { feqn_ext = noExtField
+ , feqn_tycon = tc
+ , feqn_bndrs = bndrs
+ , feqn_pats = tparams
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs },
ann) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe (Located CType)
- -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs]
+ -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
@@ -296,13 +295,13 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
+ ; return (L loc (DataFamInstD noExtField (DataFamInstDecl
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
- , feqn_rhs = defn }))))) }
+ , feqn_rhs = defn })))) }
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
@@ -631,7 +630,7 @@ mkConDeclH98 name mb_forall mb_cxt args
-- records whether this is a prefix or record GADT constructor. See
-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.
mkGadtDecl :: [Located RdrName]
- -> LHsType GhcPs
+ -> LHsSigType GhcPs
-> P (ConDecl GhcPs, [AddAnn])
mkGadtDecl names ty = do
let (args, res_ty, anns)
@@ -643,15 +642,14 @@ mkGadtDecl names ty = do
pure ( ConDeclGADT { con_g_ext = noExtField
, con_names = names
- , con_forall = L (getLoc ty) $ isJust mtvs
- , con_qvars = fromMaybe [] mtvs
+ , con_bndrs = L (getLoc ty) outer_bndrs
, con_mb_cxt = mcxt
, con_g_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns )
where
- (mtvs, mcxt, body_ty) = splitLHsGadtTy ty
+ (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
@@ -1479,7 +1477,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
mkHsWildCardPV l = return $ L l hsHoleExpr
- mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
+ mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig))
mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
mkHsRecordPV l lrec a (fbinds, ddLoc) = do
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 0837cac70e89..21f74a878e8b 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -519,15 +519,14 @@ instance HasHaddock (HsDecl GhcPs) where
, DataFamInstDecl { dfid_eqn } <- dfid_inst
= do
dfid_eqn' <- case dfid_eqn of
- HsIB _ (FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs })
+ FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }
-> do
registerHdkA feqn_tycon
feqn_rhs' <- addHaddock feqn_rhs
- pure $
- HsIB noExtField (FamEqn {
+ pure $ FamEqn {
feqn_ext = noExtField,
feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity,
- feqn_rhs = feqn_rhs' })
+ feqn_rhs = feqn_rhs' }
pure $ InstD noExtField (DataFamInstD {
dfid_ext = noExtField,
dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } })
@@ -690,7 +689,7 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
addHaddock (L l_con_decl con_decl) =
extendHdkA l_con_decl $
case con_decl of
- ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_g_args, con_res_ty } -> do
+ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names))
con_g_args' <-
@@ -702,7 +701,7 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
pure $ RecConGADT (L l_rec flds')
con_res_ty' <- addHaddock con_res_ty
pure $ L l_con_decl $
- ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt,
+ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,
con_doc = con_doc',
con_g_args = con_g_args',
con_res_ty = con_res_ty' }
@@ -931,8 +930,15 @@ instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
-instance HasHaddock a => HasHaddock (HsImplicitBndrs GhcPs a) where
- addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t
+instance HasHaddock (Located (HsSigType GhcPs)) where
+ addHaddock (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ extendHdkA l $ do
+ case outer_bndrs of
+ HsOuterImplicit{} -> pure ()
+ HsOuterExplicit{hso_bndrs = bndrs} ->
+ registerLocHdkA (getLHsTyVarBndrsLoc bndrs)
+ body' <- addHaddock body
+ pure $ L l $ HsSig noExtField outer_bndrs body'
-- Process a type, adding documentation comments to function arguments
-- and the result. Many formatting styles are supported.
@@ -1465,10 +1471,12 @@ mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc)
getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc tele =
- foldr combineSrcSpans noSrcSpan $
case tele of
- HsForAllVis{ hsf_vis_bndrs } -> map getLoc hsf_vis_bndrs
- HsForAllInvis { hsf_invis_bndrs } -> map getLoc hsf_invis_bndrs
+ HsForAllVis{ hsf_vis_bndrs } -> getLHsTyVarBndrsLoc hsf_vis_bndrs
+ HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs
+
+getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan
+getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLoc bndrs
-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back
-- into a flat list. Elements are put back into the order in which they
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index ac92e300b59d..cd5d431ee1a6 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -12,7 +12,7 @@ module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnHsWcType,
- HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
+ HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
@@ -24,15 +24,15 @@ module GHC.Rename.HsType (
checkPrecMatch, checkSectionPrec,
-- Binding related stuff
- bindHsForAllTelescope,
+ bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
- extractHsTvBndrs, extractHsTyArgRdrKiTyVars,
- forAllOrNothing, nubL
+ extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
+ nubL
) where
import GHC.Prelude
@@ -82,7 +82,7 @@ to break several loops.
*********************************************************
-}
-data HsSigWcTypeScoping
+data HsPatSigTypeScoping
= AlwaysBind
-- ^ Always bind any free tyvars of the given type, regardless of whether we
-- have a forall at the top.
@@ -103,10 +103,6 @@ data HsSigWcTypeScoping
-- 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.Type".
- | BindUnlessForall
- -- ^ 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. This is used for RULES that have both
-- explicit type and term variable binders, e.g.:
@@ -124,13 +120,19 @@ data HsSigWcTypeScoping
rnHsSigWcType :: HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, 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
+rnHsSigWcType doc (HsWC { hswc_body =
+ sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) })
+ = do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty)
+ ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars
+ ; let nwc_rdrs = nubL nwc_rdrs'
+ ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' ->
+ do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty
+ ; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs', sig_body = body_ty' }}
+ , fvs) } }
+
+rnHsPatSigType :: HsPatSigTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
@@ -145,33 +147,20 @@ rnHsPatSigType :: HsSigWcTypeScoping
rnHsPatSigType scoping ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; 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 scoping ctxt hs_ty thing_inside
- = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)
+ ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty)
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
- ; implicit_bndrs <- case scoping of
- AlwaysBind -> pure tv_rdrs
- BindUnlessForall -> forAllOrNothing (isLHsInvisForAllTy hs_ty) tv_rdrs
- NeverBind -> pure []
- ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars ->
- do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; (res, fvs2) <- thing_inside wcs vars hs_ty'
+ implicit_bndrs = case scoping of
+ AlwaysBind -> tv_rdrs
+ NeverBind -> []
+ ; rnImplicitBndrs Nothing implicit_bndrs $ \ imp_tvs ->
+ do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty
+ ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
+ sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' }
+ ; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
+ where
+ pat_sig_ty = hsPatSigType sig_ty
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
@@ -306,7 +295,7 @@ of the HsWildCardBndrs structure, and we are done.
*********************************************************
* *
- HsSigtype (i.e. no wildcards)
+ HsSigType (i.e. no wildcards)
* *
****************************************************** -}
@@ -316,76 +305,22 @@ rnHsSigType :: HsDocContext
-> RnM (LHsSigType GhcRn, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
-rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
- = do { traceRn "rnHsSigType" (ppr hs_ty)
- ; rdr_env <- getLocalRdrEnv
- ; vars0 <- forAllOrNothing (isLHsInvisForAllTy hs_ty)
- $ filterInScope rdr_env
- $ extractHsTyRdrTyVars hs_ty
- ; rnImplicitBndrs Nothing vars0 $ \ vars ->
- do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty
-
- ; return ( HsIB { hsib_ext = vars
- , hsib_body = body' }
+rnHsSigType ctx level
+ (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
+ = setSrcSpan loc $
+ do { traceRn "rnHsSigType" (ppr sig_ty)
+ ; case outer_bndrs of
+ HsOuterExplicit{} -> checkPolyKinds env sig_ty
+ HsOuterImplicit{} -> pure ()
+ ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body
+ ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' ->
+ do { (body', fvs) <- rnLHsTyKi env body
+
+ ; return ( L loc $ HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs', sig_body = body' }
, fvs ) } }
-
-{-
-Note [forall-or-nothing rule]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Free variables in signatures are usually bound in an implicit 'forall' at the
-beginning of user-written signatures. However, if the signature has an
-explicit, invisible forall at the beginning, this is disabled.
-
-The idea is nested foralls express something which is only expressible
-explicitly, while a top level forall could (usually) be replaced with an
-implicit binding. Top-level foralls alone ("forall.") are therefore an
-indication that the user is trying to be fastidious, so we don't implicitly
-bind any variables.
-
-Note that this rule only applies to outermost /in/visible 'forall's, and not
-outermost visible 'forall's. See #18660 for more on this point.
-
-Here are some concrete examples to demonstrate the forall-or-nothing rule in
-action:
-
- type F1 :: a -> b -> b -- Legal; a,b are implicitly quantified.
- -- Equivalently: forall a b. a -> b -> b
-
- type F2 :: forall a b. a -> b -> b -- Legal; explicitly quantified
-
- type F3 :: forall a. a -> b -> b -- Illegal; the forall-or-nothing rule says that
- -- if you quantify a, you must also quantify b
-
- type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/
- -- quantifer, so the "nothing" part of the forall-or-nothing
- -- rule applies, and b is therefore implicitly quantified.
- -- Equivalently: forall b. forall a -> b -> b
-
- type F5 :: forall b. forall a -> b -> c -- Illegal; the forall-or-nothing rule says that
- -- if you quantify b, you must also quantify c
-
- type F6 :: forall a -> forall b. b -> c -- Legal: just like F4.
--}
-
--- | 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
- -- we do not want to bring 'b' into scope, hence True
- -- But f :: a -> b
- -- we want to bring both 'a' and 'b' into scope, hence False
- -> FreeKiTyVars
- -- ^ Free vars of the type
- -> RnM FreeKiTyVars
-forAllOrNothing has_outer_forall fvs = case has_outer_forall of
- True -> do
- traceRn "forAllOrNothing" $ text "has explicit outer forall"
- pure []
- False -> do
- traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs
- pure fvs
+ where
+ env = mkTyKiEnv ctx level RnTypeBody
rnImplicitBndrs :: Maybe assoc
-- ^ @'Just' _@ => an associated type decl
@@ -1053,6 +988,28 @@ an LHsQTyVars can be semantically significant. As a result, we suppress
-Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
-}
+bindHsOuterTyVarBndrs :: OutputableBndrFlag flag
+ => HsDocContext
+ -> Maybe assoc
+ -- ^ @'Just' _@ => an associated type decl
+ -> FreeKiTyVars
+ -> HsOuterTyVarBndrs flag GhcPs
+ -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
+ case outer_bndrs of
+ HsOuterImplicit{} ->
+ rnImplicitBndrs mb_cls implicit_vars $ \implicit_vars' ->
+ thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ -- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs
+ -- will use class variables for any names the user meant to bring in
+ -- scope here. This is an explicit forall, so we want fresh names, not
+ -- class variables. Thus: always pass Nothing.
+ bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->
+ thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
+ , hso_bndrs = exp_bndrs' }
+
bindHsForAllTelescope :: HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
@@ -1859,6 +1816,10 @@ extract_lty (L _ ty) acc
-- We deal with these separately in rnLHsTypeWithWildCards
HsWildCardTy {} -> acc
+extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
+extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ extractHsOuterTvBndrs outer_bndrs $ extract_lty body []
+
extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
FreeKiTyVars
extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc
@@ -1875,11 +1836,13 @@ extract_hs_for_all_telescope tele acc_vars body_fvs =
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
extract_hs_tv_bndrs bndrs acc_vars body_fvs
-extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]
- -> FreeKiTyVars -- Free in body
- -> FreeKiTyVars -- Free in result
-extractHsTvBndrs tv_bndrs body_fvs
- = extract_hs_tv_bndrs tv_bndrs [] body_fvs
+extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs
+ -> FreeKiTyVars -- Free in body
+ -> FreeKiTyVars -- Free in result
+extractHsOuterTvBndrs outer_bndrs body_fvs =
+ case outer_bndrs of
+ HsOuterImplicit{} -> body_fvs
+ HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs
extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -- Accumulator
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index d535f008ae4d..e0deda3b1d49 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -73,7 +73,7 @@ import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
-import Data.Maybe ( isNothing, isJust, fromMaybe, mapMaybe )
+import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
import Data.Function ( on )
@@ -658,25 +658,25 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
addErrAt l $ withHsDocContext ctxt err_msg
pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
-rnFamInstEqn :: HsDocContext
- -> AssocTyFamInfo
- -> FreeKiTyVars
- -- ^ Kind variables from the equation's RHS to be implicitly bound
- -- if no explicit forall.
- -> FamInstEqn GhcPs rhs
- -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
- -> RnM (FamInstEqn GhcRn rhs', FreeVars)
-rnFamInstEqn doc atfi rhs_kvars
- (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
- , feqn_bndrs = mb_bndrs
- , feqn_pats = pats
- , feqn_fixity = fixity
- , feqn_rhs = payload }}) rn_payload
+rnFamEqn :: HsDocContext
+ -> AssocTyFamInfo
+ -> FreeKiTyVars
+ -- ^ Kind variables from the equation's RHS to be implicitly bound
+ -- if no explicit forall.
+ -> FamEqn GhcPs rhs
+ -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+ -> RnM (FamEqn GhcRn rhs', FreeVars)
+rnFamEqn doc atfi rhs_kvars
+ (FamEqn { feqn_tycon = tycon
+ , feqn_bndrs = outer_bndrs
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = payload }) rn_payload
= do { tycon' <- lookupFamInstName mb_cls tycon
-- all_imp_vars represent the implicitly bound type variables. This is
-- empty if we have an explicit `forall` (see
- -- Note [forall-or-nothing rule] in GHC.Rename.HsType), which means
+ -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means
-- ignoring:
--
-- - pat_kity_vars_with_dups, the variables mentioned in the LHS of
@@ -696,31 +696,22 @@ rnFamInstEqn doc atfi rhs_kvars
-- type instance F [(a, b)] c = a -> b -> c
-- -- all_imp_vars = [a, b, c]
-- @
- ; all_imp_vars <- forAllOrNothing (isJust mb_bndrs) $
- -- No need to filter out explicit binders (the 'mb_bndrs = Just
- -- explicit_bndrs' case) because there must be none if we're going
- -- to implicitly bind anything, per the previous comment.
- pat_kity_vars_with_dups ++ rhs_kvars
-
- ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' ->
- bindLHsTyVarBndrs doc WarnUnusedForalls
- Nothing (fromMaybe [] mb_bndrs) $ \bndrs' ->
- -- Note: If we pass mb_cls instead of Nothing here,
- -- bindLHsTyVarBndrs will use class variables for any names
- -- the user meant to bring in scope here. This is an explicit
- -- forall, so we want fresh names, not class variables.
- -- Thus: always pass Nothing
+ ; let all_imp_vars = pat_kity_vars_with_dups ++ rhs_kvars
+
+ ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
; (payload', rhs_fvs) <- rn_payload doc payload
-- Report unused binders on the LHS
-- See Note [Unused type variables in family instances]
- ; let -- The SrcSpan that rnImplicitBndrs will attach to each Name will
+ ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each
+ -- implicitly bound type variable Name in outer_bndrs' will
-- span the entire type family instance, which will be reflected in
-- -Wunused-type-patterns warnings. We can be a little more precise
-- than that by pointing to the LHS of the instance instead, which
-- is what lhs_loc corresponds to.
- all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names'
+ rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc))
+ rn_outer_bndrs
groups :: [NonEmpty (Located RdrName)]
groups = equivClasses cmpLocated $
@@ -735,7 +726,7 @@ rnFamInstEqn doc atfi rhs_kvars
-- Note [Unused type variables in family instances]
; let nms_used = extendNameSetList rhs_fvs $
inst_tvs ++ nms_dups
- all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
+ all_nms = hsOuterTyVarNames rn_outer_bndrs'
; warnUnusedTypePatterns all_nms nms_used
; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
@@ -745,14 +736,13 @@ rnFamInstEqn doc atfi rhs_kvars
-> eqn_fvs
_ -> eqn_fvs `addOneFV` unLoc tycon'
- ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
- , hsib_body
- = FamEqn { feqn_ext = noExtField
- , feqn_tycon = tycon'
- , feqn_bndrs = bndrs' <$ mb_bndrs
- , feqn_pats = pats'
- , feqn_fixity = fixity
- , feqn_rhs = payload' } },
+ ; return (FamEqn { feqn_ext = noExtField
+ , feqn_tycon = tycon'
+ -- Note [Wildcards in family instances]
+ , feqn_bndrs = rn_outer_bndrs'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = payload' },
all_fvs) } }
where
-- The parent class, if we are dealing with an associated type family
@@ -780,7 +770,7 @@ rnFamInstEqn doc atfi rhs_kvars
-- type instance F a b c = Either a b
-- ^^^^^
lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc rhs_kvars of
- [] -> panic "rnFamInstEqn.lhs_loc"
+ [] -> panic "rnFamEqn.lhs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
@@ -838,10 +828,8 @@ data ClosedTyFamInfo
rnTyFamInstEqn :: AssocTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn atfi
- eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
- , feqn_rhs = rhs }})
- = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
+rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs })
+ = rnFamEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
where
rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
@@ -853,12 +841,12 @@ rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
- FamEqn { feqn_tycon = tycon
- , feqn_rhs = rhs }})})
+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
+ eqn@(FamEqn { feqn_tycon = tycon
+ , feqn_rhs = rhs })})
= do { let rhs_kvs = extractDataDefnKindVars rhs
; (eqn', fvs) <-
- rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
+ rnFamEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-- Renaming of the associated types in instances.
@@ -1065,7 +1053,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
where
ctxt = DerivDeclCtx
inf_err = Just (text "Inferred type variables are not allowed")
- loc = getLoc $ hsib_body nowc_ty
+ loc = getLoc nowc_ty
nowc_ty = dropWildCards ty
standaloneDerivErr :: SDoc
@@ -1931,17 +1919,15 @@ rnLDerivStrategy doc mds thing_inside
ViaStrategy via_ty ->
do checkInferredVars doc inf_err via_ty
(via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
- let HsIB { hsib_ext = via_imp_tvs
- , hsib_body = via_body } = via_ty'
- (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body
- via_exp_tvs = maybe [] hsLTyVarNames via_exp_tv_bndrs
- via_tvs = via_imp_tvs ++ via_exp_tvs
+ let HsSig { sig_bndrs = via_outer_bndrs
+ , sig_body = via_body } = unLoc via_ty'
+ via_tvs = hsOuterTyVarNames via_outer_bndrs
-- Check if there are any nested `forall`s, which are illegal in a
-- `via` type.
-- See Note [No nested foralls or contexts in instance types]
-- (Wrinkle: Derived instances) in GHC.Hs.Type.
addNoNestedForallsContextsErr doc
- (quotes (text "via") <+> text "type") via_rho
+ (quotes (text "via") <+> text "type") via_body
(thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
@@ -2194,32 +2180,29 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_forall = forall }, -- Remove when #18311 is fixed
all_fvs) }}
-rnConDecl decl@(ConDeclGADT { con_names = names
- , con_forall = forall@(L _ explicit_forall)
- , con_qvars = explicit_tkvs
- , con_mb_cxt = mcxt
- , con_g_args = args
- , con_res_ty = res_ty
- , con_doc = mb_doc })
+rnConDecl (ConDeclGADT { con_names = names
+ , con_bndrs = L l outer_bndrs
+ , con_mb_cxt = mcxt
+ , con_g_args = args
+ , con_res_ty = res_ty
+ , con_doc = mb_doc })
= do { mapM_ (addLocM checkConName) names
; new_names <- mapM lookupLocatedTopBndrRn names
- -- We must ensure that we extract the free tkvs in left-to-right
- -- order of their appearance in the constructor type.
- -- That order governs the order the implicitly-quantified type
- -- variable, and hence the order needed for visible type application
- -- See #14808.
- ; implicit_bndrs <- forAllOrNothing explicit_forall
- $ extractHsTvBndrs explicit_tkvs
- $ extractHsTysRdrTyVars (hsConDeclTheta mcxt)
- $ extractConDeclGADTDetailsTyVars args
- $ extractHsTyRdrTyVars res_ty
+ ; let -- We must ensure that we extract the free tkvs in left-to-right
+ -- order of their appearance in the constructor type.
+ -- That order governs the order the implicitly-quantified type
+ -- variable, and hence the order needed for visible type application
+ -- See #14808.
+ implicit_bndrs =
+ extractHsOuterTvBndrs outer_bndrs $
+ extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
+ extractConDeclGADTDetailsTyVars args $
+ extractHsTysRdrTyVars [res_ty] []
; let ctxt = ConDeclCtx new_names
- ; rnImplicitBndrs Nothing implicit_bndrs $ \ implicit_tkvs ->
- bindLHsTyVarBndrs ctxt WarnUnusedForalls
- Nothing explicit_tkvs $ \ explicit_tkvs ->
+ ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
@@ -2233,12 +2216,11 @@ rnConDecl decl@(ConDeclGADT { con_names = names
; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
; traceRn "rnConDecl (ConDeclGADT)"
- (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
- ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names
- , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
- , con_g_args = new_args, con_res_ty = new_res_ty
- , con_doc = mb_doc
- , con_forall = forall }, -- Remove when #18311 is fixed
+ (ppr names $$ ppr outer_bndrs')
+ ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names
+ , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt
+ , con_g_args = new_args, con_res_ty = new_res_ty
+ , con_doc = mb_doc },
all_fvs) } }
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index cde4fe6d4a79..45b8bcd3134d 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -830,8 +830,7 @@ getLocalNonValBinders fixity_env
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
- new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
- HsIB { hsib_body = ti_decl }})
+ new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
= do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let (bndrs, flds) = hsDataFamInstBinders dfid
; sub_names <- mapM newTopSrcBinder bndrs
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 68d453a68fbf..2e93ad882d53 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -194,17 +194,14 @@ checkInferredVars :: HsDocContext
-> RnM ()
checkInferredVars _ Nothing _ = return ()
checkInferredVars ctxt (Just msg) ty =
- let bndrs = forallty_bndrs (hsSigType ty)
+ let bndrs = sig_ty_bndrs ty
in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of
Nothing -> return ()
Just _ -> addErr $ withHsDocContext ctxt msg
where
- forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
- forallty_bndrs (L _ ty) = case ty of
- HsParTy _ ty' -> forallty_bndrs ty'
- HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}
- -> map unLoc tvs
- _ -> []
+ sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
+ sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))
+ = map unLoc (hsOuterExplicitBndrs outer_bndrs)
{-
Note [Unobservably inferred type variables]
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 9e9adbb9612d..407cb6a21be4 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -500,7 +500,7 @@ derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =
-- We carefully set up uses of recoverM to minimize error message
-- cascades. See Note [Recovering from failures in deriving clauses].
recoverM (pure Nothing) $
- setSrcSpan (getLoc (hsSigType deriv_pred)) $ do
+ setSrcSpan (getLoc deriv_pred) $ do
traceTc "derivePred" $ vcat
[ text "tc" <+> ppr tc
, text "tys" <+> ppr tys
@@ -718,18 +718,15 @@ tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType ctxt
- (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
- , hsib_body = deriv_ty_body })})
- | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body
+ (HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs
+ , sig_body = deriv_ty_body }))})
+ | (theta, rho) <- splitLHsQualTy deriv_ty_body
, L _ [wc_pred] <- theta
, L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
- = do dfun_ty <- tcHsClsInstType ctxt $
- HsIB { hsib_ext = vars
- , hsib_body
- = L (getLoc deriv_ty_body) $
- HsForAllTy { hst_tele = mkHsForAllInvisTele tvs
- , hst_xforall = noExtField
- , hst_body = rho }}
+ = do dfun_ty <- tcHsClsInstType ctxt $ L loc $
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_body = rho }
let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, InferContext (Just wc_span), cls, inst_tys)
| otherwise
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 33c0765c69e9..a2ba8d1dbb54 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -596,7 +596,9 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-- mean more tests (dynamically)
nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
where
- ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR
+ ascribeBool e = noLoc $ ExprWithTySig noExtField e
+ $ mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType
+ $ nlHsTyVar boolTyCon_RDR
nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
@@ -1890,7 +1892,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
--
-- op :: forall c. a -> [T x] -> c -> Int
L loc $ ClassOpSig noExtField False [loc_meth_RDR]
- $ mkLHsSigType $ nlHsCoreTy to_ty
+ $ L loc $ mkHsImplicitSigType $ nlHsCoreTy to_ty
)
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
@@ -1948,11 +1950,6 @@ nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)
where
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
-nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty
- where
- hs_ty = mkLHsSigWcType s
-
nlHsCoreTy :: Type -> LHsType GhcPs
nlHsCoreTy = noLoc . XHsType . NHsCoreTy
@@ -2082,19 +2079,21 @@ genAuxBindSpecDup loc original_rdr_name dup_spec
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivCon2Tag tycon _
- -> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
+ -> mk_sig $ L loc $ XHsType $ NHsCoreTy $
mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
mkParentType tycon `mkVisFunTyMany` intPrimTy
DerivTag2Con tycon _
- -> mkLHsSigWcType $ L loc $
+ -> mk_sig $ L loc $
XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkVisFunTyMany` mkParentType tycon
DerivMaxTag _ _
- -> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
+ -> mk_sig (L loc (XHsType (NHsCoreTy intTy)))
DerivDataDataType _ _ _
- -> mkLHsSigWcType (nlHsTyVar dataType_RDR)
+ -> mk_sig (nlHsTyVar dataType_RDR)
DerivDataConstr _ _ _
- -> mkLHsSigWcType (nlHsTyVar constr_RDR)
+ -> mk_sig (nlHsTyVar constr_RDR)
+ where
+ mk_sig = mkHsWildCardBndrs . L loc . mkHsImplicitSigType
type SeparateBagsDerivStuff =
-- DerivAuxBinds
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 8b50d5e7196b..37dc095f71a3 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -438,8 +438,13 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs
where
tcl_env = ic_env implic
insoluble = isInsolubleStatus status
- (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
- info' = tidySkolemInfo env1 info
+ (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $
+ scopedSort tvs
+ -- scopedSort: the ic_skols may not be in dependency order
+ -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)
+ -- but tidying goes wrong on out-of-order constraints;
+ -- so we sort them here before tidying
+ info' = tidySkolemInfo env1 info
implic' = implic { ic_skols = tvs'
, ic_given = map (tidyEvVar env1) given
, ic_info = info' }
@@ -507,7 +512,7 @@ warnRedundantConstraints ctxt env info ev_vars
= any isImprovementPred (pred : transSuperClasses pred)
reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM ()
-reportBadTelescope ctxt env (ForAllSkol _ telescope) skols
+reportBadTelescope ctxt env (ForAllSkol telescope) skols
= do { msg <- mkErrorReport ctxt env (important doc)
; reportError msg }
where
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 97d997897fc7..e1077b883aa3 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -1659,7 +1659,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
= [ null theta
| TcIdSig (PartialSig { psig_hs_ty = hs_ty })
<- mapMaybe sig_fn (collectHsBindListBinders lbinds)
- , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]
+ , let (L _ theta, _) = splitLHsQualTy (hsSigWcType hs_ty) ]
has_partial_sigs = not (null partial_sig_mrs)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 783e4b377347..524d97077d86 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -632,7 +632,7 @@ tcExprWithSig expr hs_ty
; (expr', poly_ty) <- tcExprSig expr sig_info
; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
where
- loc = getLoc (hsSigWcType hs_ty)
+ loc = getLoc (dropWildCards hs_ty)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 889923743c95..685a1bc81541 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -29,7 +29,12 @@ module GHC.Tc.Gen.HsType (
bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
- ContextKind(..),
+
+ bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv,
+ tcOuterTKBndrs, scopedSortOuter,
+ bindOuterSigTKBndrs_Tv,
+ tcExplicitTKBndrs,
+ bindNamedWildCardBinders,
-- Type checking type and class decls, and instances thereof
bindTyClTyVars, tcFamTyPats,
@@ -42,8 +47,8 @@ module GHC.Tc.Gen.HsType (
-- No kind generalisation, no checkValidType
InitialKindStrategy(..),
SAKS_or_CUSK(..),
+ ContextKind(..),
kcDeclHeader,
- tcNamedWildCardBinders,
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated,
@@ -335,13 +340,13 @@ funsSigCtxt :: [Located Name] -> UserTypeCtxt
funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False
funsSigCtxt [] = panic "funSigCtxt"
-addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
+addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> TcM a -> TcM a
addSigCtxt ctxt hs_ty thing_inside
= setSrcSpan (getLoc hs_ty) $
addErrCtxt (pprSigCtxt ctxt hs_ty) $
thing_inside
-pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc
+pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> SDoc
-- (pprSigCtxt ctxt <extra> <type>)
-- prints In the type signature for 'f':
-- f :: <type>
@@ -361,9 +366,9 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
-- already checked this, so we can simply ignore it.
tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
-kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
+kcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
-- This is a special form of tcClassSigType that is used during the
--- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type.
+-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.
-- Importantly, this does *not* kind-generalize. Consider
-- class SC f where
-- meth :: forall a (x :: f a). Proxy x -> ()
@@ -374,21 +379,18 @@ kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
-- end up promoting kappa to the top level (because kind-generalization is
-- normally done right before adding a binding to the context), and then we
-- can't set kappa := f a, because a is local.
-kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars
- , hsib_body = hs_ty })
- = addSigCtxt (funsSigCtxt names) hs_ty $
- do { (tc_lvl, wanted, (spec_tkvs, _))
- <- pushLevelAndSolveEqualitiesX "kcClassSigType" $
- bindImplicitTKBndrs_Skol sig_vars $
+kcClassSigType names
+ sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))
+ = addSigCtxt (funsSigCtxt names) sig_ty $
+ do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $
tcLHsType hs_ty liftedTypeKind
+ ; return () }
- ; emitResidualTvConstraint skol_info spec_tkvs tc_lvl wanted }
-
-tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
+tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type
-- Does not do validity checking
-tcClassSigType skol_info names sig_ty
- = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
- do { (implic, ty) <- tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
+tcClassSigType names sig_ty
+ = addSigCtxt sig_ctxt sig_ty $
+ do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
; emitImplication implic
; return ty }
-- Do not zonk-to-Type, nor perform a validity check
@@ -407,20 +409,24 @@ tcClassSigType skol_info names sig_ty
-- It should be that f has kind `k2 -> *`, but we never get a chance
-- to run the solver where the kind of f is touchable. This is
-- painfully delicate.
+ where
+ sig_ctxt = funsSigCtxt names
+ skol_info = SigTypeSkol sig_ctxt
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
-- Does validity checking
-- See Note [Recipe for checking a signature]
tcHsSigType ctxt sig_ty
- = addSigCtxt ctxt (hsSigType sig_ty) $
+ = addSigCtxt ctxt sig_ty $
do { traceTc "tcHsSigType {" (ppr sig_ty)
-- Generalise here: see Note [Kind generalisation]
- ; (implic, ty) <- tc_hs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt)
+ ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt)
- -- Spit out the implication (and perhaps fail fast)
+ -- Float out constraints, failing fast if not possible
-- See Note [Failure in local type signatures] in GHC.Tc.Solver
- ; emitFlatConstraints (mkImplicWC (unitBag implic))
+ ; traceTc "tcHsSigType 2" (ppr implic)
+ ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))
; ty <- zonkTcType ty
; checkValidType ctxt ty
@@ -429,7 +435,7 @@ tcHsSigType ctxt sig_ty
where
skol_info = SigTypeSkol ctxt
-tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
+tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-> ContextKind -> TcM (Implication, TcType)
-- Kind-checks/desugars an 'LHsSigType',
-- solve equalities,
@@ -437,25 +443,28 @@ tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-- This will never emit constraints, as it uses solveEqualities internally.
-- No validity checking or zonking
-- Returns also an implication for the unsolved constraints
-tc_hs_sig_type skol_info hs_sig_type ctxt_kind
- | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
- = do { (tc_lvl, wanted, (spec_tkvs, ty))
- <- pushLevelAndSolveEqualitiesX "tc_hs_sig_type" $
+tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs
+ , sig_body = hs_ty })) ctxt_kind
+ = setSrcSpan loc $
+ do { (tc_lvl, wanted, (outer_bndrs, ty))
+ <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $
-- See Note [Failure in local type signatures]
- bindImplicitTKBndrs_Skol sig_vars $
+ tcOuterTKBndrs skol_info hs_outer_bndrs $
do { kind <- newExpectedKind ctxt_kind
; tcLHsType hs_ty kind }
-- Any remaining variables (unsolved in the solveEqualities)
-- should be in the global tyvars, and therefore won't be quantified
- ; spec_tkvs <- zonkAndScopedSort spec_tkvs
- ; let ty1 = mkSpecForAllTys spec_tkvs ty
+ ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)
+ ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs
+
+ ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty
; kvs <- kindGeneralizeSome wanted ty1
-- Build an implication for any as-yet-unsolved kind equalities
-- See Note [Skolem escape in type signatures]
- ; implic <- buildTvImplication skol_info (kvs ++ spec_tkvs) tc_lvl wanted
+ ; implic <- buildTvImplication skol_info kvs tc_lvl wanted
; return (implic, mkInfForAllTys kvs ty1) }
@@ -466,23 +475,24 @@ tcHsSigType is tricky. Consider (T11142)
This is ill-kinded becuase of a nested skolem-escape.
That will show up as an un-solvable constraint in the implication
-returned by buildTvImplication in tc_hs_sig_type. See Note [Skolem
+returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem
escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable
(the unification variable for b's kind is untouchable).
-Then, in GHC.Tc.Solver.emitFlatConstraints (called from tcHsSigType)
+Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)
we'll try to float out the constraint, be unable to do so, and fail.
See GHC.Tc.Solver Note [Failure in local type signatures] for more
detail on this.
-The separation between tcHsSigType and tc_hs_sig_type is because
+The separation between tcHsSigType and tc_lhs_sig_type is because
tcClassSigType wants to use the latter, but *not* fail fast, because
there are skolems from the class decl which are in scope; but it's fine
not to because tcClassDecl1 has a solveEqualities wrapped around all
the tcClassSigType calls.
-That's why tcHsSigType does emitFlatConstraints (which fails fast) but
-tcClassSigType just does emitImplication (which does not). Ugh.
+That's why tcHsSigType does simplifyAndEmitFlatConstraints (which
+fails fast) but tcClassSigType just does emitImplication (which does
+not). Ugh.
c.f. see also Note [Skolem escape and forall-types]. The difference
is that we don't need to simplify at a forall type, only at the
@@ -491,45 +501,46 @@ top level of a signature.
-- Does validity checking and zonking.
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
-tcStandaloneKindSig (L _ kisig) = case kisig of
- StandaloneKindSig _ (L _ name) ksig ->
- let ctxt = StandaloneKindSigCtxt name in
- addSigCtxt ctxt (hsSigType ksig) $
- do { let mode = mkMode KindLevel
- ; kind <- tc_top_lhs_type mode ksig (expectedKindInCtxt ctxt)
+tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))
+ = addSigCtxt ctxt ksig $
+ do { kind <- tc_top_lhs_type KindLevel ctxt ksig
; checkValidType ctxt kind
; return (name, kind) }
+ where
+ ctxt = StandaloneKindSigCtxt name
+tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
+tcTopLHsType ctxt lsig_ty
+ = tc_top_lhs_type TypeLevel ctxt lsig_ty
-tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type
-tcTopLHsType hs_ty ctxt_kind
- = tc_top_lhs_type (mkMode TypeLevel) hs_ty ctxt_kind
-
-tc_top_lhs_type :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
--- tcTopLHsType is used for kind-checking top-level HsType where
+tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
+-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where
-- we want to fully solve /all/ equalities, and report errors
-- Does zonking, but not validity checking because it's used
-- for things (like deriving and instances) that aren't
-- ordinary types
-- Used for both types and kinds
-tc_top_lhs_type mode hs_sig_type ctxt_kind
- | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
- = do { traceTc "tcTopLHsType {" (ppr hs_ty)
- ; (tclvl, wanted, (spec_tkvs, ty))
- <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $
- bindImplicitTKBndrs_Skol sig_vars $
- do { kind <- newExpectedKind ctxt_kind
- ; tc_lhs_type mode hs_ty kind }
-
- ; spec_tkvs <- zonkAndScopedSort spec_tkvs
- ; reportUnsolvedEqualities InstSkol spec_tkvs tclvl wanted
-
- ; let ty1 = mkSpecForAllTys spec_tkvs ty
- ; kvs <- kindGeneralizeAll ty1
+tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs
+ , sig_body = body }))
+ = setSrcSpan loc $
+ do { traceTc "tc_top_lhs_type {" (ppr sig_ty)
+ ; (tclvl, wanted, (outer_bndrs, ty))
+ <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $
+ tcOuterTKBndrs skol_info hs_outer_bndrs $
+ do { kind <- newExpectedKind (expectedKindInCtxt ctxt)
+ ; tc_lhs_type (mkMode tyki) body kind }
+
+ ; outer_tv_bndrs <- scopedSortOuter outer_bndrs
+ ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty
+
+ ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type
+ ; reportUnsolvedEqualities skol_info kvs tclvl wanted
; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)
- ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])
- ; return final_ty}
+ ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])
+ ; return final_ty }
+ where
+ skol_info = SigTypeSkol ctxt
-----------------
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
@@ -542,7 +553,7 @@ tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
tcHsDeriv hs_ty
= do { ty <- checkNoErrs $ -- Avoid redundant error report
-- with "illegal deriving", below
- tcTopLHsType hs_ty AnyKind
+ tcTopLHsType DerivClauseCtxt hs_ty
; let (tvs, pred) = splitForAllTys ty
(kind_args, _) = splitFunTys (tcTypeKind pred)
; case getClassPredTys_maybe pred of
@@ -571,7 +582,7 @@ tcDerivStrategy mb_lds
tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy
tc_deriv_strategy (ViaStrategy ty) = do
- ty' <- checkNoErrs $ tcTopLHsType ty AnyKind
+ ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty
let (via_tvs, via_pred) = splitForAllTys ty'
pure (ViaStrategy via_pred, via_tvs)
@@ -583,13 +594,13 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt
-> TcM Type
-- Like tcHsSigType, but for a class instance declaration
tcHsClsInstType user_ctxt hs_inst_ty
- = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
+ = setSrcSpan (getLoc hs_inst_ty) $
do { -- Fail eagerly if tcTopLHsType fails. We are at top level so
-- these constraints will never be solved later. And failing
-- eagerly avoids follow-on errors when checkValidInstance
-- sees an unsolved coercion hole
inst_ty <- checkNoErrs $
- tcTopLHsType hs_inst_ty (TheKind constraintKind)
+ tcTopLHsType user_ctxt hs_inst_ty
; checkValidInstance user_ctxt hs_inst_ty inst_ty
; return inst_ty }
@@ -605,7 +616,7 @@ tcHsTypeApp wc_ty kind
solveEqualities "tcHsTypeApp" $
-- We are looking at a user-written type, very like a
-- signature so we want to solve its equalities right now
- tcNamedWildCardBinders sig_wcs $ \ _ ->
+ bindNamedWildCardBinders sig_wcs $ \ _ ->
tc_lhs_type mode hs_ty kind
-- We do not kind-generalize type applications: we just
@@ -713,7 +724,7 @@ tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)
tcInferLHsTypeKind lhs_ty@(L loc hs_ty)
= addTypeCtxt lhs_ty $
setSrcSpan loc $ -- Cover the tcInstInvisibleTyBinders
- do { (res_ty, res_kind) <- tc_infer_hs_type (mkMode TypeLevel) hs_ty
+ do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty
; tcInstInvisibleTyBinders res_ty res_kind }
-- See Note [Do not always instantiate eagerly in types]
@@ -783,7 +794,7 @@ concern things that the renamer can't handle.
-}
tcMult :: HsArrow GhcRn -> TcM Mult
-tcMult hc = tc_mult (mkMode TypeLevel) hc
+tcMult hc = tc_mult typeLevelMode hc
-- | Info about the context in which we're checking a type. Currently,
-- differentiates only between types and kinds, but this will likely
@@ -795,11 +806,11 @@ tcMult hc = tc_mult (mkMode TypeLevel) hc
-- This data type is purely local, not exported from this module
data TcTyMode
= TcTyMode { mode_tyki :: TypeOrKind
+ , mode_holes :: HoleInfo }
- -- See Note [Levels for wildcards]
- -- Nothing <=> no wildcards expected
- , mode_holes :: Maybe (TcLevel, HoleMode)
- }
+-- See Note [Levels for wildcards]
+-- Nothing <=> no wildcards expected
+type HoleInfo = Maybe (TcLevel, HoleMode)
-- HoleMode says how to treat the occurrences
-- of anonymous wildcards; see tcAnonWildCardOcc
@@ -812,15 +823,17 @@ data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int
mkMode :: TypeOrKind -> TcTyMode
mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }
+typeLevelMode, kindLevelMode :: TcTyMode
+-- These modes expect no wildcards (holes) in the type
+kindLevelMode = mkMode KindLevel
+typeLevelMode = mkMode TypeLevel
+
mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode tyki hm
= do { lvl <- getTcLevel
; return (TcTyMode { mode_tyki = tyki
, mode_holes = Just (lvl,hm) }) }
-kindLevel :: TcTyMode -> TcTyMode
-kindLevel mode = mode { mode_tyki = KindLevel }
-
instance Outputable HoleMode where
ppr HM_Sig = text "HM_Sig"
ppr HM_FamPat = text "HM_FamPat"
@@ -997,7 +1010,7 @@ substitution to each NHsCoreTy and all is well:
------------------------------------------
tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType
tcLHsType hs_ty exp_kind
- = tc_lhs_type (mkMode TypeLevel) hs_ty exp_kind
+ = tc_lhs_type typeLevelMode hs_ty exp_kind
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
tc_lhs_type mode (L span ty) exp_kind
@@ -1049,32 +1062,16 @@ tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
= tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind
--------- Foralls
-tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
- = do { (tclvl, wanted, (tv_bndrs, ty'))
- <- pushLevelAndCaptureConstraints $
- -- No need to solve equalities here; we will do that later
- bindExplicitTKTele_Skol_M mode tele $
- -- The _M variant passes on the mode from the type, to
- -- any wildards in kind signatures on the forall'd variables
+tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
+ = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $
+ tc_lhs_type mode ty exp_kind
+ -- Pass on the mode from the type, to any wildcards
+ -- in kind signatures on the forall'd variables
-- e.g. f :: _ -> Int -> forall (a :: _). blah
- tc_lhs_type mode ty exp_kind
-- Why exp_kind? See Note [Body kind of HsForAllTy]
-- Do not kind-generalise here! See Note [Kind generalisation]
- ; let skol_info = ForAllSkol (ppr forall) $ sep $ case tele of
- HsForAllVis { hsf_vis_bndrs = hs_tvs } ->
- map ppr hs_tvs
- HsForAllInvis { hsf_invis_bndrs = hs_tvs } ->
- map ppr hs_tvs
- skol_tvs = binderVars tv_bndrs
-
- ; implic <- buildTvImplication skol_info skol_tvs tclvl wanted
- ; emitImplication implic
- -- /Always/ emit this implication even if wanted is empty
- -- We need the implication so that we check for a bad telescope
- -- See Note [Skolem escape and forall-types]
-
; return (mkForAllTys tv_bndrs ty') }
tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind
@@ -1824,10 +1821,10 @@ tcHsMbContext Nothing = return []
tcHsMbContext (Just cxt) = tcHsContext cxt
tcHsContext :: LHsContext GhcRn -> TcM [PredType]
-tcHsContext cxt = tc_hs_context (mkMode TypeLevel) cxt
+tcHsContext cxt = tc_hs_context typeLevelMode cxt
tcLHsPredType :: LHsType GhcRn -> TcM PredType
-tcLHsPredType pred = tc_lhs_pred (mkMode TypeLevel) pred
+tcLHsPredType pred = tc_lhs_pred typeLevelMode pred
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)
@@ -2051,13 +2048,13 @@ addTypeCtxt (L _ ty) thing
* *
********************************************************************* -}
-tcNamedWildCardBinders :: [Name]
- -> ([(Name, TcTyVar)] -> TcM a)
- -> TcM a
+bindNamedWildCardBinders :: [Name]
+ -> ([(Name, TcTyVar)] -> TcM a)
+ -> TcM a
-- Bring into scope the /named/ wildcard binders. Remember that
-- plain wildcards _ are anonymous and dealt with by HsWildCardTy
-- Soe Note [The wildcard story for types] in GHC.Hs.Type
-tcNamedWildCardBinders wc_names thing_inside
+bindNamedWildCardBinders wc_names thing_inside
= do { wcs <- mapM newNamedWildTyVar wc_names
; let wc_prs = wc_names `zip` wcs
; tcExtendNameTyVarEnv wc_prs $
@@ -2351,7 +2348,7 @@ kcInferDeclHeader name flav
all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-- NB: bindExplicitTKBndrs_Q_Tv does not clone;
-- ditto Implicit
- -- See Note [Non-cloning for tyvar binders]
+ -- See Note [Cloning for type variable binders]
tycon = mkTcTyCon name tc_binders res_kind all_tv_prs
False -- not yet generalised
@@ -2897,6 +2894,7 @@ expectedKindInCtxt (GhciCtxt {}) = AnyKind
-- The types in a 'default' decl can have varying kinds
-- See Note [Extended defaults]" in GHC.Tc.Utils.Env
expectedKindInCtxt DefaultDeclCtxt = AnyKind
+expectedKindInCtxt DerivClauseCtxt = AnyKind
expectedKindInCtxt TypeAppCtxt = AnyKind
expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind
expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind
@@ -2910,228 +2908,411 @@ expectedKindInCtxt _ = OpenKind
* *
********************************************************************* -}
-{- Note [Non-cloning for tyvar binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone;
-and nor do the Implicit versions. There is no need.
-
-bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit.
-We take advantage of this in kcInferDeclHeader:
- all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-If we cloned, we'd need to take a bit more care here; not hard.
-
-The main payoff is that avoidng gratuitious cloning means that we can
-almost always take the fast path in swizzleTcTyConBndrs. "Almost
-always" means not the case of mutual recursion with polymorphic kinds.
-
-
-Note [Cloning for tyvar binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique,
-unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.)
-And similarly for bindImplicit...
-
-This for a narrow and tricky reason which, alas, I couldn't find a
-simpler way round. #16221 is the poster child:
-
- data SameKind :: k -> k -> *
- data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int
-
-When kind-checking T, we give (a :: kappa1). Then:
-
-- In kcConDecl we make a TyVarTv unification variable kappa2 for k2
- (as described in Note [Kind-checking for GADTs], even though this
- example is an existential)
-- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv
-- We end up unifying kappa1 := kappa2, because of the (SameKind a b)
-
-Now we generalise over kappa2. But if kappa2's Name is precisely k2
-(i.e. we did not clone) we'll end up giving T the utterlly final kind
- T :: forall k2. k2 -> *
-Nothing directly wrong with that but when we typecheck the data constructor
-we have k2 in scope; but then it's brought into scope /again/ when we find
-the forall k2. This is chaotic, and we end up giving it the type
- MkT :: forall k2 (a :: k2) k2 (b :: k2).
- SameKind @k2 a b -> Int -> T @{k2} a
-which is bogus -- because of the shadowing of k2, we can't
-apply T to the kind or a!
-
-And there no reason /not/ to clone the Name when making a unification
-variable. So that's what we do.
--}
-
---------------------------------------
--- Implicit binders
---------------------------------------
-
-bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
- bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
- :: [Name] -> TcM a -> TcM ([TcTyVar], a)
-bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)
-bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)
-bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar
-bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar
- -- newFlexiKinded... see Note [Non-cloning for tyvar binders]
- -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders]
-
-bindImplicitTKBndrsX
- :: (Name -> TcM TcTyVar) -- new_tv function
- -> [Name]
- -> TcM a
- -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence
- -- with the passed in [Name]
-bindImplicitTKBndrsX new_tv tv_names thing_inside
- = do { tkvs <- mapM new_tv tv_names
- ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)
- ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)
- thing_inside
- ; return (tkvs, res) }
-
-newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
--- Behave like new_tv, except that if the tyvar is in scope, use it
-newImplicitTyVarQ new_tv name
- = do { mb_tv <- tcLookupLcl_maybe name
- ; case mb_tv of
- Just (ATyVar _ tv) -> return tv
- _ -> new_tv name }
-
-newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
-newFlexiKindedTyVar new_tv name
- = do { kind <- newMetaKindVar
- ; new_tv name kind }
-
-newFlexiKindedSkolemTyVar :: Name -> TcM TyVar
-newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar
-
-newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
-newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
-
-cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar
-cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar
- -- See Note [Cloning for tyvar binders]
-
--------------------------------------
--- Explicit binders
+-- HsForAllTelescope
--------------------------------------
--- | Skolemise the 'HsTyVarBndr's in an 'LHsForAllTelescope.
-bindExplicitTKTele_Skol_M
- :: TcTyMode
- -> HsForAllTelescope GhcRn
- -> TcM a
- -> TcM ([TcTyVarBinder], a)
-bindExplicitTKTele_Skol_M mode tele thing_inside = case tele of
+tcTKTelescope :: TcTyMode
+ -> HsForAllTelescope GhcRn
+ -> TcM a
+ -> TcM ([TcTyVarBinder], a)
+tcTKTelescope mode tele thing_inside = case tele of
HsForAllVis { hsf_vis_bndrs = bndrs }
- -> do { (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside
+ -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside
-- req_tv_bndrs :: [VarBndr TyVar ()],
-- but we want [VarBndr TyVar ArgFlag]
; return (tyVarReqToBinders req_tv_bndrs, thing) }
+
HsForAllInvis { hsf_invis_bndrs = bndrs }
- -> do { (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside
+ -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside
-- inv_tv_bndrs :: [VarBndr TyVar Specificity],
-- but we want [VarBndr TyVar ArgFlag]
; return (tyVarSpecToBinders inv_tv_bndrs, thing) }
+ where
+ skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode }
+
+--------------------------------------
+-- HsOuterTyVarBndrs
+--------------------------------------
+
+bindOuterTKBndrsX :: OutputableBndrFlag flag
+ => SkolemMode
+ -> HsOuterTyVarBndrs flag GhcRn
+ -> TcM a
+ -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+bindOuterTKBndrsX skol_mode outer_bndrs thing_inside
+ = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} ->
+ do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside
+ ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}
+ , thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside
+ ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
+ , hso_bndrs = exp_bndrs }
+ , thing) }
+
+getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]
+-- The returned [TcTyVar] is not necessarily in dependency order
+-- at least for the HsOuterImplicit case
+getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs
+getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs
+
+---------------
+scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
+-- Sort any /implicit/ binders into dependency order
+-- (zonking first so we can see the dependencies)
+-- /Explicit/ ones are already in the right order
+scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})
+ = do { imp_tvs <- zonkAndScopedSort imp_tvs
+ ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] }
+scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs})
+ = -- No need to dependency-sort (or zonk) explicit quantifiers
+ return exp_tvs
+
+---------------
+bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn
+ -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
+bindOuterSigTKBndrs_Tv
+ = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })
+
+bindOuterSigTKBndrs_Tv_M :: TcTyMode
+ -> HsOuterSigTyVarBndrs GhcRn
+ -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
+-- Do not push level; do not make implication constraint; use Tvs
+-- Two major clients of this "bind-only" path are:
+-- Note [Kind-checking for GADTs] in TyCl
+-- Note [Checking partial type signatures]
+bindOuterSigTKBndrs_Tv_M mode
+ = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True
+ , sm_holes = mode_holes mode })
+
+bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn
+ -> TcM a
+ -> TcM ([TcTyVar], a)
+bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside
+ = liftFstM getOuterTyVars $
+ bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
+ , sm_tvtv = True })
+ hs_bndrs thing_inside
+ -- sm_clone=False: see Note [Cloning for type variable binders]
+
+bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn
+ -> TcM a
+ -> TcM ([TcTyVar], a)
+bindOuterFamEqnTKBndrs hs_bndrs thing_inside
+ = liftFstM getOuterTyVars $
+ bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })
+ hs_bndrs thing_inside
+ -- sm_clone=False: see Note [Cloning for type variable binders]
+
+---------------
+tcOuterTKBndrs :: OutputableBndrFlag flag
+ => SkolemInfo
+ -> HsOuterTyVarBndrs flag GhcRn
+ -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False })
+ -- Do not clone the outer binders
+ -- See Note [Cloning for type variable binder] under "must not"
+
+tcOuterTKBndrsX :: OutputableBndrFlag flag
+ => SkolemMode -> SkolemInfo
+ -> HsOuterTyVarBndrs flag GhcRn
+ -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
+-- Push level, capture constraints, make implication
+tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside
+ = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} ->
+ do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside
+ ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}
+ , thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside
+ ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
+ , hso_bndrs = exp_bndrs }
+ , thing) }
+--------------------------------------
+-- Explicit tyvar binders
+--------------------------------------
+
+tcExplicitTKBndrs :: OutputableBndrFlag flag
+ => [LHsTyVarBndr flag GhcRn]
+ -> TcM a
+ -> TcM ([VarBndr TyVar flag], a)
+tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True })
+
+tcExplicitTKBndrsX :: OutputableBndrFlag flag
+ => SkolemMode
+ -> [LHsTyVarBndr flag GhcRn]
+ -> TcM a
+ -> TcM ([VarBndr TyVar flag], a)
+-- Push level, capture constraints,
+-- and emit an implication constraint with a ForAllSkol ic_info,
+-- so that it is subject to a telescope test.
+tcExplicitTKBndrsX skol_mode bndrs thing_inside
+ = do { (tclvl, wanted, (skol_tvs, res))
+ <- pushLevelAndCaptureConstraints $
+ bindExplicitTKBndrsX skol_mode bndrs $
+ thing_inside
+
+ ; let skol_info = ForAllSkol (fsep (map ppr bndrs))
+ -- Notice that we use ForAllSkol here, ignoring the enclosing
+ -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope
+ -- test applies only to ForAllSkol
+ ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted
+
+ ; return (skol_tvs, res) }
+
+----------------
+-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied
+-- 'TcTyMode'.
bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
:: (OutputableBndrFlag flag)
=> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
-bindExplicitTKBndrs_Skol_M, bindExplicitTKBndrs_Tv_M
- :: (OutputableBndrFlag flag)
- => TcTyMode
- -> [LHsTyVarBndr flag GhcRn]
- -> TcM a
- -> TcM ([VarBndr TyVar flag], a)
-
-bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) newSkolemTyVar)
-bindExplicitTKBndrs_Skol_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) newSkolemTyVar)
-bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) cloneTyVarTyVar)
-bindExplicitTKBndrs_Tv_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode) cloneTyVarTyVar)
- -- newSkolemTyVar: see Note [Non-cloning for tyvar binders]
- -- cloneTyVarTyVar: see Note [Cloning for tyvar binders]
+bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False })
+bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })
+ -- sm_clone: see Note [Cloning for type variable binders]
bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
:: ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
-
-bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)
-bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)
- -- See Note [Non-cloning for tyvar binders]
-
-bindExplicitTKBndrsX_Q
- :: (HsTyVarBndr () GhcRn -> TcM TcTyVar)
- -> [LHsTyVarBndr () GhcRn]
- -> TcM a
- -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence
- -- with the passed-in [LHsTyVarBndr]
-bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside
- = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
- ; return (binderVars tv_bndrs,res) }
+-- These do not clone: see Note [Cloning for type variable binders]
+bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside
+ = liftFstM binderVars $
+ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
+ , sm_kind = ctxt_kind })
+ hs_bndrs thing_inside
+ -- sm_clone=False: see Note [Cloning for type variable binders]
+
+bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside
+ = liftFstM binderVars $
+ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
+ , sm_tvtv = True, sm_kind = ctxt_kind })
+ hs_bndrs thing_inside
+ -- sm_clone=False: see Note [Cloning for type variable binders]
bindExplicitTKBndrsX :: (OutputableBndrFlag flag)
- => (HsTyVarBndr flag GhcRn -> TcM TyVar)
+ => SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence
-- with the passed-in [LHsTyVarBndr]
-bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
- = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)
+bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind
+ , sm_holes = hole_info })
+ hs_tvs thing_inside
+ = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)
; go hs_tvs }
where
+ tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }
+ -- Inherit the HoleInfo from the context
+
go [] = do { res <- thing_inside
; return ([], res) }
go (L _ hs_tv : hs_tvs)
- = do { tv <- tc_tv hs_tv
+ = do { lcl_env <- getLclTypeEnv
+ ; tv <- tc_hs_bndr lcl_env hs_tv
-- Extend the environment as we go, in case a binder
-- is mentioned in the kind of a later binder
-- e.g. forall k (a::k). blah
-- NB: tv's Name may differ from hs_tv's
- -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders]
+ -- See Note [Cloning for type variable binders]
; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $
go hs_tvs
; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }
------------------
-tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar)
- -> HsTyVarBndr flag GhcRn -> TcM TcTyVar
-tcHsTyVarBndr _ new_tv (UserTyVar _ _ (L _ tv_nm))
- = do { kind <- newMetaKindVar
- ; new_tv tv_nm kind }
-tcHsTyVarBndr mode new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)
- = do { kind <- tc_lhs_kind_sig mode (TyVarBndrKindCtxt tv_nm) lhs_kind
- ; new_tv tv_nm kind }
------------------
-tcHsQTyVarBndr :: ContextKind
- -> (Name -> Kind -> TcM TyVar)
- -> HsTyVarBndr () GhcRn -> TcM TcTyVar
--- Just like tcHsTyVarBndr, but also
--- - uses the in-scope TyVar from class, if it exists
--- - takes a ContextKind to use for the no-sig case
-tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ _ (L _ tv_nm))
- = do { mb_tv <- tcLookupLcl_maybe tv_nm
- ; case mb_tv of
- Just (ATyVar _ tv) -> return tv
- _ -> do { kind <- newExpectedKind ctxt_kind
- ; new_tv tv_nm kind } }
-
-tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)
- = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
- ; mb_tv <- tcLookupLcl_maybe tv_nm
- ; case mb_tv of
- Just (ATyVar _ tv)
- -> do { discardResult $ unifyKind (Just (ppr tv_nm))
- kind (tyVarKind tv)
- -- This unify rejects:
- -- class C (m :: * -> *) where
- -- type F (m :: *) = ...
- ; return tv }
-
- _ -> new_tv tv_nm kind }
+ tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))
+ | check_parent
+ , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
+ = return tv
+ | otherwise
+ = do { kind <- newExpectedKind ctxt_kind
+ ; newTyVarBndr skol_mode name kind }
+
+ tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)
+ | check_parent
+ , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
+ = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind
+ ; discardResult $
+ unifyKind (Just (ppr name)) kind (tyVarKind tv)
+ -- This unify rejects:
+ -- class C (m :: * -> *) where
+ -- type F (m :: *) = ...
+ ; return tv }
+
+ | otherwise
+ = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind
+ ; newTyVarBndr skol_mode name kind }
+
+newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar
+newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind
+ = do { name <- case clone of
+ True -> do { uniq <- newUnique
+ ; return (setNameUnique name uniq) }
+ False -> return name
+ ; details <- case tvtv of
+ True -> newMetaDetails TyVarTv
+ False -> do { lvl <- getTcLevel
+ ; return (SkolemTv lvl False) }
+ ; return (mkTcTyVar name kind details) }
+
+--------------------------------------
+-- Implicit tyvar binders
+--------------------------------------
+
+tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo
+ -> [Name]
+ -> TcM a
+ -> TcM ([TcTyVar], a)
+-- The workhorse:
+-- push level, capture constraints,
+-- and emit an implication constraint with a ForAllSkol ic_info,
+-- so that it is subject to a telescope test.
+tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside
+ = do { (tclvl, wanted, (skol_tvs, res))
+ <- pushLevelAndCaptureConstraints $
+ bindImplicitTKBndrsX skol_mode bndrs $
+ thing_inside
+
+ ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted
+
+ ; return (skol_tvs, res) }
+
+------------------
+bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
+ bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
+ :: [Name] -> TcM a -> TcM ([TcTyVar], a)
+bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = True })
+bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })
+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })
+bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True })
+
+bindImplicitTKBndrsX
+ :: SkolemMode
+ -> [Name]
+ -> TcM a
+ -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence
+ -- with the passed in [Name]
+bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })
+ tv_names thing_inside
+ = do { lcl_env <- getLclTypeEnv
+ ; tkvs <- mapM (new_tv lcl_env) tv_names
+ ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)
+ ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)
+ thing_inside
+ ; return (tkvs, res) }
+ where
+ new_tv lcl_env name
+ | check_parent
+ , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
+ = return tv
+ | otherwise
+ = do { kind <- newExpectedKind ctxt_kind
+ ; newTyVarBndr skol_mode name kind }
+
+--------------------------------------
+-- SkolemMode
+--------------------------------------
+
+-- | 'SkolemMode' decribes how to typecheck an explicit ('HsTyVarBndr') or
+-- implicit ('Name') binder in a type. It is just a record of flags
+-- that describe what sort of 'TcTyVar' to create.
+data SkolemMode
+ = SM { sm_parent :: Bool -- True <=> check the in-scope parent type variable
+ -- Used only for asssociated types
+
+ , sm_clone :: Bool -- True <=> fresh unique
+ -- See Note [Cloning for type variable binders]
+
+ , sm_tvtv :: Bool -- True <=> use a TyVarTv, rather than SkolemTv
+ -- Why? See Note [Inferring kinds for type declarations]
+ -- in GHC.Tc.TyCl, and (in this module)
+ -- Note [Checking partial type signatures]
+
+ , sm_kind :: ContextKind -- Use this for the kind of any new binders
+
+ , sm_holes :: HoleInfo -- What to do for wildcards in the kind
+ }
+
+smVanilla :: SkolemMode
+smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this
+ , sm_parent = False
+ , sm_tvtv = False
+ , sm_kind = AnyKind
+ , sm_holes = Nothing }
+
+{- Note [Cloning for type variable binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Sometimes we must clone the Name of a type variable binder (written in
+the source program); and sometimes we must not. This is controlled by
+the sm_clone field of SkolemMode.
+
+In some cases it doesn't matter whether or not we clone. Perhaps
+it'd be better to use MustClone/MayClone/MustNotClone.
+
+When we /must not/ clone
+* In the binders of a type signature (tcOuterTKBndrs)
+ f :: forall a{27}. blah
+ f = rhs
+ Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),
+ we must get the type (forall a{27}. blah) for the Id f, because
+ we bring that type variable into scope when we typecheck 'rhs'.
+
+* In the binders of a data family instance (bindOuterFamEqnTKBndrs)
+ data instance
+ forall p q. D (p,q) = D1 p | D2 q
+ We kind-check the LHS in tcDataFamInstHeader, and then separately
+ (in tcDataFamInstDecl) bring p,q into scope before looking at the
+ the constructor decls.
+
+* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone
+ We take advantage of this in kcInferDeclHeader:
+ all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
+ If we cloned, we'd need to take a bit more care here; not hard.
+
+* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.
+ There is no need, I think.
+
+ The payoff here is that avoiding gratuitous cloning means that we can
+ almost always take the fast path in swizzleTcTyConBndrs.
+
+When we /must/ clone.
+* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning
+
+ This for a narrow and tricky reason which, alas, I couldn't find a
+ simpler way round. #16221 is the poster child:
+
+ data SameKind :: k -> k -> *
+ data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int
+
+ When kind-checking T, we give (a :: kappa1). Then:
+
+ - In kcConDecl we make a TyVarTv unification variable kappa2 for k2
+ (as described in Note [Kind-checking for GADTs], even though this
+ example is an existential)
+ - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv
+ - We end up unifying kappa1 := kappa2, because of the (SameKind a b)
+
+ Now we generalise over kappa2. But if kappa2's Name is precisely k2
+ (i.e. we did not clone) we'll end up giving T the utterly final kind
+ T :: forall k2. k2 -> *
+ Nothing directly wrong with that but when we typecheck the data constructor
+ we have k2 in scope; but then it's brought into scope /again/ when we find
+ the forall k2. This is chaotic, and we end up giving it the type
+ MkT :: forall k2 (a :: k2) k2 (b :: k2).
+ SameKind @k2 a b -> Int -> T @{k2} a
+ which is bogus -- because of the shadowing of k2, we can't
+ apply T to the kind or a!
+
+ And there no reason /not/ to clone the Name when making a unification
+ variable. So that's what we do.
+-}
--------------------------------------
-- Binding type/class variables in the
@@ -3161,8 +3342,8 @@ bindTyClTyVars tycon_name thing_inside
zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort spec_tkvs
- = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs
- -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv
+ = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs
+ -- Zonk the kinds, to we can do the dependency analayis
-- Do a stable topological sort, following
-- Note [Ordering of implicit variables] in GHC.Rename.HsType
@@ -3563,18 +3744,16 @@ tcHsPartialSigType
, TcType ) -- Tau part
-- See Note [Checking partial type signatures]
tcHsPartialSigType ctxt sig_ty
- | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
- , HsIB { hsib_ext = implicit_hs_tvs
- , hsib_body = hs_ty } <- ib_ty
- , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty
- = addSigCtxt ctxt hs_ty $
+ | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty
+ , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty
+ , (L _ hs_ctxt, hs_tau) <- splitLHsQualTy body_ty
+ = addSigCtxt ctxt sig_ty $
do { mode <- mkHoleMode TypeLevel HM_Sig
- ; (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau)))
- <- solveEqualities "tcHsPartialSigType" $
+ ; (outer_bndrs, (wcs, wcx, theta, tau))
+ <- solveEqualities "tcHsPartialSigType" $
-- See Note [Failure in local type signatures]
- tcNamedWildCardBinders sig_wcs $ \ wcs ->
- bindImplicitTKBndrs_Tv implicit_hs_tvs $
- bindExplicitTKBndrs_Tv_M mode explicit_hs_tvs $
+ bindNamedWildCardBinders sig_wcs $ \ wcs ->
+ bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $
do { -- Instantiate the type-class context; but if there
-- is an extra-constraints wildcard, just discard it here
(theta, wcx) <- tcPartialContext mode hs_ctxt
@@ -3585,11 +3764,12 @@ tcHsPartialSigType ctxt sig_ty
; return (wcs, wcx, theta, tau) }
- ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs
+ ; traceTc "tcHsPartialSigType 2" empty
+ ; outer_tv_bndrs <- scopedSortOuter outer_bndrs
+ ; traceTc "tcHsPartialSigType 3" empty
-- No kind-generalization here:
- ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $
- mkInvisForAllTys explicit_tvbndrs $
+ ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $
mkPhiTy theta $
tau)
@@ -3601,16 +3781,17 @@ tcHsPartialSigType ctxt sig_ty
-- Zonk, so that any nested foralls can "see" their occurrences
-- See Note [Checking partial type signatures], and in particular
-- Note [Levels for wildcards]
- ; implicit_tvbndrs <- mapM zonkInvisTVBinder implicit_tvbndrs
- ; explicit_tvbndrs <- mapM zonkInvisTVBinder explicit_tvbndrs
- ; theta <- mapM zonkTcType theta
- ; tau <- zonkTcType tau
+ ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs
+ ; theta <- mapM zonkTcType theta
+ ; tau <- zonkTcType tau
-- We return a proper (Name,InvisTVBinder) environment, to be sure that
-- we bring the right name into scope in the function body.
-- Test case: partial-sigs/should_compile/LocalDefinitionBug
- ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs)
- ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs)
+ ; let outer_bndr_names :: [Name]
+ outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs
+ tv_prs :: [(Name,InvisTVBinder)]
+ tv_prs = outer_bndr_names `zip` outer_tv_bndrs
-- NB: checkValidType on the final inferred type will be
-- done later by checkInferredPolyId. We can't do it
@@ -3656,7 +3837,7 @@ we do the following
They are typechecked as a recursive group, with monomorphic types,
so 'a' and 'b' will get unified together. Very like kind inference
for mutually recursive data types (sans CUSKs or SAKS); see
- Note [Cloning for tyvar binders] in GHC.Tc.Gen.HsType
+ Note [Cloning for type variable binders]
* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike
the companion CompleteSig) contains the original, as-yet-unchecked
@@ -3784,7 +3965,7 @@ tcHsPatSigType ctxt
solveEqualities "tcHsPatSigType" $
-- See Note [Failure in local type signatures]
-- and c.f #16033
- tcNamedWildCardBinders sig_wcs $ \ wcs ->
+ bindNamedWildCardBinders sig_wcs $ \ wcs ->
tcExtendNameTyVarEnv sig_tkv_prs $
do { ek <- newOpenTypeKind
; sig_ty <- tc_lhs_type mode hs_ty ek
@@ -3890,7 +4071,7 @@ It does sort checking and desugaring at the same time, in one single pass.
tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig ctxt hs_kind
- = tc_lhs_kind_sig (mkMode KindLevel) ctxt hs_kind
+ = tc_lhs_kind_sig kindLevelMode ctxt hs_kind
tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tc_lhs_kind_sig mode ctxt hs_kind
@@ -3927,7 +4108,11 @@ promotionErr name err
NoDataKindsTC -> text "perhaps you intended to use DataKinds"
NoDataKindsDC -> text "perhaps you intended to use DataKinds"
PatSynPE -> text "pattern synonyms cannot be promoted"
- _ -> text "it is defined and used in the same recursive group"
+ RecDataConPE -> same_rec_group_msg
+ ClassPE -> same_rec_group_msg
+ TyConPE -> same_rec_group_msg
+
+ same_rec_group_msg = text "it is defined and used in the same recursive group"
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index dba5bf5874a9..a1004e07c669 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -838,6 +838,15 @@ between alternatives.
RIP GADT refinement: refinements have been replaced by the use of explicit
equality constraints that are used in conjunction with implication constraints
to express the local scope of GADT refinements.
+
+Note [Freshen existentials]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is essential that these existentials are freshened.
+Otherwise, if we have something like
+ case (a :: Ex, b :: Ex) of (MkEx ..., MkEx ...) -> ...
+we'll give both unpacked existential variables the
+same name, leading to shadowing.
+
-}
-- Running example:
@@ -888,6 +897,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled
; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
-- Get location from monad, not from ex_tvs
+ -- This freshens: See Note [Freshen existentials]
; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
-- pat_ty' is type of the actual constructor application
@@ -974,6 +984,8 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)
; checkExistentials ex_tvs all_arg_tys penv
; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
+ -- This freshens: Note [Freshen existentials]
+
; let ty' = substTy tenv ty
arg_tys' = substScaledTys tenv arg_tys
pat_mult = scaledMult pat_ty
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 170930c2ff95..64be6780a3bf 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -32,6 +32,7 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
@@ -104,21 +105,8 @@ especially on value bindings. Here's an overview.
unification variables is correct because we are in tcMonoBinds.
-Note [Scoped tyvars]
-~~~~~~~~~~~~~~~~~~~~
-The -XScopedTypeVariables flag brings lexically-scoped type variables
-into scope for any explicitly forall-quantified type variables:
- f :: forall a. a -> a
- f x = e
-Then 'a' is in scope inside 'e'.
-
-However, we do *not* support this
- - For pattern bindings e.g
- f :: forall a. a->a
- (f,g) = e
-
Note [Binding scoped type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type variables *brought into lexical scope* by a type signature
may be a subset of the *quantified type variables* of the signatures,
for two reasons:
@@ -264,13 +252,17 @@ completeSigFromId ctxt id
, sig_loc = getSrcSpan id }
isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
--- ^ If there are no wildcards, return a LHsSigType
-isCompleteHsSig (HsWC { hswc_ext = wcs
- , hswc_body = HsIB { hsib_body = hs_ty } })
- = null wcs && no_anon_wc hs_ty
+-- ^ If there are no wildcards, return a LHsSigWcType
+isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty })
+ = null wcs && no_anon_wc_sig_ty hs_sig_ty
+
+no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
+no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
+ = all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs)
+ && no_anon_wc_ty body
-no_anon_wc :: LHsType GhcRn -> Bool
-no_anon_wc lty = go lty
+no_anon_wc_ty :: LHsType GhcRn -> Bool
+no_anon_wc_ty lty = go lty
where
go (L _ ty) = case ty of
HsWildCardTy _ -> False
@@ -305,11 +297,13 @@ no_anon_wc lty = go lty
no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele tele = case tele of
- HsForAllVis { hsf_vis_bndrs = ltvs } -> all (go . unLoc) ltvs
- HsForAllInvis { hsf_invis_bndrs = ltvs } -> all (go . unLoc) ltvs
- where
- go (UserTyVar _ _ _) = True
- go (KindedTyVar _ _ _ ki) = no_anon_wc ki
+ HsForAllVis { hsf_vis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs
+ HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs
+
+no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool
+no_anon_wc_tvb (L _ tvb) = case tvb of
+ UserTyVar _ _ _ -> True
+ KindedTyVar _ _ _ ki -> no_anon_wc_ty ki
{- Note [Fail eagerly on bad signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -378,17 +372,17 @@ completely solving them.
tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
-- See Note [Pattern synonym signatures]
-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
-tcPatSynSig name sig_ty
- | HsIB { hsib_ext = implicit_hs_tvs
- , hsib_body = hs_ty } <- sig_ty
- , (univ_hs_tvbndrs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty
- , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1
- = do { traceTc "tcPatSynSig 1" (ppr sig_ty)
- ; (tclvl, wanted, (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))))
- <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $
- bindImplicitTKBndrs_Skol implicit_hs_tvs $
- bindExplicitTKBndrs_Skol univ_hs_tvbndrs $
- bindExplicitTKBndrs_Skol ex_hs_tvbndrs $
+tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty}))
+ | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty
+ , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1
+ = do { traceTc "tcPatSynSig 1" (ppr sig_ty)
+
+ ; let skol_info = DataConSkol name
+ ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))
+ <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $
+ -- See Note [solveEqualities in tcPatSynSig]
+ tcOuterTKBndrs skol_info hs_outer_bndrs $
+ tcExplicitTKBndrs ex_hs_tvbndrs $
do { req <- tcHsContext hs_req
; prov <- tcHsContext hs_prov
; body_ty <- tcHsOpenType hs_body_ty
@@ -396,32 +390,37 @@ tcPatSynSig name sig_ty
-- e.g. pattern Zero <- 0# (#12094)
; return (req, prov, body_ty) }
+ ; let implicit_tvs :: [TcTyVar]
+ univ_bndrs :: [TcInvisTVBinder]
+ (implicit_tvs, univ_bndrs) = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, [])
+ HsOuterExplicit{hso_xexplicit = univ_bndrs} -> ([], univ_bndrs)
+
; implicit_tvs <- zonkAndScopedSort implicit_tvs
- ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs
- req ex_tvbndrs prov body_ty
+ ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs
-- Kind generalisation
- ; kvs <- kindGeneralizeAll ungen_patsyn_ty
+ ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs
+ req ex_bndrs prov body_ty
; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)
-
- ; let skol_tvs = kvs ++ implicit_tvs ++ binderVars (univ_tvbndrs ++ ex_tvbndrs)
- skol_info = DataConSkol name
- ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted
+ ; kvs <- kindGeneralizeAll ungen_patsyn_ty
+ ; reportUnsolvedEqualities skol_info kvs tclvl wanted
-- See Note [Report unsolved equalities in tcPatSynSig]
-- These are /signatures/ so we zonk to squeeze out any kind
-- unification variables. Do this after kindGeneralizeAll which may
-- default kind variables to *.
- ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs
- ; univ_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs
- ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs
- ; req <- zonkTcTypes req
- ; prov <- zonkTcTypes prov
- ; body_ty <- zonkTcType body_ty
+ ; (ze, kv_bndrs) <- zonkTyVarBinders (mkTyVarBinders InferredSpec kvs)
+ ; (ze, implicit_bndrs) <- zonkTyVarBindersX ze implicit_bndrs
+ ; (ze, univ_bndrs) <- zonkTyVarBindersX ze univ_bndrs
+ ; (ze, ex_bndrs) <- zonkTyVarBindersX ze ex_bndrs
+ ; req <- zonkTcTypesToTypesX ze req
+ ; prov <- zonkTcTypesToTypesX ze prov
+ ; body_ty <- zonkTcTypeToTypeX ze body_ty
-- Now do validity checking
; checkValidType ctxt $
- build_patsyn_type kvs implicit_tvs univ_tvbndrs req ex_tvbndrs prov body_ty
+ build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty
-- arguments become the types of binders. We thus cannot allow
-- levity polymorphism here
@@ -429,27 +428,25 @@ tcPatSynSig name sig_ty
; mapM_ (checkForLevPoly empty . scaledThing) arg_tys
; traceTc "tcTySig }" $
- vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
- , text "kvs" <+> ppr_tvs kvs
- , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs)
+ vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs)
+ , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs)
+ , text "univ_tvs" <+> ppr_tvs (binderVars univ_bndrs)
, text "req" <+> ppr req
- , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs)
+ , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs)
, text "prov" <+> ppr prov
, text "body_ty" <+> ppr body_ty ]
; return (TPSI { patsig_name = name
- , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++
- mkTyVarBinders SpecifiedSpec implicit_tvs
- , patsig_univ_bndrs = univ_tvbndrs
+ , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs
+ , patsig_univ_bndrs = univ_bndrs
, patsig_req = req
- , patsig_ex_bndrs = ex_tvbndrs
+ , patsig_ex_bndrs = ex_bndrs
, patsig_prov = prov
, patsig_body_ty = body_ty }) }
where
ctxt = PatSynCtxt name
- build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body
- = mkInfForAllTys kvs $
- mkSpecForAllTys imp $
+ build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body
+ = mkInvisForAllTys implicit_bndrs $
mkInvisForAllTys univ_bndrs $
mkPhiTy req $
mkInvisForAllTys ex_bndrs $
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 115c64f34141..754059571b17 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2470,14 +2470,14 @@ getGhciStepIO = do
let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
- step_ty = noLoc $ HsForAllTy
- { hst_tele = mkHsForAllInvisTele
- [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]
- , hst_xforall = noExtField
- , hst_body = nlHsFunTy ghciM ioM }
+ step_ty :: LHsSigType GhcRn
+ step_ty = noLoc $ HsSig
+ { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]}
+ , sig_ext = noExtField
+ , sig_body = nlHsFunTy ghciM ioM }
stepTy :: LHsSigWcType GhcRn
- stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
+ stepTy = mkEmptyWildCardBndrs step_ty
return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
@@ -2610,7 +2610,7 @@ tcRnType hsc_env flexi normalise rdr_type
; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
; (_tclvl, wanted, (ty, kind))
<- pushLevelAndSolveEqualitiesX "tcRnType" $
- tcNamedWildCardBinders wcs $ \ wcs' ->
+ bindNamedWildCardBinders wcs $ \ wcs' ->
do { mapM_ emitNamedTypeHole wcs'
; tcInferLHsTypeUnsaturated rn_type }
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index bf7e9b239e98..dc23ca54e675 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -18,7 +18,7 @@ module GHC.Tc.Solver(
simplifyTopWanteds,
- promoteTyVarSet, emitFlatConstraints,
+ promoteTyVarSet, simplifyAndEmitFlatConstraints,
-- For Rules we need these
solveWanteds, solveWantedsAndDrop,
@@ -200,24 +200,29 @@ solveEqualities :: String -> TcM a -> TcM a
solveEqualities callsite thing_inside
= do { traceTc "solveEqualities {" (text "Called from" <+> text callsite)
; (res, wanted) <- captureConstraints thing_inside
- ; residual_wanted <- runTcSEqualities (solveWantedsAndDrop wanted)
- ; emitFlatConstraints residual_wanted
- -- emitFlatConstraints fails outright unless the only unsolved
- -- constraints are soluble-looking equalities that can float out
- ; traceTc "solveEqualities }" (text "Residual: " <+> ppr residual_wanted)
+ ; simplifyAndEmitFlatConstraints wanted
+ -- simplifyAndEmitFlatConstraints fails outright unless
+ -- the only unsolved constraints are soluble-looking
+ -- equalities that can float out
+ ; traceTc "solveEqualities }" empty
; return res }
-emitFlatConstraints :: WantedConstraints -> TcM ()
+simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()
-- See Note [Failure in local type signatures]
-emitFlatConstraints wanted
- = do { wanted <- TcM.zonkWC wanted
+simplifyAndEmitFlatConstraints wanted
+ = do { -- Solve and zonk to esablish the
+ -- preconditions for floatKindEqualities
+ wanted <- runTcSEqualities (solveWanteds wanted)
+ ; wanted <- TcM.zonkWC wanted
+
+ ; traceTc "emitFlatConstraints {" (ppr wanted)
; case floatKindEqualities wanted of
- Nothing -> do { traceTc "emitFlatConstraints: failing" (ppr wanted)
+ Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted)
; emitConstraints wanted -- So they get reported!
; failM }
Just (simples, holes)
- -> do { _ <- TcM.promoteTyVarSet (tyCoVarsOfCts simples)
- ; traceTc "emitFlatConstraints:" $
+ -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)
+ ; traceTc "emitFlatConstraints }" $
vcat [ text "simples:" <+> ppr simples
, text "holes: " <+> ppr holes ]
; emitHoles holes -- Holes don't need promotion
@@ -228,6 +233,12 @@ floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)
-- Return Nothing if any constraints can't be floated (captured
-- by skolems), or if there is an insoluble constraint, or
-- IC_Telescope telescope error
+-- Precondition 1: we have tried to solve the 'wanteds', both so that
+-- the ic_status field is set, and because solving can make constraints
+-- more floatable.
+-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities
+-- is not monadic
+-- See Note [floatKindEqualities vs approximateWC]
floatKindEqualities wc = float_wc emptyVarSet wc
where
float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)
@@ -328,7 +339,7 @@ So here's the plan (see tcHsSigType):
* buildTvImplication: build an implication for the residual, unsolved
constraint
-* emitFlatConstraints: try to float out every unsolved equalities
+* simplifyAndEmitFlatConstraints: try to float out every unsolved equality
inside that implication, in the hope that it constrains only global
type variables, not the locally-quantified ones.
@@ -364,6 +375,16 @@ All this is done:
reporting errors, we avoid that happening.
See also #18062, #11506
+
+Note [floatKindEqualities vs approximateWC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+floatKindEqualities and approximateWC are strikingly similar to each
+other, but
+
+* floatKindEqualites tries to float /all/ equalities, and fails if
+ it can't, or if any implication is insoluble.
+* approximateWC just floats out any constraints
+ (not just equalities) that can float; it never fails.
-}
@@ -1928,7 +1949,7 @@ checkBadTelescope :: Implication -> TcS Bool
-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint
checkBadTelescope (Implic { ic_info = info
, ic_skols = skols })
- | ForAllSkol {} <- info
+ | checkTelescopeSkol info
= do{ skols <- mapM TcS.zonkTyCoVarKind skols
; return (go emptyVarSet (reverse skols))}
@@ -2237,6 +2258,7 @@ defaultTyVarTcS the_tv
approximateWC :: Bool -> WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts
-- See Note [ApproximateWC]
+-- See Note [floatKindEqualities vs approximateWC]
approximateWC float_past_equalities wc
= float_wc emptyVarSet wc
where
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 924996edfdd8..5bd83982f1ce 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -2145,7 +2145,7 @@ canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
| otherwise -- For some reason (occurs check, or forall) we can't unify
-- We must not use it for further rewriting!
- = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
+ = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs $$ ppr mtvu)
; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
; let status | isInsolubleOccursCheck eq_rel tv1 rhs
= InsolubleCIS
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 3983113554c0..38fc88407cac 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -38,6 +38,8 @@ import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.Unify( emitResidualTvConstraint )
+import GHC.Tc.Types.Constraint( emptyWC )
import GHC.Tc.Validity
import GHC.Tc.Utils.Zonk
import GHC.Tc.TyCl.Utils
@@ -755,7 +757,9 @@ swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]
swizzleTcTyConBndrs tc_infos
| all no_swizzle swizzle_prs
-- This fast path happens almost all the time
- -- See Note [Non-cloning for tyvar binders] in GHC.Tc.Gen.HsType
+ -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType
+ -- "Almost all the time" means not the case of mutual recursion with
+ -- polymorphic kinds.
= do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos))
; return tc_infos }
@@ -1560,11 +1564,9 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM_ kc_sig) sigs }
where
- kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty
+ kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty
kc_sig _ = return ()
- skol_info = TyConSkol ClassFlavour name
-
kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-- closed type families look at their equations, but other families don't
-- do anything here
@@ -1636,8 +1638,8 @@ kcConDecl new_or_data res_kind (ConDeclH98
}
kcConDecl new_or_data res_kind (ConDeclGADT
- { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt
- , con_g_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })
+ { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt
+ , con_g_args = args, con_res_ty = res_ty })
= -- Even though the GADT-style data constructor's type is closed,
-- we must still kind-check the type, because that may influence
-- the inferred kind of the /type/ constructor. Example:
@@ -1646,9 +1648,8 @@ kcConDecl new_or_data res_kind (ConDeclGADT
-- If we don't look at MkT we won't get the correct kind
-- for the type constructor T
addErrCtxt (dataConCtxtName names) $
- discardResult $
- bindImplicitTKBndrs_Tv implicit_tkv_nms $
- bindExplicitTKBndrs_Tv explicit_tkv_nms $
+ discardResult $
+ bindOuterSigTKBndrs_Tv outer_bndrs $
-- Why "_Tv"? See Note [Kind-checking for GADTs]
do { _ <- tcHsMbContext cxt
; kcConGADTArgs new_or_data res_kind args
@@ -2437,11 +2438,10 @@ tcDefaultAssocDecl _ (d1:_:_)
tcDefaultAssocDecl fam_tc
[L loc (TyFamInstDecl { tfid_eqn =
- HsIB { hsib_ext = imp_vars
- , hsib_body = FamEqn { feqn_tycon = L _ tc_name
- , feqn_bndrs = mb_expl_bndrs
+ FamEqn { feqn_tycon = L _ tc_name
+ , feqn_bndrs = outer_bndrs
, feqn_pats = hs_pats
- , feqn_rhs = hs_rhs_ty }}})]
+ , feqn_rhs = hs_rhs_ty }})]
= -- See Note [Type-checking default assoc decls]
setSrcSpan loc $
tcAddFamInstCtxt (text "default type instance") tc_name $
@@ -2465,8 +2465,7 @@ tcDefaultAssocDecl fam_tc
-- type default LHS can mention *different* type variables than the
-- enclosing class. So it's treated more as a freestanding beast.
; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated
- imp_vars (mb_expl_bndrs `orElse` [])
- hs_pats hs_rhs_ty
+ outer_bndrs hs_pats hs_rhs_ty
; let fam_tvs = tyConTyVars fam_tc
; traceTc "tcDefaultAssocDecl 2" (vcat
@@ -2845,17 +2844,15 @@ kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
-- Used for the equations of a closed type family only
-- Not used for data/type instances
kcTyFamInstEqn tc_fam_tc
- (L loc (HsIB { hsib_ext = imp_vars
- , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name
- , feqn_bndrs = mb_expl_bndrs
- , feqn_pats = hs_pats
- , feqn_rhs = hs_rhs_ty }}))
+ (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name
+ , feqn_bndrs = outer_bndrs
+ , feqn_pats = hs_pats
+ , feqn_rhs = hs_rhs_ty }))
= setSrcSpan loc $
do { traceTc "kcTyFamInstEqn" (vcat
[ text "tc_name =" <+> ppr eqn_tc_name
, text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
- , text "hsib_vars =" <+> ppr imp_vars
- , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
+ , text "feqn_bndrs =" <+> ppr outer_bndrs
, text "feqn_pats =" <+> ppr hs_pats ])
-- this check reports an arity error instead of a kind error; easier for user
; let vis_pats = numVisibleArgs hs_pats
@@ -2871,8 +2868,7 @@ kcTyFamInstEqn tc_fam_tc
wrongNumberOfParmsErr vis_arity
; discardResult $
- bindImplicitTKBndrs_Q_Tv imp_vars $
- bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
+ bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $
do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }
-- Why "_Tv" here? Consider (#14066
@@ -2892,13 +2888,12 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-- (typechecked here) have TyFamInstEqns
tcTyFamInstEqn fam_tc mb_clsinfo
- (L loc (HsIB { hsib_ext = imp_vars
- , hsib_body = FamEqn { feqn_bndrs = mb_expl_bndrs
- , feqn_pats = hs_pats
- , feqn_rhs = hs_rhs_ty }}))
+ (L loc (FamEqn { feqn_bndrs = outer_bndrs
+ , feqn_pats = hs_pats
+ , feqn_rhs = hs_rhs_ty }))
= setSrcSpan loc $
do { traceTc "tcTyFamInstEqn" $
- vcat [ ppr fam_tc <+> ppr hs_pats
+ vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats
, text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
, case mb_clsinfo of
NotAssociated {} -> empty
@@ -2914,24 +2909,15 @@ tcTyFamInstEqn fam_tc mb_clsinfo
; checkTc (vis_pats == vis_arity) $
wrongNumberOfParmsErr vis_arity
; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo
- imp_vars (mb_expl_bndrs `orElse` [])
- hs_pats hs_rhs_ty
+ outer_bndrs hs_pats hs_rhs_ty
-- Don't print results they may be knot-tied
-- (tcFamInstEqnGuts zonks to Type)
; return (mkCoAxBranch qtvs [] [] pats rhs_ty
(map (const Nominal) qtvs)
loc) }
-{-
-Kind check type patterns and kind annotate the embedded type variables.
- type instance F [a] = rhs
-
- * Here we check that a type instance matches its kind signature, but we do
- not check whether there is a pattern for each type index; the latter
- check is only required for type synonym instances.
-
-Note [Instantiating a family tycon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Instantiating a family tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's possible that kind-checking the result of a family tycon applied to
its patterns will instantiate the tycon further. For example, we might
have
@@ -2960,19 +2946,30 @@ We want to quantify over all the free vars of the LHS including
such as Proxy
* wildcards such as '_' above
-So, the simple thing is
- - Gather candidates from the LHS
- - Include any user-specified forall'd variables, so that we get an
- error from Validity.checkFamPatBinders if a forall'd variable is
- not bound on the LHS
- - Quantify over them
+The wildcards are particularly awkward: they may need to be quantified
+ - before the explicit variables k,a,b
+ - after them
+ - or even interleaved with them
+ c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType
+
+So, we use bindOuterFamEqnTKBndrs (which does not create an implication for
+the telescope), and generalise over /all/ the variables in the LHS,
+without treating the explicitly-quanfitifed ones specially. Wrinkles:
+
+ - When generalising, include the explicit user-specified forall'd
+ variables, so that we get an error from Validity.checkFamPatBinders
+ if a forall'd variable is not bound on the LHS
-Note that, unlike a type signature like
- f :: forall (a::k). blah
-we do /not/ care about the Inferred/Specified designation
-or order for the final quantified tyvars. Type-family
-instances are not invoked directly in Haskell source code,
-so visible type application etc plays no role.
+ - We still want to complain about a bad telescope among the user-specified
+ variables. So in checkFamTelescope we emit an implication constraint
+ quantifying only over them, purely so that we get a good telescope error.
+
+ - Note that, unlike a type signature like
+ f :: forall (a::k). blah
+ we do /not/ care about the Inferred/Specified designation or order for
+ the final quantified tyvars. Type-family instances are not invoked
+ directly in Haskell source code, so visible type application etc plays
+ no role.
See also Note [Re-quantify type variables in rules] in
GHC.Tc.Gen.Rule, which explains a /very/ similar design when
@@ -2982,12 +2979,12 @@ generalising over the type of a rewrite rule.
--------------------------
tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
- -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicit binder
+ -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders
-> HsTyPats GhcRn -- Patterns
-> LHsType GhcRn -- RHS
-> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs)
-- Used only for type families, not data families
-tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
+tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
= do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc)
-- By now, for type families (but not data families) we should
@@ -2995,10 +2992,9 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
-- This code is closely related to the code
-- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk
- ; (tclvl, wanted, (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))))
+ ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty)))
<- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $
- bindImplicitTKBndrs_Q_Skol imp_vars $
- bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+ bindOuterFamEqnTKBndrs outer_hs_bndrs $
do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
-- Ensure that the instance is consistent with its
-- parent class (#16008)
@@ -3013,9 +3009,10 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
-- check there too!
-- See Note [Generalising in tcTyFamInstEqnGuts]
- ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys (imp_tvs ++ exp_tvs))
+ ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs)
; qtvs <- quantifyTyVars dvs
; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted
+ ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs
; traceTc "tcTyFamInstEqnGuts 2" $
vcat [ ppr fam_tc
@@ -3033,6 +3030,22 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)
; return (qtvs, pats, rhs_ty) }
+
+checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn
+ -> [TcTyVar] -> TcM ()
+-- Emit a constraint (forall a b c. <empty>), so that
+-- we will do telescope-checking on a,b,c
+-- See Note [Generalising in tcTyFamInstEqnGuts]
+checkFamTelescope tclvl hs_outer_bndrs outer_tvs
+ | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs
+ , (b_first : _) <- bndrs
+ , let b_last = last bndrs
+ skol_info = ForAllSkol (fsep (map ppr bndrs))
+ = setSrcSpan (combineSrcSpans (getLoc b_first) (getLoc b_last)) $
+ emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC
+ | otherwise
+ = return ()
+
-----------------
unravelFamInstPats :: TcType -> [TcType]
-- Decompose fam_app to get the argument patterns
@@ -3218,8 +3231,8 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])
; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))
- <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $
- bindExplicitTKBndrs_Skol explicit_tkv_nms $
+ <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $
+ tcExplicitTKBndrs explicit_tkv_nms $
do { ctxt <- tcHsMbContext hs_ctxt
; let exp_kind = getArgExpKind new_or_data res_kind
; btys <- tcConH98Args exp_kind hs_args
@@ -3248,7 +3261,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
; kvs <- kindGeneralizeAll fake_ty
- ; let skol_tvs = kvs ++ tmpl_tvs ++ binderVars exp_tvbndrs
+ ; let skol_tvs = kvs ++ tmpl_tvs
; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted
-- Zonk to Types
@@ -3289,19 +3302,17 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
-- NB: don't use res_kind here, as it's ill-scoped. Instead,
-- we get the res_kind by typechecking the result type.
- (ConDeclGADT { con_g_ext = implicit_tkv_nms
- , con_names = names
- , con_qvars = explicit_tkv_nms
+ (ConDeclGADT { con_names = names
+ , con_bndrs = L _ outer_hs_bndrs
, con_mb_cxt = cxt, con_g_args = hs_args
, con_res_ty = hs_res_ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1 gadt" (ppr names)
; let (L _ name : _) = names
- ; (tclvl, wanted, (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))))
+ ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
<- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $
- bindImplicitTKBndrs_Skol implicit_tkv_nms $
- bindExplicitTKBndrs_Skol explicit_tkv_nms $
+ tcOuterTKBndrs skol_info outer_hs_bndrs $
do { ctxt <- tcHsMbContext cxt
; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
-- See Note [GADT return kinds]
@@ -3314,19 +3325,17 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
; field_lbls <- lookupConstructorFields name
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
}
- ; imp_tvs <- zonkAndScopedSort imp_tvs
- ; let con_ty = mkSpecForAllTys imp_tvs $
- mkInvisForAllTys exp_tvbndrs $
- mkPhiTy ctxt $
- mkVisFunTys arg_tys $
- res_ty
- ; kvs <- kindGeneralizeAll con_ty
- ; let tvbndrs = mkTyVarBinders InferredSpec kvs
- ++ mkTyVarBinders SpecifiedSpec imp_tvs
- ++ exp_tvbndrs
+ ; outer_tv_bndrs <- scopedSortOuter outer_bndrs
+
+ ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $
+ mkPhiTy ctxt $
+ mkVisFunTys arg_tys $
+ res_ty)
+ ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)
+ ; reportUnsolvedEqualities skol_info tkvs tclvl wanted
- ; reportUnsolvedEqualities skol_info (binderVars tvbndrs) tclvl wanted
+ ; let tvbndrs = mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs
-- Zonk to Types
; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs
@@ -4825,8 +4834,7 @@ tcAddTyFamInstCtxt decl
= tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
-tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
- HsIB { hsib_body = eqn }})
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = eqn })
= tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
(unLoc (feqn_tycon eqn))
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 92be85fa06b2..8e637a1a32f9 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -157,16 +157,14 @@ tcClassSigs clas sigs def_methods
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
- skol_info = TyConSkol ClassFlavour clas
-
tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
- ; op_ty <- tcClassSigType skol_info op_names op_hs_ty
+ ; op_ty <- tcClassSigType op_names op_hs_ty
-- Class tyvars already in scope
- ; traceTc "ClsSig 2" (ppr op_names)
+ ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty)
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
@@ -174,7 +172,7 @@ tcClassSigs clas sigs def_methods
| otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
- = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
+ = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
{-
@@ -290,7 +288,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty
local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
- , sig_loc = getLoc (hsSigType hs_ty) }
+ , sig_loc = getLoc hs_ty }
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars [this_dict] $
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index cc47d1e34850..2c52a892482a 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -531,7 +531,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
- ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))
+ ; dfun_name <- newDFunName clas inst_tys (getLoc hs_ty)
-- Dfun location is that of instance *header*
; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
@@ -559,7 +559,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
`unionNameSet`
mkNameSet (map (unLoc . feqn_tycon
- . hsib_body
. dfid_eqn
. unLoc) adts)
@@ -583,7 +582,7 @@ tcTyFamInstDecl :: AssocInstInfo
tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
= setSrcSpan loc $
tcAddTyFamInstCtxt decl $
- do { let fam_lname = feqn_tycon (hsib_body eqn)
+ do { let fam_lname = feqn_tycon eqn
; fam_tc <- tcLookupLocatedTyCon fam_lname
; tcFamInstDeclChecks mb_clsinfo fam_tc
@@ -592,10 +591,11 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group
+ -- For some reason we don't have a location for the equation
+ -- itself, so we make do with the location of family name
; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
(L (getLoc fam_lname) eqn)
-
-- (2) check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
; checkValidCoAxBranch fam_tc co_ax_branch
@@ -665,9 +665,8 @@ tcDataFamInstDecl ::
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
-- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo tv_skol_env
- (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars
- , hsib_body =
- FamEqn { feqn_bndrs = mb_bndrs
+ (L loc decl@(DataFamInstDecl { dfid_eqn =
+ FamEqn { feqn_bndrs = outer_bndrs
, feqn_pats = hs_pats
, feqn_tycon = lfam_name@(L _ fam_name)
, feqn_fixity = fixity
@@ -676,7 +675,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
, dd_ctxt = hs_ctxt
, dd_cons = hs_cons
, dd_kindSig = m_ksig
- , dd_derivs = derivs } }}}))
+ , dd_derivs = derivs } }}))
= setSrcSpan loc $
tcAddDataFamInstCtxt decl $
do { fam_tc <- tcLookupLocatedTyCon lfam_name
@@ -689,7 +688,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
-- Do /not/ check that the number of patterns = tyConArity fam_tc
-- See [Arity of data families] in GHC.Core.FamInstEnv
; (qtvs, pats, res_kind, stupid_theta)
- <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs
+ <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs
fixity hs_ctxt hs_pats m_ksig hs_cons
new_or_data
@@ -856,7 +855,7 @@ TyVarEnv will simply be empty, and there is nothing to worry about.
-----------------------
tcDataFamInstHeader
- :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr () GhcRn]
+ :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity -> LHsContext GhcRn
-> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
-> NewOrData
@@ -865,13 +864,12 @@ tcDataFamInstHeader
-- the data constructors themselves
-- e.g. data instance D [a] :: * -> * where ...
-- Here the "header" is the bit before the "where"
-tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
+tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity
hs_ctxt hs_pats m_ksig hs_cons new_or_data
= do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)
- ; (tclvl, wanted, (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))))
+ ; (tclvl, wanted, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))
<- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $
- bindImplicitTKBndrs_Q_Skol imp_vars $
- bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+ bindOuterFamEqnTKBndrs outer_bndrs $
do { stupid_theta <- tcHsContext hs_ctxt
; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
; (lhs_applied_ty, lhs_applied_kind)
@@ -909,7 +907,7 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
-- check there too!
-- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]
- ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys (imp_tvs ++ exp_tvs))
+ ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
; qtvs <- quantifyTyVars dvs
; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted
@@ -937,9 +935,8 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
; return (qtvs, pats, master_res_kind, stupid_theta) }
where
- fam_name = tyConName fam_tc
- data_ctxt = DataKindCtxt fam_name
- exp_bndrs = mb_bndrs `orElse` []
+ fam_name = tyConName fam_tc
+ data_ctxt = DataKindCtxt fam_name
-- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, wrinkle (2).
tc_kind_sig Nothing
@@ -952,8 +949,8 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
-- See Note [Result kind signature for a data family instance]
tc_kind_sig (Just hs_kind)
= do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
- ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
; lvl <- getTcLevel
+ ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs
-- Perhaps surprisingly, we don't need the skolemised tvs themselves
; return (substTy subst inner_kind) }
@@ -1802,7 +1799,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-- There is a signature in the instance
-- See Note [Instance method signatures]
= do { (sig_ty, hs_wrap)
- <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
+ <- setSrcSpan (getLoc hs_sig_ty) $
do { inst_sigs <- xoptM LangExt.InstanceSigs
; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
@@ -1823,7 +1820,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
inner_meth_id = mkLocalId inner_meth_name Many sig_ty
inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
, sig_ctxt = ctxt
- , sig_loc = getLoc (hsSigType hs_sig_ty) }
+ , sig_loc = getLoc hs_sig_ty }
; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 014a5027a4e4..3f5b10f34324 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -24,6 +24,7 @@ import GHC.Hs
import GHC.Tc.Gen.Pat
import GHC.Core.Multiplicity
import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
+import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )
import GHC.Tc.Utils.Env
@@ -61,7 +62,7 @@ import GHC.Utils.Misc
import GHC.Utils.Error
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
-import Data.List( partition )
+import Data.List( partition, mapAccumL )
#include "HsVersions.h"
@@ -345,24 +346,24 @@ tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
, psb_def = lpat, psb_dir = dir }
TPSI{ patsig_implicit_bndrs = implicit_bndrs
- , patsig_univ_bndrs = explicit_univ_bndrs, patsig_prov = prov_theta
- , patsig_ex_bndrs = explicit_ex_bndrs, patsig_req = req_theta
+ , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta
+ , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta
, patsig_body_ty = sig_body_ty }
= addPatSynCtxt lname $
- do { let decl_arity = length arg_names
- (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
-
- ; traceTc "tcCheckPatSynDecl" $
+ do { traceTc "tcCheckPatSynDecl" $
vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta
, ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ]
+ ; let decl_arity = length arg_names
+ (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+
; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
Right stuff -> return stuff
Left missing -> wrongNumberOfParmsErr name decl_arity missing
-- Complain about: pattern P :: () => forall x. x -> P x
-- The existential 'x' should not appear in the result type
- -- Can't check this until we know P's arity
+ -- Can't check this until we know P's arity (decl_arity above)
; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
; checkTc (null bad_tvs) $
hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
@@ -379,36 +380,55 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
univ_tvs = binderVars univ_bndrs
ex_tvs = binderVars ex_bndrs
+ -- Skolemise the quantified type variables. This is necessary
+ -- in order to check the actual pattern type against the
+ -- expected type. Even though the tyvars in the type are
+ -- already skolems, this step changes their TcLevels,
+ -- avoiding level-check errors when unifying.
+ ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs
+ ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_subst0 ex_bndrs
+ ; let skol_univ_tvs = binderVars skol_univ_bndrs
+ skol_ex_tvs = binderVars skol_ex_bndrs
+ skol_req_theta = substTheta skol_subst0 req_theta
+ skol_prov_theta = substTheta skol_subst prov_theta
+ skol_arg_tys = substTys skol_subst (map scaledThing arg_tys)
+ skol_pat_ty = substTy skol_subst pat_ty
+
+ univ_tv_prs = [ (getName orig_univ_tv, skol_univ_tv)
+ | (orig_univ_tv, skol_univ_tv) <- univ_tvs `zip` skol_univ_tvs ]
+
-- Right! Let's check the pattern against the signature
-- See Note [Checking against a pattern signature]
- ; req_dicts <- newEvVars req_theta
+ ; req_dicts <- newEvVars skol_req_theta
; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
pushLevelAndCaptureConstraints $
- tcExtendTyVarEnv univ_tvs $
- tcCheckPat PatSyn lpat (unrestricted pat_ty) $
- do { let in_scope = mkInScopeSet (mkVarSet univ_tvs)
+ tcExtendNameTyVarEnv univ_tv_prs $
+ tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $
+ do { let in_scope = mkInScopeSet (mkVarSet skol_univ_tvs)
empty_subst = mkEmptyTCvSubst in_scope
- ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
+ ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
-- newMetaTyVarX: see the "Existential type variables"
-- part of Note [Checking against a pattern signature]
; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
- ; let prov_theta' = substTheta subst prov_theta
+ ; let prov_theta' = substTheta inst_subst skol_prov_theta
-- Add univ_tvs to the in_scope set to
-- satisfy the substitution invariant. There's no need to
-- add 'ex_tvs' as they are already in the domain of the
-- substitution.
-- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
- ; args' <- zipWithM (tc_arg subst) arg_names (map scaledThing arg_tys)
+ ; args' <- zipWithM (tc_arg inst_subst) arg_names
+ skol_arg_tys
; return (ex_tvs', prov_dicts, args') }
; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
-- The type here is a bit bogus, but we do not print
-- the type for PatSynCtxt, so it doesn't matter
-- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"
- ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
+ ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs
+ req_dicts wanted
-- Solve the constraints now, because we are about to make a PatSyn,
-- which should not contain unification variables and the like (#10997)
@@ -419,11 +439,12 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-- when that should be impossible
; traceTc "tcCheckPatSynDecl }" $ ppr name
+
; tc_patsyn_finish lname dir is_infix lpat'
- (univ_bndrs, req_theta, ev_binds, req_dicts)
- (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
- (args', map scaledThing arg_tys)
- pat_ty rec_fields }
+ (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
+ (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
+ (args', skol_arg_tys)
+ skol_pat_ty rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
-- Look up the variable actually bound by lpat
@@ -440,13 +461,50 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
do { arg_id <- tcLookupId arg_name
; wrap <- tcSubTypeSigma GenSigCtxt
(idType arg_id)
- (substTyUnchecked subst arg_ty)
+ (substTy subst arg_ty)
-- Why do we need tcSubType here?
-- See Note [Pattern synonyms and higher rank types]
; return (mkLHsWrap wrap $ nlHsVar arg_id) }
-{- [Pattern synonyms and higher rank types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag]
+ -> TcM (TCvSubst, [VarBndr TcTyVar flag])
+-- Make new TcTyVars, all skolems with levels, but do not clone
+-- The level is one level deeper than the current level
+-- See Note [Skolemising when checking a pattern synonym]
+skolemiseTvBndrsX orig_subst tvs
+ = do { tc_lvl <- getTcLevel
+ ; let pushed_lvl = pushTcLevel tc_lvl
+ details = SkolemTv pushed_lvl False
+
+ mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag
+ -> (TCvSubst, VarBndr TcTyVar flag)
+ mk_skol_tv_x subst (Bndr tv flag)
+ = (subst', Bndr new_tv flag)
+ where
+ new_kind = substTyUnchecked subst (tyVarKind tv)
+ new_tv = mkTcTyVar (tyVarName tv) new_kind details
+ subst' = extendTvSubstWithClone subst tv new_tv
+
+ ; return (mapAccumL mk_skol_tv_x orig_subst tvs) }
+
+{- Note [Skolemising when checking a pattern synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ pattern P1 :: forall a. a -> Maybe a
+ pattern P1 x <- Just x where
+ P1 x = Just (x :: a)
+
+The scoped type variable 'a' scopes over the builder RHS, Just (x::a).
+But the builder RHS is typechecked much later in tcPatSynBuilderBind,
+and gets its scoped type variables from the type of the builder_id.
+The easiest way to achieve this is not to clone when skolemising.
+
+Hence a special-purpose skolemiseTvBndrX here, similar to
+GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter
+does cloning.
+
+[Pattern synonyms and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT (forall a. a->a)
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 71f628aa3a18..308569ace099 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -35,7 +35,7 @@ module GHC.Tc.Types.Constraint (
isDroppableCt, insolubleImplic,
arisesFromGivens,
- Implication(..), implicationPrototype,
+ Implication(..), implicationPrototype, checkTelescopeSkol,
ImplicStatus(..), isInsolubleStatus, isSolvedStatus,
SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
bumpSubGoalDepth, subGoalDepthExceeded,
@@ -1176,8 +1176,8 @@ data ImplicStatus
| IC_Insoluble -- At least one insoluble constraint in the tree
- | IC_BadTelescope -- solved, but the skolems in the telescope are out of
- -- dependency order
+ | IC_BadTelescope -- Solved, but the skolems in the telescope are out of
+ -- dependency order. See Note [Checking telescopes]
| IC_Unsolved -- Neither of the above; might go either way
@@ -1207,6 +1207,11 @@ instance Outputable ImplicStatus where
ppr (IC_Solved { ics_dead = dead })
= text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))
+checkTelescopeSkol :: SkolemInfo -> Bool
+-- See Note [Checking telescopes]
+checkTelescopeSkol (ForAllSkol {}) = True
+checkTelescopeSkol _ = False
+
{- Note [Checking telescopes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When kind-checking a /user-written/ type, we might have a "bad telescope"
@@ -1241,7 +1246,7 @@ all at once, creating one implication constraint for the lot:
that binds existentials, where the type of the data constructor is
known to be valid (it in tcConPat), no need for the check.
- So the check is done if and only if ic_info is ForAllSkol
+ So the check is done /if and only if/ ic_info is ForAllSkol.
* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the
original, user-written type variables.
@@ -1251,6 +1256,18 @@ all at once, creating one implication constraint for the lot:
constraint solver a chance to make that bad-telescope test! Hence
the extra guard in emitResidualTvConstraint; see #16247
+* Don't mix up inferred and explicit variables in the same implication
+ constraint. E.g.
+ foo :: forall a kx (b :: kx). SameKind a b
+ We want an implication
+ Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }
+ but GHC will attempt to quantify over kx, since it is free in (a::kx),
+ and it's hopelessly confusing to report an error about quantified
+ variables kx (a::kx) kx (b::kx).
+ Instead, the outer quantification over kx should be in a separate
+ implication. TL;DR: an explicit forall should generate an implication
+ quantified only over those explicitly quantified variables.
+
Note [Needed evidence variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Th ic_need_evs field holds the free vars of ic_binds, and all the
@@ -1277,14 +1294,30 @@ worrying that 'b' might clash.
Note [Skolems in an implication]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The skolems in an implication are not there to perform a skolem escape
-check. That happens because all the environment variables are in the
-untouchables, and therefore cannot be unified with anything at all,
-let alone the skolems.
-
-Instead, ic_skols is used only when considering floating a constraint
-outside the implication in GHC.Tc.Solver.floatEqualities or
-GHC.Tc.Solver.approximateImplications
+The skolems in an implication are used:
+
+* When considering floating a constraint outside the implication in
+ GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications
+ For this, we can treat ic_skols as a set.
+
+* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)
+ has its variables in the correct order; see Note [Checking telescopes].
+ Only for these implications does ic_skols need to be a list.
+
+Nota bene: Although ic_skols is a list, it is not necessarily
+in dependency order:
+- In the ic_info=ForAllSkol case, the user might have written them
+ in the wrong order
+- In the case of a type signature like
+ f :: [a] -> [b]
+ the renamer gathers the implicit "outer" forall'd variables {a,b}, but
+ does not know what order to put them in. The type checker can sort them
+ into dependency order, but only after solving all the kind constraints;
+ and to do that it's convenient to create the Implication!
+
+So we accept that ic_skols may be out of order. Think of it as a set or
+(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly
+wrong, order.
Note [Insoluble constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index d836b8d94703..b47d4319ddec 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -184,7 +184,6 @@ data SkolemInfo
-- hence, we have less info
| ForAllSkol -- Bound by a user-written "forall".
- SDoc -- Shows the entire forall type
SDoc -- Shows just the binders, used when reporting a bad telescope
-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint
@@ -244,7 +243,7 @@ pprSkolInfo :: SkolemInfo -> SDoc
-- Complete the sentence "is a rigid type variable bound by..."
pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx
-pprSkolInfo (ForAllSkol pt _) = quotes pt
+pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> tvs
pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for"
<+> pprWithCommas ppr ips
pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred)
@@ -304,7 +303,7 @@ For pattern synonym SkolemInfo we have
but the type 'ty' is not very helpful. The full pattern-synonym type
has the provided and required pieces, which it is inconvenient to
record and display here. So we simply don't display the type at all,
-contenting outselves with just the name of the pattern synonym, which
+contenting ourselves with just the name of the pattern synonym, which
is fine. We could do more, but it doesn't seem worth it.
Note [SigSkol SkolemInfo]
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 61d0cdcd476b..199fb57cc673 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -734,8 +734,8 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
- get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
+ get_fi_cons (DataFamInstDecl { dfid_eqn =
+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }})
= map unLoc $ concatMap (getConNames . unLoc) cons
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 6940d161d6f6..c2140f7deb7c 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -491,7 +491,7 @@ tcInstTypeBndrs id
tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type signature with skolem constants.
--- We could give them fresh names, but no need to do so
+-- This freshens the names, but no need to do so
tcSkolDFunType dfun
= do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
; return (map snd tv_prs, theta, tau) }
@@ -523,13 +523,18 @@ tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
-- See Note [Skolemising type variables]
+-- This version freshens the names and creates "super skolems";
+-- see comments around superSkolemTv.
tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
-- See Note [Skolemising type variables]
+-- This version freshens the names and creates "super skolems";
+-- see comments around superSkolemTv.
tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
-tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
+tcInstSkolTyVarsPushLevel :: Bool -- True <=> make "super skolem"
+ -> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
-- Skolemise one level deeper, hence pushTcLevel
-- See Note [Skolemising type variables]
@@ -598,10 +603,22 @@ a) Level allocation. We generally skolemise /before/ calling
b) The [TyVar] should be ordered (kind vars first)
See Note [Kind substitution when instantiating]
-c) It's a complete freshening operation: the skolems have a fresh
- unique, and a location from the monad
-
-d) The resulting skolems are
+c) Clone the variable to give a fresh unique. This is essential.
+ Consider (tc160)
+ type Foo x = forall a. a -> x
+ And typecheck the expression
+ (e :: Foo (Foo ())
+ We will skolemise the signature, but after expanding synonyms it
+ looks like
+ forall a. a -> forall a. a -> x
+ We don't want to make two big-lambdas with the same unique!
+
+d) We retain locations. Because the location of the variable is the correct
+ location to report in errors (e.g. in the signature). We don't want the
+ location to change to the body of the function, which does *not* explicitly
+ bind the variable.
+
+e) The resulting skolems are
non-overlappable for tcInstSkolTyVars,
but overlappable for tcInstSuperSkolTyVars
See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index a040cca093b9..de3c4aeb012c 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1845,8 +1845,8 @@ It's distressingly delicate though:
the visible type application fails in the monad (throws an exception).
We must not discard the out-of-scope error.
- Also GHC.Tc.Solver.emitFlatConstraints may fail having emitted some
- constraints with skolem-escape problems.
+ Also GHC.Tc.Solver.simplifyAndEmitFlatConstraints may fail having
+ emitted some constraints with skolem-escape problems.
* If we discard too /few/ constraints, we may get the misleading
class constraints mentioned above. But we may /also/ end up taking
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index d704bcbf8f7c..4b0a5f8fdd62 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -927,13 +927,18 @@ checkTvConstraints skol_info skol_tvs thing_inside
emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]
-> TcLevel -> WantedConstraints -> TcM ()
emitResidualTvConstraint skol_info skol_tvs tclvl wanted
- | isEmptyWC wanted
- = return ()
-
- | otherwise
- = do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted
+ | not (isEmptyWC wanted) ||
+ checkTelescopeSkol skol_info
+ = -- checkTelescopeSkol: in this case, /always/ emit this implication
+ -- even if 'wanted' is empty. We need the implication so that we check
+ -- for a bad telescope. See Note [Skolem escape and forall-types] in
+ -- GHC.Tc.Gen.HsType
+ do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted
; emitImplication implic }
+ | otherwise -- Empty 'wanted', emit nothing
+ = return ()
+
buildTvImplication :: SkolemInfo -> [TcTyVar]
-> TcLevel -> WantedConstraints -> TcM Implication
buildTvImplication skol_info skol_tvs tclvl wanted
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 5f08249e385a..68ef82785d84 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -2855,7 +2855,7 @@ at all in the kind -- after all, it is Specified so it must have
occurred. (It /used/ to be possible; see tests T13983 and T7873. But
with the advent of the forall-or-nothing rule for kind variables,
those strange cases went away. See Note [forall-or-nothing rule] in
-GHC.Rename.HsType.)
+GHC.Hs.Type.)
But one might worry about
type v k = *
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 26325cf7bc85..57b56964394c 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -191,14 +191,14 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
- ; ty' <- cvtType typ
+ ; ty' <- cvtSigType typ
; returnJustL $ Hs.SigD noExtField
- (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }
+ (TypeSig noExtField [nm'] (mkHsWildCardBndrs ty')) }
cvtDec (TH.KiSigD nm ki)
= do { nm' <- tconNameL nm
- ; ki' <- cvtType ki
- ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')
+ ; ki' <- cvtSigKind ki
+ ; let sig' = StandaloneKindSig noExtField nm' ki'
; returnJustL $ Hs.KindSigD noExtField sig' }
cvtDec (TH.InfixD fx nm)
@@ -289,9 +289,10 @@ cvtDec (InstanceD o ctxt ty decs)
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext funPrec ctxt
; (L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
+ ; let inst_ty' = L loc $ mkHsImplicitSigType $
+ mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustL $ InstD noExtField $ ClsInstD noExtField $
- ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'
+ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
@@ -330,7 +331,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
; returnJustL $ InstD noExtField $ DataFamInstD
{ dfid_ext = noExtField
- , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+ , dfid_inst = DataFamInstDecl { dfid_eqn =
FamEqn { feqn_ext = noExtField
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
@@ -350,7 +351,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
, dd_cons = [con'], dd_derivs = derivs' }
; returnJustL $ InstD noExtField $ DataFamInstD
{ dfid_ext = noExtField
- , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+ , dfid_inst = DataFamInstDecl { dfid_eqn =
FamEqn { feqn_ext = noExtField
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
@@ -386,18 +387,19 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext funPrec cxt
; ds' <- traverse cvtDerivStrategy ds
; (L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
+ ; let inst_ty' = L loc $ mkHsImplicitSigType $
+ mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD noExtField $
DerivDecl { deriv_ext =noExtField
, deriv_strategy = ds'
- , deriv_type = mkLHsSigWcType inst_ty'
+ , deriv_type = mkHsWildCardBndrs inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
- ; ty' <- cvtType typ
+ ; ty' <- cvtSigType typ
; returnJustL $ Hs.SigD noExtField
- $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}
+ $ ClassOpSig noExtField True [nm'] ty'}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
@@ -424,7 +426,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
- ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}
+ ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] ty'}
-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
@@ -436,25 +438,26 @@ cvtDec (TH.ImplicitParamBindD _ _)
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
= do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+ ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs'
; (head_ty, args) <- split_ty_app lhs
; case head_ty of
ConT nm -> do { nm' <- tconNameL nm
; rhs' <- cvtType rhs
; let args' = map wrap_tyarg args
- ; returnL $ mkHsImplicitBndrs
+ ; returnL
$ FamEqn { feqn_ext = noExtField
, feqn_tycon = nm'
- , feqn_bndrs = mb_bndrs'
+ , feqn_bndrs = outer_bndrs
, feqn_pats = args'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
InfixT t1 nm t2 -> do { nm' <- tconNameL nm
; args' <- mapM cvtType [t1,t2]
; rhs' <- cvtType rhs
- ; returnL $ mkHsImplicitBndrs
+ ; returnL
$ FamEqn { feqn_ext = noExtField
, feqn_tycon = nm'
- , feqn_bndrs = mb_bndrs'
+ , feqn_bndrs = outer_bndrs
, feqn_pats =
(map HsValArg args') ++ args
, feqn_fixity = Hs.Infix
@@ -497,19 +500,20 @@ cvt_tycl_hdr cxt tc tvs
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
-> CvtM ( LHsContext GhcPs
, Located RdrName
- , Maybe [LHsTyVarBndr () GhcPs]
+ , HsOuterFamEqnTyVarBndrs GhcPs
, HsTyPats GhcPs)
cvt_datainst_hdr cxt bndrs tys
= do { cxt' <- cvtContext funPrec cxt
; bndrs' <- traverse (mapM cvt_tv) bndrs
+ ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs'
; (head_ty, args) <- split_ty_app tys
; case head_ty of
ConT nm -> do { nm' <- tconNameL nm
; let args' = map wrap_tyarg args
- ; return (cxt', nm', bndrs', args') }
+ ; return (cxt', nm', outer_bndrs, args') }
InfixT t1 nm t2 -> do { nm' <- tconNameL nm
; args' <- mapM cvtType [t1,t2]
- ; return (cxt', nm', bndrs',
+ ; return (cxt', nm', outer_bndrs,
((map HsValArg args') ++ args)) }
_ -> failWith $ text "Invalid type instance header:"
<+> text (show tys) }
@@ -601,12 +605,17 @@ cvtConstr (ForallC tvs ctxt con)
add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
-> ConDecl GhcPs -> ConDecl GhcPs
- add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
- = con { con_forall = noLoc $ not (null all_tvs)
- , con_qvars = all_tvs
+ add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt })
+ = con { con_bndrs = L l outer_bndrs'
, con_mb_cxt = add_cxt cxt' cxt }
where
- all_tvs = tvs' ++ qvars
+ outer_bndrs'
+ | null all_tvs = mkHsOuterImplicit
+ | otherwise = mkHsOuterExplicit all_tvs
+
+ all_tvs = tvs' ++ outer_exp_tvs
+
+ outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs
add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
= con { con_forall = noLoc $ not (null all_tvs)
@@ -638,8 +647,7 @@ mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
mk_gadt_decl names args res_ty
= ConDeclGADT { con_g_ext = noExtField
, con_names = names
- , con_forall = noLoc False
- , con_qvars = []
+ , con_bndrs = noLoc mkHsOuterImplicit
, con_mb_cxt = Nothing
, con_g_args = args
, con_res_ty = res_ty
@@ -707,10 +715,10 @@ cvtForD (ImportF callconv safety from nm ty)
where
mk_imp impspec
= do { nm' <- vNameL nm
- ; ty' <- cvtType ty
+ ; ty' <- cvtSigType ty
; return (ForeignImport { fd_i_ext = noExtField
, fd_name = nm'
- , fd_sig_ty = mkLHsSigType ty'
+ , fd_sig_ty = ty'
, fd_fi = impspec })
}
safety' = case safety of
@@ -720,14 +728,14 @@ cvtForD (ImportF callconv safety from nm ty)
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
- ; ty' <- cvtType ty
+ ; ty' <- cvtSigType ty
; let e = CExport (noLoc (CExportStatic (SourceText as)
(mkFastString as)
(cvt_conv callconv)))
(noLoc (SourceText as))
; return $ ForeignExport { fd_e_ext = noExtField
, fd_name = nm'
- , fd_sig_ty = mkLHsSigType ty'
+ , fd_sig_ty = ty'
, fd_fe = e } }
cvt_conv :: TH.Callconv -> CCallConv
@@ -757,7 +765,7 @@ cvtPragmaD (InlineP nm inline rm phases)
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
- ; ty' <- cvtType ty
+ ; ty' <- cvtSigType ty
; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
src TH.Inline = "{-# SPECIALISE INLINE"
src TH.Inlinable = "{-# SPECIALISE INLINE"
@@ -771,12 +779,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
- ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }
+ ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
- = do { ty' <- cvtType ty
+ = do { ty' <- cvtSigType ty
; returnJustL $ Hs.SigD noExtField $
- SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+ SpecInstSig noExtField (SourceText "{-# SPECIALISE") ty' }
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -1002,9 +1010,9 @@ cvtl e = wrapL (cvt e)
; cvtOpApp x'' s y } -- Note [Converting UInfix]
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' }
- cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
+ cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t
; let pe = parenthesizeHsExpr sigPrec e'
- ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') }
+ ; return $ ExprWithTySig noExtField pe (mkHsWildCardBndrs t') }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -1398,16 +1406,17 @@ cvtPred = cvtType
cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys tys
- = do { tys' <- mapM cvtType tys
+ = do { tys' <- mapM cvtSigType tys
-- Since TH.Cxt doesn't indicate the presence or absence of
-- parentheses in a deriving clause, we have to choose between
-- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
-- unless the TH.Cxt is a singleton list whose type is a bare type
-- constructor with no arguments.
; case tys' of
- [ty'@(L l (HsTyVar _ NotPromoted _))]
- -> return $ L l $ DctSingle noExtField $ mkLHsSigType ty'
- _ -> returnL $ DctMulti noExtField (map mkLHsSigType tys') }
+ [ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{}
+ , sig_body = L _ (HsTyVar _ NotPromoted _) }))]
+ -> return $ L l $ DctSingle noExtField ty'
+ _ -> returnL $ DctMulti noExtField tys' }
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
@@ -1421,12 +1430,23 @@ cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy
cvtDerivStrategy (TH.ViaStrategy ty) = do
- ty' <- cvtType ty
- returnL $ Hs.ViaStrategy (mkLHsSigType ty')
+ ty' <- cvtSigType ty
+ returnL $ Hs.ViaStrategy ty'
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType = cvtTypeKind "type"
+cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
+cvtSigType = cvtSigTypeKind "type"
+
+-- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating
+-- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform
+-- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'.
+cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs)
+cvtSigTypeKind ty_str ty = do
+ ty' <- cvtTypeKind ty_str ty
+ pure $ hsTypeToHsSigType ty'
+
cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind ty_str ty
= do { (head_ty, tys') <- split_ty_app ty
@@ -1726,6 +1746,9 @@ cvtOpAppT x op y
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind = cvtTypeKind "kind"
+cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
+cvtSigKind = cvtSigTypeKind "kind"
+
-- | Convert Maybe Kind to a type family result signature. Used with data
-- families where naming of the result is not possible (thus only kind or no
-- signature is possible).
@@ -1752,30 +1775,28 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
; annRHS' <- mapM tNameL annRHS
; returnL (Hs.InjectivityAnn annLHS' annRHS') }
-cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
+cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
-- them separately from regular types;
-- see Note [Pattern synonym type signatures and Template Haskell]
cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
- | null exis, null provs = cvtType (ForallT univs reqs ty)
+ | null exis, null provs = cvtSigType (ForallT univs reqs ty)
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
- ; return $ L l (HsQualTy { hst_ctxt = L l []
+ ; return $ L l $ mkHsImplicitSigType
+ $ L l (HsQualTy { hst_ctxt = L l []
, hst_xqual = noExtField
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
- ; let forTy = HsForAllTy
- { hst_tele = mkHsForAllInvisTele univs'
- , hst_xforall = noExtField
- , hst_body = L l cxtTy }
+ ; let forTy = mkHsExplicitSigType univs' $ L l cxtTy
cxtTy = HsQualTy { hst_ctxt = L l []
, hst_xqual = noExtField
, hst_body = ty' }
; return $ L l forTy }
- | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
-cvtPatSynSigTy ty = cvtType ty
+ | otherwise = cvtSigType (ForallT univs reqs (ForallT exis provs ty))
+cvtPatSynSigTy ty = cvtSigType ty
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
@@ -1859,6 +1880,9 @@ mkHsQualTy ctxt loc ctxt' ty
, hst_ctxt = ctxt'
, hst_body = ty }
+mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
+mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit mkHsOuterExplicit
+
--------------------------------------------------------------------
-- Turning Name back into RdrName
--------------------------------------------------------------------
diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs
index 8ba0eefb3436..19b0667ceb8e 100644
--- a/compiler/GHC/Utils/Monad.hs
+++ b/compiler/GHC/Utils/Monad.hs
@@ -11,6 +11,7 @@ module GHC.Utils.Monad
, zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM
, mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M
, mapAccumLM
+ , liftFstM, liftSndM
, mapSndM
, concatMapM
, mapMaybeM
@@ -164,6 +165,12 @@ mapSndM f xs = go xs
go [] = return []
go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) }
+liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r)
+liftFstM f thing = do { (a,r) <- thing; return (f a, r) }
+
+liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b)
+liftSndM f thing = do { (r,a) <- thing; return (r, f a) }
+
-- | Monadic version of concatMap
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 2c2b9fc3bb66..025f82fa08b0 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1689,7 +1689,8 @@ defineMacro overwrite s = do
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
`mkHsApp` (nlHsPar expr)
- tySig = mkLHsSigWcType (nlHsFunTy stringTy ioM)
+ tySig = mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType $
+ nlHsFunTy stringTy ioM
new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig
hv <- GHC.compileParsedExprRemote new_expr
@@ -1757,7 +1758,8 @@ getGhciStepIO = do
ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
- tySig = mkLHsSigWcType (nlHsFunTy ghciM ioM)
+ tySig = mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType $
+ nlHsFunTy ghciM ioM
return $ noLoc $ ExprWithTySig noExtField body tySig
-----------------------------------------------------------------------------
diff --git a/testsuite/tests/dependent/should_fail/BadTelescope5.stderr b/testsuite/tests/dependent/should_fail/BadTelescope5.stderr
index d2ec36e5dfbe..02daf9d742e9 100644
--- a/testsuite/tests/dependent/should_fail/BadTelescope5.stderr
+++ b/testsuite/tests/dependent/should_fail/BadTelescope5.stderr
@@ -2,10 +2,9 @@
BadTelescope5.hs:10:81: error:
• Expected kind ‘k’, but ‘d’ has kind ‘Proxy a’
‘k’ is a rigid type variable bound by
- ‘forall a k (b :: k) (c :: Proxy b) (d :: Proxy a).
- Proxy c -> SameKind b d’
+ an explicit forall a k (b :: k) (c :: Proxy b) (d :: Proxy a)
at BadTelescope5.hs:10:17
• In the second argument of ‘SameKind’, namely ‘d’
In the type signature:
- bar :: forall a k (b :: k) (c :: Proxy b) (d :: Proxy a).
- Proxy c -> SameKind b d
+ bar :: forall a k (b :: k) (c :: Proxy b) (d :: Proxy a). Proxy c
+ -> SameKind b d
diff --git a/testsuite/tests/dependent/should_fail/T14066.stderr b/testsuite/tests/dependent/should_fail/T14066.stderr
index d958f9a5192a..240108c29642 100644
--- a/testsuite/tests/dependent/should_fail/T14066.stderr
+++ b/testsuite/tests/dependent/should_fail/T14066.stderr
@@ -3,7 +3,7 @@ T14066.hs:15:59: error:
• Expected kind ‘k0’, but ‘b’ has kind ‘k’
because kind variable ‘k’ would escape its scope
This (rigid, skolem) kind variable is bound by
- ‘forall k (b :: k). SameKind a b’
+ an explicit forall k (b :: k)
at T14066.hs:15:29-59
• In the second argument of ‘SameKind’, namely ‘b’
In the type signature: g :: forall k (b :: k). SameKind a b
diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
index a91909533747..d642d6201c3c 100644
--- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
+++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
@@ -3,7 +3,7 @@ TypeSkolEscape.hs:9:52: error:
• Expected kind ‘k0’, but ‘a’ has kind ‘TYPE v’
because kind variable ‘v’ would escape its scope
This (rigid, skolem) kind variable is bound by
- ‘forall (v :: RuntimeRep) (a :: TYPE v). a’
+ an explicit forall (v :: RuntimeRep) (a :: TYPE v)
at TypeSkolEscape.hs:9:12-52
• In the type ‘forall (v :: RuntimeRep) (a :: TYPE v). a’
In the type declaration for ‘Bad’
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
index 2e5452129b48..2d9cede53c50 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
@@ -39,33 +39,36 @@
[({ T17544.hs:6:3-4 }
(Unqual
{OccName: f1}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:6:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ T17544.hs:6:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:6:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:6:14-16 }
- (HsDocTy
- (NoExtField)
- ({ T17544.hs:6:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:6:14-16 }
- (Unqual
- {OccName: Int}))))
- ({ T17544.hs:7:5-23 }
- (HsDocString
- " comment on Int")))))))))]
+ ({ T17544.hs:6:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:6:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ T17544.hs:6:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:6:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:6:14-16 }
+ (HsDocTy
+ (NoExtField)
+ ({ T17544.hs:6:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:6:14-16 }
+ (Unqual
+ {OccName: Int}))))
+ ({ T17544.hs:7:5-23 }
+ (HsDocString
+ " comment on Int"))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -100,27 +103,30 @@
[({ T17544.hs:10:3-4 }
(Unqual
{OccName: f2}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:10:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ T17544.hs:10:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:10:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:10:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:10:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:10:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:10:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ T17544.hs:10:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:10:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:10:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:10:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -158,27 +164,30 @@
[({ T17544.hs:14:3-4 }
(Unqual
{OccName: f3}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:14:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ T17544.hs:14:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:14:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:14:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:14:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:14:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:14:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ T17544.hs:14:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:14:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:14:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:14:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -219,27 +228,30 @@
[({ T17544.hs:18:3-4 }
(Unqual
{OccName: f4}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:18:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ T17544.hs:18:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:18:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:18:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:18:14-16 }
- (Unqual
- {OccName: Int})))))))))
+ ({ T17544.hs:18:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:18:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ T17544.hs:18:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:18:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:18:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:18:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))
,({ T17544.hs:20:3-16 }
(ClassOpSig
(NoExtField)
@@ -247,27 +259,30 @@
[({ T17544.hs:20:3-4 }
(Unqual
{OccName: g4}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:20:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ T17544.hs:20:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:20:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:20:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:20:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:20:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:20:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ T17544.hs:20:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:20:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:20:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:20:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -327,87 +342,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:23:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:23:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:23:10-11 }
- (Unqual
- {OccName: C5}))))
- ({ T17544.hs:23:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:23:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:23:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:23:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:23:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:23:10-11 }
+ (Unqual
+ {OccName: C5}))))
+ ({ T17544.hs:23:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:23:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(24,3)-(25,18) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:24:8-9 }
+ (Unqual
+ {OccName: D5}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:24:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:24:11-13 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:24:8-9 }
- (Unqual
- {OccName: D5}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:24:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:24:11-13 }
+ [({ T17544.hs:25:5-18 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:25:5-8 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:25:5-18 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:25:5-8 }
- (Unqual
- {OccName: MkD5}))]
- ({ T17544.hs:25:13-18 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:25:13-18 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:25:13-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:25:13-14 }
- (Unqual
- {OccName: D5}))))
- ({ T17544.hs:25:16-18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:25:16-18 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD5}))]
+ ({ T17544.hs:25:13-18 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:25:13-18 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:25:13-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:25:13-14 }
+ (Unqual
+ {OccName: D5}))))
+ ({ T17544.hs:25:16-18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:25:16-18 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:28:1-30 }
(TyClD
@@ -463,87 +480,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:29:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:29:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:29:10-11 }
- (Unqual
- {OccName: C6}))))
- ({ T17544.hs:29:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:29:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:29:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:29:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:29:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:29:10-11 }
+ (Unqual
+ {OccName: C6}))))
+ ({ T17544.hs:29:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:29:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(30,3)-(31,18) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:30:8-9 }
+ (Unqual
+ {OccName: D6}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:30:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:30:11-13 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:30:8-9 }
- (Unqual
- {OccName: D6}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:30:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:30:11-13 }
+ [({ T17544.hs:31:5-18 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:31:5-8 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:31:5-18 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:31:5-8 }
- (Unqual
- {OccName: MkD6}))]
- ({ T17544.hs:31:13-18 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:31:13-18 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:31:13-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:31:13-14 }
- (Unqual
- {OccName: D6}))))
- ({ T17544.hs:31:16-18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:31:16-18 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD6}))]
+ ({ T17544.hs:31:13-18 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:31:13-18 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:31:13-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:31:13-14 }
+ (Unqual
+ {OccName: D6}))))
+ ({ T17544.hs:31:16-18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:31:16-18 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:34:1-30 }
(TyClD
@@ -599,87 +618,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:35:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:35:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:35:10-11 }
- (Unqual
- {OccName: C7}))))
- ({ T17544.hs:35:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:35:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:35:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:35:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:35:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:35:10-11 }
+ (Unqual
+ {OccName: C7}))))
+ ({ T17544.hs:35:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:35:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(36,3)-(37,18) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:36:8-9 }
+ (Unqual
+ {OccName: D7}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:36:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:36:11-13 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:36:8-9 }
- (Unqual
- {OccName: D7}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:36:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:36:11-13 }
+ [({ T17544.hs:37:5-18 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:37:5-8 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:37:5-18 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:37:5-8 }
- (Unqual
- {OccName: MkD7}))]
- ({ T17544.hs:37:13-18 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:37:13-18 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:37:13-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:37:13-14 }
- (Unqual
- {OccName: D7}))))
- ({ T17544.hs:37:16-18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:37:16-18 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD7}))]
+ ({ T17544.hs:37:13-18 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:37:13-18 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:37:13-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:37:13-14 }
+ (Unqual
+ {OccName: D7}))))
+ ({ T17544.hs:37:16-18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:37:16-18 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:40:1-30 }
(TyClD
@@ -735,87 +756,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:41:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:41:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:41:10-11 }
- (Unqual
- {OccName: C8}))))
- ({ T17544.hs:41:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:41:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:41:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:41:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:41:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:41:10-11 }
+ (Unqual
+ {OccName: C8}))))
+ ({ T17544.hs:41:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:41:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(42,3)-(43,18) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:42:8-9 }
+ (Unqual
+ {OccName: D8}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:42:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:42:11-13 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:42:8-9 }
- (Unqual
- {OccName: D8}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:42:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:42:11-13 }
+ [({ T17544.hs:43:5-18 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:43:5-8 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:43:5-18 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:43:5-8 }
- (Unqual
- {OccName: MkD8}))]
- ({ T17544.hs:43:13-18 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:43:13-18 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:43:13-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:43:13-14 }
- (Unqual
- {OccName: D8}))))
- ({ T17544.hs:43:16-18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:43:16-18 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD8}))]
+ ({ T17544.hs:43:13-18 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:43:13-18 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:43:13-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:43:13-14 }
+ (Unqual
+ {OccName: D8}))))
+ ({ T17544.hs:43:16-18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:43:16-18 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:46:1-30 }
(TyClD
@@ -871,87 +894,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:47:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:47:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:47:10-11 }
- (Unqual
- {OccName: C9}))))
- ({ T17544.hs:47:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:47:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:47:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:47:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:47:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:47:10-11 }
+ (Unqual
+ {OccName: C9}))))
+ ({ T17544.hs:47:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:47:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(48,3)-(49,18) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:48:8-9 }
+ (Unqual
+ {OccName: D9}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:48:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:48:11-13 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:48:8-9 }
- (Unqual
- {OccName: D9}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:48:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:48:11-13 }
+ [({ T17544.hs:49:5-18 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:49:5-8 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:49:5-18 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:49:5-8 }
- (Unqual
- {OccName: MkD9}))]
- ({ T17544.hs:49:13-18 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:49:13-18 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:49:13-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:49:13-14 }
- (Unqual
- {OccName: D9}))))
- ({ T17544.hs:49:16-18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:49:16-18 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD9}))]
+ ({ T17544.hs:49:13-18 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:49:13-18 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:49:13-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:49:13-14 }
+ (Unqual
+ {OccName: D9}))))
+ ({ T17544.hs:49:16-18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:49:16-18 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:52:1-32 }
(TyClD
@@ -1007,87 +1032,89 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:53:10-16 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:53:10-12 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:53:10-12 }
- (Unqual
- {OccName: C10}))))
- ({ T17544.hs:53:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:53:14-16 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:53:10-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:53:10-16 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:53:10-12 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:53:10-12 }
+ (Unqual
+ {OccName: C10}))))
+ ({ T17544.hs:53:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:53:14-16 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
[]
[({ T17544.hs:(54,3)-(55,20) }
(DataFamInstDecl
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
+ ({ T17544.hs:54:8-10 }
+ (Unqual
+ {OccName: D10}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ T17544.hs:54:12-14 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:54:12-14 }
+ (Unqual
+ {OccName: Int})))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ T17544.hs:54:8-10 }
- (Unqual
- {OccName: D10}))
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
(Nothing)
- [(HsValArg
- ({ T17544.hs:54:12-14 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:54:12-14 }
+ [({ T17544.hs:55:5-20 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ T17544.hs:55:5-9 }
(Unqual
- {OccName: Int})))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (DataType)
- ({ <no location info> }
- [])
- (Nothing)
- (Nothing)
- [({ T17544.hs:55:5-20 }
- (ConDeclGADT
- (NoExtField)
- [({ T17544.hs:55:5-9 }
- (Unqual
- {OccName: MkD10}))]
- ({ T17544.hs:55:14-20 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [])
- ({ T17544.hs:55:14-20 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:55:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:55:14-16 }
- (Unqual
- {OccName: D10}))))
- ({ T17544.hs:55:18-20 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:55:18-20 }
- (Unqual
- {OccName: Int}))))))
- (Nothing)))]
- ({ <no location info> }
- []))))))]
+ {OccName: MkD10}))]
+ ({ T17544.hs:55:14-20 }
+ (HsOuterImplicit
+ (NoExtField)))
+ (Nothing)
+ (PrefixConGADT
+ [])
+ ({ T17544.hs:55:14-20 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:55:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:55:14-16 }
+ (Unqual
+ {OccName: D10}))))
+ ({ T17544.hs:55:18-20 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:55:18-20 }
+ (Unqual
+ {OccName: Int}))))))
+ (Nothing)))]
+ ({ <no location info> }
+ [])))))]
(Nothing)))))
,({ T17544.hs:56:1-38 }
(DocD
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
index d1ff09f56c27..b8cb9eedf2be 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
@@ -36,8 +36,8 @@
(Unqual
{OccName: MkFoo}))]
({ T17544_kw.hs:16:18-20 }
- (False))
- []
+ (HsOuterImplicit
+ (NoExtField)))
(Nothing)
(PrefixConGADT
[])
@@ -80,8 +80,8 @@
(Unqual
{OccName: MkBar}))]
({ T17544_kw.hs:19:18-26 }
- (False))
- []
+ (HsOuterImplicit
+ (NoExtField)))
(Nothing)
(PrefixConGADT
[(HsScaled
@@ -134,15 +134,18 @@
[({ T17544_kw.hs:24:5-13 }
(Unqual
{OccName: clsmethod}))]
- (HsIB
- (NoExtField)
- ({ T17544_kw.hs:24:18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544_kw.hs:24:18 }
- (Unqual
- {OccName: a})))))))]
+ ({ T17544_kw.hs:24:18 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544_kw.hs:24:18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544_kw.hs:24:18 }
+ (Unqual
+ {OccName: a}))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index dc48459d1745..31f8b10c2580 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -88,92 +88,90 @@
(ClosedTypeFamily
(Just
[({ DumpParsedAst.hs:10:3-36 }
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
- (NoExtField)
- ({ DumpParsedAst.hs:10:3-8 }
- (Unqual
- {OccName: Length}))
- (Nothing)
- [(HsValArg
- ({ DumpParsedAst.hs:10:10-17 }
- (HsParTy
- (NoExtField)
- ({ DumpParsedAst.hs:10:11-16 }
- (HsOpTy
- (NoExtField)
- ({ DumpParsedAst.hs:10:11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:10:11 }
- (Unqual
- {OccName: a}))))
- ({ DumpParsedAst.hs:10:13 }
- (Exact
- {Name: :}))
- ({ DumpParsedAst.hs:10:15-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:10:15-16 }
- (Unqual
- {OccName: as})))))))))]
- (Prefix)
- ({ DumpParsedAst.hs:10:21-36 }
- (HsAppTy
- (NoExtField)
- ({ DumpParsedAst.hs:10:21-24 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:10:21-24 }
- (Unqual
- {OccName: Succ}))))
- ({ DumpParsedAst.hs:10:26-36 }
- (HsParTy
- (NoExtField)
- ({ DumpParsedAst.hs:10:27-35 }
- (HsAppTy
- (NoExtField)
- ({ DumpParsedAst.hs:10:27-32 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:10:27-32 }
- (Unqual
- {OccName: Length}))))
- ({ DumpParsedAst.hs:10:34-35 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:10:34-35 }
- (Unqual
- {OccName: as})))))))))))))
+ ({ DumpParsedAst.hs:10:3-8 }
+ (Unqual
+ {OccName: Length}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ DumpParsedAst.hs:10:10-17 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:10:11-16 }
+ (HsOpTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:10:11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:10:11 }
+ (Unqual
+ {OccName: a}))))
+ ({ DumpParsedAst.hs:10:13 }
+ (Exact
+ {Name: :}))
+ ({ DumpParsedAst.hs:10:15-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:10:15-16 }
+ (Unqual
+ {OccName: as})))))))))]
+ (Prefix)
+ ({ DumpParsedAst.hs:10:21-36 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:10:21-24 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:10:21-24 }
+ (Unqual
+ {OccName: Succ}))))
+ ({ DumpParsedAst.hs:10:26-36 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:10:27-35 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:10:27-32 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:10:27-32 }
+ (Unqual
+ {OccName: Length}))))
+ ({ DumpParsedAst.hs:10:34-35 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:10:34-35 }
+ (Unqual
+ {OccName: as}))))))))))))
,({ DumpParsedAst.hs:11:3-24 }
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
- (NoExtField)
- ({ DumpParsedAst.hs:11:3-8 }
- (Unqual
- {OccName: Length}))
- (Nothing)
- [(HsValArg
- ({ DumpParsedAst.hs:11:10-12 }
- (HsExplicitListTy
- (NoExtField)
- (IsPromoted)
- [])))]
- (Prefix)
- ({ DumpParsedAst.hs:11:21-24 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:11:21-24 }
- (Unqual
- {OccName: Zero})))))))]))
+ ({ DumpParsedAst.hs:11:3-8 }
+ (Unqual
+ {OccName: Length}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ DumpParsedAst.hs:11:10-12 }
+ (HsExplicitListTy
+ (NoExtField)
+ (IsPromoted)
+ [])))]
+ (Prefix)
+ ({ DumpParsedAst.hs:11:21-24 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:11:21-24 }
+ (Unqual
+ {OccName: Zero}))))))]))
({ DumpParsedAst.hs:9:13-18 }
(Unqual
{OccName: Length}))
@@ -294,77 +292,76 @@
(ClosedTypeFamily
(Just
[({ DumpParsedAst.hs:17:3-30 }
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
- (NoExtField)
- ({ DumpParsedAst.hs:17:3-4 }
- (Unqual
- {OccName: F1}))
- (Nothing)
- [(HsTypeArg
- { DumpParsedAst.hs:17:6-11 }
- ({ DumpParsedAst.hs:17:7-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:7-11 }
- (Unqual
- {OccName: Peano})))))
- ,(HsValArg
- ({ DumpParsedAst.hs:17:13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:13 }
- (Unqual
- {OccName: a})))))
- ,(HsValArg
- ({ DumpParsedAst.hs:17:15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:15 }
- (Unqual
- {OccName: f})))))]
- (Prefix)
- ({ DumpParsedAst.hs:17:19-30 }
- (HsAppTy
- (NoExtField)
- ({ DumpParsedAst.hs:17:19-28 }
- (HsAppTy
- (NoExtField)
- ({ DumpParsedAst.hs:17:19-26 }
- (HsAppKindTy
- { DumpParsedAst.hs:17:21-26 }
- ({ DumpParsedAst.hs:17:19 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:19 }
- (Unqual
- {OccName: T}))))
- ({ DumpParsedAst.hs:17:22-26 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:22-26 }
- (Unqual
- {OccName: Peano}))))))
- ({ DumpParsedAst.hs:17:28 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:28 }
- (Unqual
- {OccName: f}))))))
- ({ DumpParsedAst.hs:17:30 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpParsedAst.hs:17:30 }
- (Unqual
- {OccName: a})))))))))]))
+ ({ DumpParsedAst.hs:17:3-4 }
+ (Unqual
+ {OccName: F1}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsTypeArg
+ { DumpParsedAst.hs:17:6-11 }
+ ({ DumpParsedAst.hs:17:7-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:7-11 }
+ (Unqual
+ {OccName: Peano})))))
+ ,(HsValArg
+ ({ DumpParsedAst.hs:17:13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:13 }
+ (Unqual
+ {OccName: a})))))
+ ,(HsValArg
+ ({ DumpParsedAst.hs:17:15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:15 }
+ (Unqual
+ {OccName: f})))))]
+ (Prefix)
+ ({ DumpParsedAst.hs:17:19-30 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:17:19-28 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpParsedAst.hs:17:19-26 }
+ (HsAppKindTy
+ { DumpParsedAst.hs:17:21-26 }
+ ({ DumpParsedAst.hs:17:19 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:19 }
+ (Unqual
+ {OccName: T}))))
+ ({ DumpParsedAst.hs:17:22-26 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:22-26 }
+ (Unqual
+ {OccName: Peano}))))))
+ ({ DumpParsedAst.hs:17:28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:28 }
+ (Unqual
+ {OccName: f}))))))
+ ({ DumpParsedAst.hs:17:30 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpParsedAst.hs:17:30 }
+ (Unqual
+ {OccName: a}))))))))]))
({ DumpParsedAst.hs:16:13-14 }
(Unqual
{OccName: F1}))
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index e869299a7638..29377597aeb3 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -124,84 +124,82 @@
(ClosedTypeFamily
(Just
[({ DumpRenamedAst.hs:12:3-36 }
- (HsIB
- [{Name: a}
- ,{Name: as}]
- (FamEqn
- (NoExtField)
- ({ DumpRenamedAst.hs:12:3-8 }
- {Name: DumpRenamedAst.Length})
- (Nothing)
- [(HsValArg
- ({ DumpRenamedAst.hs:12:10-17 }
- (HsParTy
- (NoExtField)
- ({ DumpRenamedAst.hs:12:11-16 }
- (HsOpTy
- (NoExtField)
- ({ DumpRenamedAst.hs:12:11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:12:11 }
- {Name: a})))
- ({ DumpRenamedAst.hs:12:13 }
- {Name: :})
- ({ DumpRenamedAst.hs:12:15-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:12:15-16 }
- {Name: as}))))))))]
- (Prefix)
- ({ DumpRenamedAst.hs:12:21-36 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:12:21-24 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:12:21-24 }
- {Name: DumpRenamedAst.Succ})))
- ({ DumpRenamedAst.hs:12:26-36 }
- (HsParTy
- (NoExtField)
- ({ DumpRenamedAst.hs:12:27-35 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:12:27-32 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:12:27-32 }
- {Name: DumpRenamedAst.Length})))
- ({ DumpRenamedAst.hs:12:34-35 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:12:34-35 }
- {Name: as}))))))))))))
+ (FamEqn
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:3-8 }
+ {Name: DumpRenamedAst.Length})
+ (HsOuterImplicit
+ [{Name: a}
+ ,{Name: as}])
+ [(HsValArg
+ ({ DumpRenamedAst.hs:12:10-17 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:11-16 }
+ (HsOpTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:12:11 }
+ {Name: a})))
+ ({ DumpRenamedAst.hs:12:13 }
+ {Name: :})
+ ({ DumpRenamedAst.hs:12:15-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:12:15-16 }
+ {Name: as}))))))))]
+ (Prefix)
+ ({ DumpRenamedAst.hs:12:21-36 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:21-24 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:12:21-24 }
+ {Name: DumpRenamedAst.Succ})))
+ ({ DumpRenamedAst.hs:12:26-36 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:27-35 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:12:27-32 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:12:27-32 }
+ {Name: DumpRenamedAst.Length})))
+ ({ DumpRenamedAst.hs:12:34-35 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:12:34-35 }
+ {Name: as})))))))))))
,({ DumpRenamedAst.hs:13:3-24 }
- (HsIB
- []
- (FamEqn
- (NoExtField)
- ({ DumpRenamedAst.hs:13:3-8 }
- {Name: DumpRenamedAst.Length})
- (Nothing)
- [(HsValArg
- ({ DumpRenamedAst.hs:13:10-12 }
- (HsExplicitListTy
- (NoExtField)
- (IsPromoted)
- [])))]
- (Prefix)
- ({ DumpRenamedAst.hs:13:21-24 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:13:21-24 }
- {Name: DumpRenamedAst.Zero}))))))]))
+ (FamEqn
+ (NoExtField)
+ ({ DumpRenamedAst.hs:13:3-8 }
+ {Name: DumpRenamedAst.Length})
+ (HsOuterImplicit
+ [])
+ [(HsValArg
+ ({ DumpRenamedAst.hs:13:10-12 }
+ (HsExplicitListTy
+ (NoExtField)
+ (IsPromoted)
+ [])))]
+ (Prefix)
+ ({ DumpRenamedAst.hs:13:21-24 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:13:21-24 }
+ {Name: DumpRenamedAst.Zero})))))]))
({ DumpRenamedAst.hs:11:13-18 }
{Name: DumpRenamedAst.Length})
(HsQTvs
@@ -287,173 +285,172 @@
(DataFamInstD
(NoExtField)
(DataFamInstDecl
- (HsIB
- [{Name: a}
- ,{Name: k}]
- (FamEqn
+ (FamEqn
+ (NoExtField)
+ ({ DumpRenamedAst.hs:18:18-20 }
+ {Name: DumpRenamedAst.Nat})
+ (HsOuterImplicit
+ [{Name: a}
+ ,{Name: k}])
+ [(HsValArg
+ ({ DumpRenamedAst.hs:18:22-37 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:18:23-36 }
+ (HsKindSig
+ (NoExtField)
+ ({ DumpRenamedAst.hs:18:23 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:23 }
+ {Name: a})))
+ ({ DumpRenamedAst.hs:18:28-36 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ DumpRenamedAst.hs:18:28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:28 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:18:33-36 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:33-36 }
+ {Name: GHC.Types.Type}))))))))))]
+ (Prefix)
+ (HsDataDefn
(NoExtField)
- ({ DumpRenamedAst.hs:18:18-20 }
- {Name: DumpRenamedAst.Nat})
+ (NewType)
+ ({ <no location info> }
+ [])
(Nothing)
- [(HsValArg
- ({ DumpRenamedAst.hs:18:22-37 }
- (HsParTy
- (NoExtField)
- ({ DumpRenamedAst.hs:18:23-36 }
- (HsKindSig
- (NoExtField)
- ({ DumpRenamedAst.hs:18:23 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:23 }
- {Name: a})))
- ({ DumpRenamedAst.hs:18:28-36 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ DumpRenamedAst.hs:18:28 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:28 }
- {Name: k})))
- ({ DumpRenamedAst.hs:18:33-36 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:33-36 }
- {Name: GHC.Types.Type}))))))))))]
- (Prefix)
- (HsDataDefn
- (NoExtField)
- (NewType)
- ({ <no location info> }
- [])
- (Nothing)
- (Just
- ({ DumpRenamedAst.hs:18:42-60 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ DumpRenamedAst.hs:18:42-52 }
- (HsParTy
- (NoExtField)
- ({ DumpRenamedAst.hs:18:43-51 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ DumpRenamedAst.hs:18:43 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:43 }
- {Name: k})))
- ({ DumpRenamedAst.hs:18:48-51 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:48-51 }
- {Name: GHC.Types.Type})))))))
- ({ DumpRenamedAst.hs:18:57-60 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:18:57-60 }
- {Name: GHC.Types.Type}))))))
- [({ DumpRenamedAst.hs:19:3-45 }
- (ConDeclGADT
- [{Name: f}
- ,{Name: g}]
- [({ DumpRenamedAst.hs:19:3-5 }
- {Name: DumpRenamedAst.Nat})]
- ({ DumpRenamedAst.hs:19:10-45 }
- (False))
- []
- (Nothing)
- (PrefixConGADT
- [(HsScaled
+ (Just
+ ({ DumpRenamedAst.hs:18:42-60 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ DumpRenamedAst.hs:18:42-52 }
+ (HsParTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:18:43-51 }
+ (HsFunTy
+ (NoExtField)
(HsUnrestrictedArrow
(NormalSyntax))
- ({ DumpRenamedAst.hs:19:10-34 }
- (HsParTy
+ ({ DumpRenamedAst.hs:18:43 }
+ (HsTyVar
(NoExtField)
- ({ DumpRenamedAst.hs:19:11-33 }
- (HsForAllTy
- (NoExtField)
- (HsForAllInvis
- (NoExtField)
- [({ DumpRenamedAst.hs:19:18-19 }
- (UserTyVar
- (NoExtField)
- (SpecifiedSpec)
- ({ DumpRenamedAst.hs:19:18-19 }
- {Name: xx})))])
- ({ DumpRenamedAst.hs:19:22-33 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ DumpRenamedAst.hs:19:22-25 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:19:22 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:22 }
- {Name: f})))
- ({ DumpRenamedAst.hs:19:24-25 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:24-25 }
- {Name: xx})))))
- ({ DumpRenamedAst.hs:19:30-33 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:19:30 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:30 }
- {Name: g})))
- ({ DumpRenamedAst.hs:19:32-33 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:32-33 }
- {Name: xx}))))))))))))])
- ({ DumpRenamedAst.hs:19:39-45 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:19:39-43 }
- (HsAppTy
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:43 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:18:48-51 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:48-51 }
+ {Name: GHC.Types.Type})))))))
+ ({ DumpRenamedAst.hs:18:57-60 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:18:57-60 }
+ {Name: GHC.Types.Type}))))))
+ [({ DumpRenamedAst.hs:19:3-45 }
+ (ConDeclGADT
+ (NoExtField)
+ [({ DumpRenamedAst.hs:19:3-5 }
+ {Name: DumpRenamedAst.Nat})]
+ ({ DumpRenamedAst.hs:19:10-45 }
+ (HsOuterImplicit
+ [{Name: f}
+ ,{Name: g}]))
+ (Nothing)
+ (PrefixConGADT
+ [(HsScaled
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ DumpRenamedAst.hs:19:10-34 }
+ (HsParTy
(NoExtField)
- ({ DumpRenamedAst.hs:19:39-41 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:39-41 }
- {Name: DumpRenamedAst.Nat})))
- ({ DumpRenamedAst.hs:19:43 }
- (HsTyVar
+ ({ DumpRenamedAst.hs:19:11-33 }
+ (HsForAllTy
(NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:43 }
- {Name: f})))))
- ({ DumpRenamedAst.hs:19:45 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:19:45 }
- {Name: g})))))
- (Nothing)))]
- ({ <no location info> }
- [])))))))])
+ (HsForAllInvis
+ (NoExtField)
+ [({ DumpRenamedAst.hs:19:18-19 }
+ (UserTyVar
+ (NoExtField)
+ (SpecifiedSpec)
+ ({ DumpRenamedAst.hs:19:18-19 }
+ {Name: xx})))])
+ ({ DumpRenamedAst.hs:19:22-33 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ DumpRenamedAst.hs:19:22-25 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:19:22 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:22 }
+ {Name: f})))
+ ({ DumpRenamedAst.hs:19:24-25 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:24-25 }
+ {Name: xx})))))
+ ({ DumpRenamedAst.hs:19:30-33 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:19:30 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:30 }
+ {Name: g})))
+ ({ DumpRenamedAst.hs:19:32-33 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:32-33 }
+ {Name: xx}))))))))))))])
+ ({ DumpRenamedAst.hs:19:39-45 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:19:39-43 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:19:39-41 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:39-41 }
+ {Name: DumpRenamedAst.Nat})))
+ ({ DumpRenamedAst.hs:19:43 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:43 }
+ {Name: f})))))
+ ({ DumpRenamedAst.hs:19:45 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:19:45 }
+ {Name: g})))))
+ (Nothing)))]
+ ({ <no location info> }
+ []))))))])
,(TyClGroup
(NoExtField)
[({ DumpRenamedAst.hs:21:1-29 }
@@ -540,70 +537,69 @@
(ClosedTypeFamily
(Just
[({ DumpRenamedAst.hs:24:3-30 }
- (HsIB
- [{Name: a}
- ,{Name: f}]
- (FamEqn
- (NoExtField)
- ({ DumpRenamedAst.hs:24:3-4 }
- {Name: DumpRenamedAst.F1})
- (Nothing)
- [(HsTypeArg
- { DumpRenamedAst.hs:24:6-11 }
- ({ DumpRenamedAst.hs:24:7-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:7-11 }
- {Name: DumpRenamedAst.Peano}))))
- ,(HsValArg
- ({ DumpRenamedAst.hs:24:13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:13 }
- {Name: a}))))
- ,(HsValArg
- ({ DumpRenamedAst.hs:24:15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:15 }
- {Name: f}))))]
- (Prefix)
- ({ DumpRenamedAst.hs:24:19-30 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:24:19-28 }
- (HsAppTy
- (NoExtField)
- ({ DumpRenamedAst.hs:24:19-26 }
- (HsAppKindTy
- { DumpRenamedAst.hs:24:21-26 }
- ({ DumpRenamedAst.hs:24:19 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:19 }
- {Name: DumpRenamedAst.T})))
- ({ DumpRenamedAst.hs:24:22-26 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:22-26 }
- {Name: DumpRenamedAst.Peano})))))
- ({ DumpRenamedAst.hs:24:28 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:28 }
- {Name: f})))))
- ({ DumpRenamedAst.hs:24:30 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ DumpRenamedAst.hs:24:30 }
- {Name: a}))))))))]))
+ (FamEqn
+ (NoExtField)
+ ({ DumpRenamedAst.hs:24:3-4 }
+ {Name: DumpRenamedAst.F1})
+ (HsOuterImplicit
+ [{Name: a}
+ ,{Name: f}])
+ [(HsTypeArg
+ { DumpRenamedAst.hs:24:6-11 }
+ ({ DumpRenamedAst.hs:24:7-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:7-11 }
+ {Name: DumpRenamedAst.Peano}))))
+ ,(HsValArg
+ ({ DumpRenamedAst.hs:24:13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:13 }
+ {Name: a}))))
+ ,(HsValArg
+ ({ DumpRenamedAst.hs:24:15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:15 }
+ {Name: f}))))]
+ (Prefix)
+ ({ DumpRenamedAst.hs:24:19-30 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:24:19-28 }
+ (HsAppTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:24:19-26 }
+ (HsAppKindTy
+ { DumpRenamedAst.hs:24:21-26 }
+ ({ DumpRenamedAst.hs:24:19 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:19 }
+ {Name: DumpRenamedAst.T})))
+ ({ DumpRenamedAst.hs:24:22-26 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:22-26 }
+ {Name: DumpRenamedAst.Peano})))))
+ ({ DumpRenamedAst.hs:24:28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:28 }
+ {Name: f})))))
+ ({ DumpRenamedAst.hs:24:30 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:24:30 }
+ {Name: a})))))))]))
({ DumpRenamedAst.hs:23:13-14 }
{Name: DumpRenamedAst.F1})
(HsQTvs
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 13aa2e6147f6..a8597046e212 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -32,40 +32,39 @@
(ClosedTypeFamily
(Just
[({ KindSigs.hs:12:3-21 }
- (HsIB
+ (FamEqn
(NoExtField)
- (FamEqn
- (NoExtField)
- ({ KindSigs.hs:12:3-5 }
- (Unqual
- {OccName: Foo}))
- (Nothing)
- [(HsValArg
- ({ KindSigs.hs:12:7 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:12:7 }
- (Unqual
- {OccName: a})))))]
- (Prefix)
- ({ KindSigs.hs:12:11-21 }
- (HsKindSig
- (NoExtField)
- ({ KindSigs.hs:12:11-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:12:11-13 }
- (Unqual
- {OccName: Int}))))
- ({ KindSigs.hs:12:18-21 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:12:18-21 }
- (Unqual
- {OccName: Type})))))))))]))
+ ({ KindSigs.hs:12:3-5 }
+ (Unqual
+ {OccName: Foo}))
+ (HsOuterImplicit
+ (NoExtField))
+ [(HsValArg
+ ({ KindSigs.hs:12:7 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:12:7 }
+ (Unqual
+ {OccName: a})))))]
+ (Prefix)
+ ({ KindSigs.hs:12:11-21 }
+ (HsKindSig
+ (NoExtField)
+ ({ KindSigs.hs:12:11-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:12:11-13 }
+ (Unqual
+ {OccName: Int}))))
+ ({ KindSigs.hs:12:18-21 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:12:18-21 }
+ (Unqual
+ {OccName: Type}))))))))]))
({ KindSigs.hs:11:13-15 }
(Unqual
{OccName: Foo}))
@@ -271,63 +270,66 @@
{OccName: qux}))]
(HsWC
(NoExtField)
- (HsIB
- (NoExtField)
- ({ KindSigs.hs:22:8-44 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ KindSigs.hs:22:8-20 }
- (HsParTy
- (NoExtField)
- ({ KindSigs.hs:22:9-19 }
- (HsKindSig
- (NoExtField)
- ({ KindSigs.hs:22:9-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:22:9-11 }
- (Unqual
- {OccName: Int}))))
- ({ KindSigs.hs:22:16-19 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:22:16-19 }
- (Unqual
- {OccName: Type}))))))))
- ({ KindSigs.hs:22:25-44 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow
- (NormalSyntax))
- ({ KindSigs.hs:22:25-28 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:22:25-28 }
- (Unqual
- {OccName: Bool}))))
- ({ KindSigs.hs:22:33-44 }
- (HsParTy
- (NoExtField)
- ({ KindSigs.hs:22:34-43 }
- (HsKindSig
- (NoExtField)
- ({ KindSigs.hs:22:34-35 }
- (HsTupleTy
- (NoExtField)
- (HsBoxedOrConstraintTuple)
- []))
- ({ KindSigs.hs:22:40-43 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:22:40-43 }
- (Unqual
- {OccName: Type})))))))))))))))))
+ ({ KindSigs.hs:22:8-44 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ KindSigs.hs:22:8-44 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ KindSigs.hs:22:8-20 }
+ (HsParTy
+ (NoExtField)
+ ({ KindSigs.hs:22:9-19 }
+ (HsKindSig
+ (NoExtField)
+ ({ KindSigs.hs:22:9-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:22:9-11 }
+ (Unqual
+ {OccName: Int}))))
+ ({ KindSigs.hs:22:16-19 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:22:16-19 }
+ (Unqual
+ {OccName: Type}))))))))
+ ({ KindSigs.hs:22:25-44 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow
+ (NormalSyntax))
+ ({ KindSigs.hs:22:25-28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:22:25-28 }
+ (Unqual
+ {OccName: Bool}))))
+ ({ KindSigs.hs:22:33-44 }
+ (HsParTy
+ (NoExtField)
+ ({ KindSigs.hs:22:34-43 }
+ (HsKindSig
+ (NoExtField)
+ ({ KindSigs.hs:22:34-35 }
+ (HsTupleTy
+ (NoExtField)
+ (HsBoxedOrConstraintTuple)
+ []))
+ ({ KindSigs.hs:22:40-43 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:22:40-43 }
+ (Unqual
+ {OccName: Type}))))))))))))))))))
,({ KindSigs.hs:23:1-12 }
(ValD
(NoExtField)
@@ -552,28 +554,31 @@
{OccName: true}))]
(HsWC
(NoExtField)
- (HsIB
- (NoExtField)
- ({ KindSigs.hs:34:9-22 }
- (HsParTy
- (NoExtField)
- ({ KindSigs.hs:34:10-21 }
- (HsKindSig
- (NoExtField)
- ({ KindSigs.hs:34:10-13 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:34:10-13 }
- (Unqual
- {OccName: Bool}))))
- ({ KindSigs.hs:34:18-21 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ KindSigs.hs:34:18-21 }
- (Unqual
- {OccName: Type})))))))))))))
+ ({ KindSigs.hs:34:9-22 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ KindSigs.hs:34:9-22 }
+ (HsParTy
+ (NoExtField)
+ ({ KindSigs.hs:34:10-21 }
+ (HsKindSig
+ (NoExtField)
+ ({ KindSigs.hs:34:10-13 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:34:10-13 }
+ (Unqual
+ {OccName: Bool}))))
+ ({ KindSigs.hs:34:18-21 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ KindSigs.hs:34:18-21 }
+ (Unqual
+ {OccName: Type}))))))))))))))
,({ KindSigs.hs:35:1-11 }
(ValD
(NoExtField)
@@ -614,3 +619,5 @@
[])))]
(Nothing)
(Nothing)))
+
+
diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr
index 853959966068..ae19f0a174c7 100644
--- a/testsuite/tests/parser/should_compile/T15323.stderr
+++ b/testsuite/tests/parser/should_compile/T15323.stderr
@@ -42,14 +42,15 @@
(Unqual
{OccName: TestParens}))]
({ T15323.hs:6:20-54 }
- (True))
- [({ T15323.hs:6:27 }
- (UserTyVar
- (NoExtField)
- (SpecifiedSpec)
- ({ T15323.hs:6:27 }
- (Unqual
- {OccName: v}))))]
+ (HsOuterExplicit
+ (NoExtField)
+ [({ T15323.hs:6:27 }
+ (UserTyVar
+ (NoExtField)
+ (SpecifiedSpec)
+ ({ T15323.hs:6:27 }
+ (Unqual
+ {OccName: v}))))]))
(Just
({ T15323.hs:6:31-36 }
[({ T15323.hs:6:31-36 }
diff --git a/testsuite/tests/partial-sigs/should_compile/T16762d.hs b/testsuite/tests/partial-sigs/should_compile/T16762d.hs
new file mode 100644
index 000000000000..02c2c57fcdf7
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T16762d.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeFamilies, PolyKinds, ExplicitForAll #-}
+
+module Foo where
+
+import Data.Kind
+import Data.Proxy
+
+
+type family F (a::k) (b::k)
+
+-- Tricky because we can't quantify the '_' variable outside.
+-- See Note [Generalising in tcTyFamInstEqnGuts] in TyCl
+
+type instance forall k (x::k). F x _ = Int
diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T
index e8d84fe3bb64..8bb939addd51 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -96,3 +96,4 @@ test('T16728', normal, compile, [''])
test('T16728a', normal, compile, [''])
test('T16728b', normal, compile, [''])
test('T18008', normal, compile, [''])
+test('T16762d', normal, compile, [''])
diff --git a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr
index be667ec3a635..8e2d02e9b33e 100644
--- a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr
@@ -5,8 +5,8 @@ T14040a.hs:26:46: error:
but ‘xs’ has kind ‘WeirdList (WeirdList z)’
because kind variable ‘z’ would escape its scope
This (rigid, skolem) kind variable is bound by
- ‘forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)).
- Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs)’
+ an explicit forall (z :: Type) (x :: z)
+ (xs :: WeirdList (WeirdList z))
at T14040a.hs:(25,19)-(27,41)
• In the second argument of ‘p’, namely ‘xs’
In the type ‘Sing wl
@@ -17,12 +17,17 @@ T14040a.hs:26:46: error:
In the type signature:
elimWeirdList :: forall (a :: Type)
(wl :: WeirdList a)
- (p :: forall (x :: Type). x -> WeirdList x -> Type).
- Sing wl
- -> (forall (y :: Type). p _ WeirdNil)
- -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)).
- Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs))
- -> p _ wl
+ (p :: forall (x :: Type). x -> WeirdList x -> Type). Sing wl
+ -> (forall (y :: Type).
+ p _ WeirdNil)
+ -> (forall (z :: Type)
+ (x :: z)
+ (xs :: WeirdList (WeirdList z)).
+ Sing x
+ -> Sing xs
+ -> p _ xs
+ -> p _ (WeirdCons x xs))
+ -> p _ wl
T14040a.hs:27:27: error:
• Couldn't match kind ‘k0’ with ‘z’
@@ -30,8 +35,8 @@ T14040a.hs:27:27: error:
but ‘WeirdCons x xs’ has kind ‘WeirdList z’
because kind variable ‘z’ would escape its scope
This (rigid, skolem) kind variable is bound by
- ‘forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)).
- Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs)’
+ an explicit forall (z :: Type) (x :: z)
+ (xs :: WeirdList (WeirdList z))
at T14040a.hs:(25,19)-(27,41)
• In the second argument of ‘p’, namely ‘(WeirdCons x xs)’
In the type ‘Sing wl
@@ -42,9 +47,14 @@ T14040a.hs:27:27: error:
In the type signature:
elimWeirdList :: forall (a :: Type)
(wl :: WeirdList a)
- (p :: forall (x :: Type). x -> WeirdList x -> Type).
- Sing wl
- -> (forall (y :: Type). p _ WeirdNil)
- -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)).
- Sing x -> Sing xs -> p _ xs -> p _ (WeirdCons x xs))
- -> p _ wl
+ (p :: forall (x :: Type). x -> WeirdList x -> Type). Sing wl
+ -> (forall (y :: Type).
+ p _ WeirdNil)
+ -> (forall (z :: Type)
+ (x :: z)
+ (xs :: WeirdList (WeirdList z)).
+ Sing x
+ -> Sing xs
+ -> p _ xs
+ -> p _ (WeirdCons x xs))
+ -> p _ wl
diff --git a/testsuite/tests/patsyn/should_fail/T11039.stderr b/testsuite/tests/patsyn/should_fail/T11039.stderr
index f8f4d357688b..aa20358e1028 100644
--- a/testsuite/tests/patsyn/should_fail/T11039.stderr
+++ b/testsuite/tests/patsyn/should_fail/T11039.stderr
@@ -5,6 +5,6 @@ T11039.hs:8:15: error:
Actual: A a
‘f’ is a rigid type variable bound by
the signature for pattern synonym ‘Q’
- at T11039.hs:7:1-38
+ at T11039.hs:7:14-38
• In the pattern: A a
In the declaration for pattern synonym ‘Q’
diff --git a/testsuite/tests/patsyn/should_fail/T11667.stderr b/testsuite/tests/patsyn/should_fail/T11667.stderr
index c9c00c916542..f4dafc0f2830 100644
--- a/testsuite/tests/patsyn/should_fail/T11667.stderr
+++ b/testsuite/tests/patsyn/should_fail/T11667.stderr
@@ -17,7 +17,7 @@ T11667.hs:18:28: error:
the signature of ‘Pat2’
‘b’ is a rigid type variable bound by
the signature for pattern synonym ‘Pat2’
- at T11667.hs:17:1-50
+ at T11667.hs:17:17-50
• In the declaration for pattern synonym ‘Pat2’
• Relevant bindings include y :: b (bound at T11667.hs:18:21)
diff --git a/testsuite/tests/patsyn/should_fail/T15694.stderr b/testsuite/tests/patsyn/should_fail/T15694.stderr
index 7e1507c332d8..2b0b7b77b19f 100644
--- a/testsuite/tests/patsyn/should_fail/T15694.stderr
+++ b/testsuite/tests/patsyn/should_fail/T15694.stderr
@@ -2,6 +2,7 @@
T15694.hs:22:35: error:
• Expected kind ‘k1 -> k0’, but ‘f a1’ has kind ‘ks’
‘ks’ is a rigid type variable bound by
- the data constructor ‘ASSO’
+ an explicit forall ks k (f :: k -> ks) (a1 :: k) (ctx :: Ctx ks)
+ (ks1 :: Type) k1 (a2 :: k1) (ctx1 :: Ctx ks1) a3
at T15694.hs:18:30-31
• In the first argument of ‘(~~)’, namely ‘f a1 a2’
diff --git a/testsuite/tests/polykinds/T11142.stderr b/testsuite/tests/polykinds/T11142.stderr
index 780bbdc63fe2..f96278a5e7af 100644
--- a/testsuite/tests/polykinds/T11142.stderr
+++ b/testsuite/tests/polykinds/T11142.stderr
@@ -3,7 +3,7 @@ T11142.hs:9:49: error:
• Expected kind ‘k’, but ‘b’ has kind ‘k0’
because kind variable ‘k’ would escape its scope
This (rigid, skolem) kind variable is bound by
- ‘forall k (a :: k). SameKind a b’
+ an explicit forall k (a :: k)
at T11142.hs:9:19-49
• In the second argument of ‘SameKind’, namely ‘b’
In the type signature:
diff --git a/testsuite/tests/polykinds/T11516.stderr b/testsuite/tests/polykinds/T11516.stderr
index 5f8083309c6e..0bee63f2b345 100644
--- a/testsuite/tests/polykinds/T11516.stderr
+++ b/testsuite/tests/polykinds/T11516.stderr
@@ -1,5 +1,5 @@
T11516.hs:12:16: error:
- • Expected kind ‘i0 -> i0 -> *’, but ‘()’ has kind ‘*’
+ • Expected kind ‘i -> i -> *’, but ‘()’ has kind ‘*’
• In the first argument of ‘Varpi’, namely ‘()’
In the instance declaration for ‘Varpi (->) (->) (Either f)’
diff --git a/testsuite/tests/polykinds/T11520.stderr b/testsuite/tests/polykinds/T11520.stderr
index 156f8490e8c5..90a582626660 100644
--- a/testsuite/tests/polykinds/T11520.stderr
+++ b/testsuite/tests/polykinds/T11520.stderr
@@ -1,9 +1,9 @@
T11520.hs:15:77: error:
- • Expected kind ‘k20 -> k10’, but ‘g’ has kind ‘k’
- ‘k’ is a rigid type variable bound by
- the instance declaration
- at T11520.hs:(15,1)-(16,23)
+ • Expected kind ‘k2 -> k1’, but ‘g’ has kind ‘k4’
+ ‘k4’ is a rigid type variable bound by
+ an instance declaration
+ at T11520.hs:15:10-78
• In the second argument of ‘Compose’, namely ‘g’
In the first argument of ‘Typeable’, namely ‘(Compose f g)’
In the instance declaration for ‘Typeable (Compose f g)’
diff --git a/testsuite/tests/polykinds/T15787.stderr b/testsuite/tests/polykinds/T15787.stderr
index 7241e2f7fb01..b22e6c7b5b1a 100644
--- a/testsuite/tests/polykinds/T15787.stderr
+++ b/testsuite/tests/polykinds/T15787.stderr
@@ -1,7 +1,7 @@
T15787.hs:15:14: error:
- • Expected a type, but ‘k’ has kind ‘ob’
- ‘ob’ is a rigid type variable bound by
+ • Expected a type, but ‘k’ has kind ‘ob1’
+ ‘ob1’ is a rigid type variable bound by
the data constructor ‘Kl’
at T15787.hs:15:3-43
• In the type ‘k’
diff --git a/testsuite/tests/polykinds/T16221a.stderr b/testsuite/tests/polykinds/T16221a.stderr
index 7b550b6c8f85..5aa099b0f158 100644
--- a/testsuite/tests/polykinds/T16221a.stderr
+++ b/testsuite/tests/polykinds/T16221a.stderr
@@ -2,7 +2,7 @@
T16221a.hs:6:49: error:
• Expected kind ‘k’, but ‘b’ has kind ‘k1’
‘k1’ is a rigid type variable bound by
- the data constructor ‘MkT2’
+ an explicit forall k (b :: k)
at T16221a.hs:6:20
‘k’ is a rigid type variable bound by
the data constructor ‘MkT2’
diff --git a/testsuite/tests/polykinds/T16762.hs b/testsuite/tests/polykinds/T16762.hs
new file mode 100644
index 000000000000..720f8f572581
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs, DataKinds, PolyKinds, ExplicitForAll #-}
+
+module BadTelescope2 where
+
+import Data.Kind
+
+data SameKind :: k -> k -> *
+
+-- This declaration made GHC 8.10 produce a Core Lint error
+data T a b where
+ MkT :: forall a kx (b :: kx). SameKind a b -> T a b
diff --git a/testsuite/tests/polykinds/T16762.stderr b/testsuite/tests/polykinds/T16762.stderr
new file mode 100644
index 000000000000..6335fa4c5013
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762.stderr
@@ -0,0 +1,7 @@
+
+T16762.hs:11:3: error:
+ • These kind and type variables: a kx (b :: kx)
+ are out of dependency order. Perhaps try this ordering:
+ kx (a :: kx) (b :: kx)
+ • In the definition of data constructor ‘MkT’
+ In the data declaration for ‘T’
diff --git a/testsuite/tests/polykinds/T16762a.hs b/testsuite/tests/polykinds/T16762a.hs
new file mode 100644
index 000000000000..4f56c8b3e985
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762a.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, ExplicitForAll #-}
+
+module T16762a where
+
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+type family F a
+
+-- This should jolly well be rejected!
+type instance forall a k (b::k). F (SameKind a b) = Int
diff --git a/testsuite/tests/polykinds/T16762a.stderr b/testsuite/tests/polykinds/T16762a.stderr
new file mode 100644
index 000000000000..0a96f77d827a
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762a.stderr
@@ -0,0 +1,6 @@
+
+T16762a.hs:12:22: error:
+ • These kind and type variables: a k (b :: k)
+ are out of dependency order. Perhaps try this ordering:
+ k (a :: k) (b :: k)
+ • In the type instance declaration for ‘F’
diff --git a/testsuite/tests/polykinds/T16762b.hs b/testsuite/tests/polykinds/T16762b.hs
new file mode 100644
index 000000000000..cad6bff33f51
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762b.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+module T16762b where
+
+import Data.Kind
+
+type T :: forall k. Type
+data T
diff --git a/testsuite/tests/polykinds/T16762b.stderr b/testsuite/tests/polykinds/T16762b.stderr
new file mode 100644
index 000000000000..ffb29b70dce0
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762b.stderr
@@ -0,0 +1,4 @@
+
+T16762b.hs:7:11: error:
+ Illegal kind: forall k. Type
+ Did you mean to enable PolyKinds?
diff --git a/testsuite/tests/polykinds/T16762c.hs b/testsuite/tests/polykinds/T16762c.hs
new file mode 100644
index 000000000000..c74c30ee472f
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762c.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, ExplicitForAll #-}
+
+module Foo where
+
+import Data.Kind
+
+data SameKind :: k -> k -> Type
+
+-- Bad telescope
+data T = forall a k (b::k). MkT (SameKind a b)
diff --git a/testsuite/tests/polykinds/T16762c.stderr b/testsuite/tests/polykinds/T16762c.stderr
new file mode 100644
index 000000000000..5be6fbb46272
--- /dev/null
+++ b/testsuite/tests/polykinds/T16762c.stderr
@@ -0,0 +1,7 @@
+
+T16762c.hs:10:10: error:
+ • These kind and type variables: a k (b :: k)
+ are out of dependency order. Perhaps try this ordering:
+ k (a :: k) (b :: k)
+ • In the definition of data constructor ‘MkT’
+ In the data declaration for ‘T’
diff --git a/testsuite/tests/polykinds/T7278.stderr b/testsuite/tests/polykinds/T7278.stderr
index 5f4ff6d18f57..93b0e9aa3d03 100644
--- a/testsuite/tests/polykinds/T7278.stderr
+++ b/testsuite/tests/polykinds/T7278.stderr
@@ -1,7 +1,7 @@
T7278.hs:9:43: error:
- • Expected kind ‘* -> * -> *’, but ‘t’ has kind ‘k’
- ‘k’ is a rigid type variable bound by
+ • Expected kind ‘* -> * -> *’, but ‘t’ has kind ‘k1’
+ ‘k1’ is a rigid type variable bound by
the type signature for ‘f’
at T7278.hs:9:1-49
• In the type signature:
diff --git a/testsuite/tests/polykinds/TyVarTvKinds3.stderr b/testsuite/tests/polykinds/TyVarTvKinds3.stderr
index b0b792444479..872fe966840a 100644
--- a/testsuite/tests/polykinds/TyVarTvKinds3.stderr
+++ b/testsuite/tests/polykinds/TyVarTvKinds3.stderr
@@ -2,10 +2,10 @@
TyVarTvKinds3.hs:9:62: error:
• Expected kind ‘k1’, but ‘b’ has kind ‘k2’
‘k2’ is a rigid type variable bound by
- the data constructor ‘MkBad’
+ an explicit forall k1 k2 (a :: k1) (b :: k2)
at TyVarTvKinds3.hs:9:22-23
‘k1’ is a rigid type variable bound by
- the data constructor ‘MkBad’
+ an explicit forall k1 k2 (a :: k1) (b :: k2)
at TyVarTvKinds3.hs:9:19-20
• In the second argument of ‘SameKind’, namely ‘b’
In the first argument of ‘Bad’, namely ‘(SameKind a b)’
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index 009172537b0f..a509dfd66597 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -216,6 +216,10 @@ test('T16245', normal, compile_fail, [''])
test('T16245a', normal, compile_fail, [''])
test('T16342', normal, compile, [''])
test('T16263', normal, compile_fail, [''])
+test('T16762', normal, compile_fail, [''])
+test('T16762a', normal, compile_fail, [''])
+test('T16762b', normal, compile_fail, [''])
+test('T16762c', normal, compile_fail, [''])
test('T16902', normal, compile_fail, [''])
test('CuskFam', normal, compile, [''])
test('T17841', normal, compile_fail, [''])
diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr
index e245ef0fbe7a..af6d93019cb9 100644
--- a/testsuite/tests/printer/T18791.stderr
+++ b/testsuite/tests/printer/T18791.stderr
@@ -36,8 +36,8 @@
(Unqual
{OccName: MkT}))]
({ T18791.hs:5:10-17 }
- (False))
- []
+ (HsOuterImplicit
+ (NoExtField)))
(Nothing)
(PrefixConGADT
[(HsScaled
diff --git a/testsuite/tests/saks/should_fail/saks_fail020.stderr b/testsuite/tests/saks/should_fail/saks_fail020.stderr
index c71b7727865d..002d7b27b3e4 100644
--- a/testsuite/tests/saks/should_fail/saks_fail020.stderr
+++ b/testsuite/tests/saks/should_fail/saks_fail020.stderr
@@ -1,10 +1,12 @@
saks_fail020.hs:9:49: error:
- • Expected kind ‘k’, but ‘a’ has kind ‘k0’
- because kind variable ‘k’ would escape its scope
- This (rigid, skolem) kind variable is bound by
- ‘forall (k :: Type) -> Proxy (a :: k)’
- at saks_fail020.hs:9:20-55
+ • Expected kind ‘k1’, but ‘a’ has kind ‘k’
+ ‘k’ is a rigid type variable bound by
+ a standalone kind signature for ‘Foo2’
+ at saks_fail020.hs:9:14-55
+ ‘k1’ is a rigid type variable bound by
+ an explicit forall (k :: Type)
+ at saks_fail020.hs:9:28
• In the first argument of ‘Proxy’, namely ‘(a :: k)’
In a standalone kind signature for ‘Foo2’:
() -> forall (k :: Type) -> Proxy (a :: k)
diff --git a/testsuite/tests/typecheck/should_fail/T12102b.stderr b/testsuite/tests/typecheck/should_fail/T12102b.stderr
index d93b7fda9c74..49bce539859a 100644
--- a/testsuite/tests/typecheck/should_fail/T12102b.stderr
+++ b/testsuite/tests/typecheck/should_fail/T12102b.stderr
@@ -1,7 +1,6 @@
T12102b.hs:21:25: error:
• Couldn't match expected kind ‘'True’
- with actual kind ‘IsTypeLit a0’
- The type variable ‘a0’ is ambiguous
+ with actual kind ‘IsTypeLit a’
• In the first argument of ‘Show’, namely ‘(T a)’
In the stand-alone deriving instance for ‘Show (T a)’
diff --git a/testsuite/tests/typecheck/should_fail/T13909.stderr b/testsuite/tests/typecheck/should_fail/T13909.stderr
index 0cbae707336a..6ea5b32e6687 100644
--- a/testsuite/tests/typecheck/should_fail/T13909.stderr
+++ b/testsuite/tests/typecheck/should_fail/T13909.stderr
@@ -1,7 +1,9 @@
T13909.hs:11:18: error:
- • Expected kind ‘k0’, but ‘Hm’ has kind ‘forall k -> k -> *’
- Cannot instantiate unification variable ‘k0’
- with a kind involving polytypes: forall k -> k -> *
+ • Expecting two more arguments to ‘Hm’
+ Expected kind ‘k’, but ‘Hm’ has kind ‘forall k -> k -> *’
+ ‘k’ is a rigid type variable bound by
+ an instance declaration
+ at T13909.hs:11:10-19
• In the first argument of ‘HasName’, namely ‘Hm’
In the instance declaration for ‘HasName Hm’
diff --git a/testsuite/tests/typecheck/should_fail/T15629.stderr b/testsuite/tests/typecheck/should_fail/T15629.stderr
index 09d59fdf62b8..3599acef7337 100644
--- a/testsuite/tests/typecheck/should_fail/T15629.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15629.stderr
@@ -4,16 +4,14 @@ T15629.hs:26:37: error:
Expected kind ‘x ~> F x ab’,
but ‘F1Sym :: x ~> F x z’ has kind ‘x ~> F x z’
‘z’ is a rigid type variable bound by
- ‘forall z ab.
- Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’
+ an explicit forall z ab
at T15629.hs:26:17
‘ab’ is a rigid type variable bound by
- ‘forall z ab.
- Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’
+ an explicit forall z ab
at T15629.hs:26:19-20
• In the first argument of ‘Comp’, namely ‘(F1Sym :: x ~> F x z)’
In the first argument of ‘Proxy’, namely
‘((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’
In the type signature:
- g :: forall z ab.
- Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)
+ g :: forall z ab. Proxy ((Comp (F1Sym :: x
+ ~> F x z) F2Sym) :: F x ab ~> F x ab)
diff --git a/testsuite/tests/typecheck/should_fail/T15799.stderr b/testsuite/tests/typecheck/should_fail/T15799.stderr
index 6823cadb8ce0..161cfe026a0a 100644
--- a/testsuite/tests/typecheck/should_fail/T15799.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15799.stderr
@@ -1,5 +1,9 @@
T15799.hs:46:62: error:
- Couldn't match kind ‘TypeLits.Natural’ with ‘Op Nat’
- • Expected kind ‘Op Nat’, but ‘UnOp b’ has kind ‘Nat’
- • In the first argument of ‘(<=)’, namely ‘UnOp b’
+ Expected a constraint, but ‘UnOp b <= a’ has kind ‘*’
+
+T15799.hs:46:67: error:
+ • Couldn't match kind ‘TypeLits.Natural’ with ‘Op Nat’
+ Expected kind ‘Op (Op Nat)’, but ‘b’ has kind ‘Op Nat’
+ • In the first argument of ‘UnOp’, namely ‘b’
+ In the first argument of ‘(<=)’, namely ‘UnOp b’
diff --git a/testsuite/tests/typecheck/should_fail/T16517.stderr b/testsuite/tests/typecheck/should_fail/T16517.stderr
index 1e17286cff56..252e8ad79307 100644
--- a/testsuite/tests/typecheck/should_fail/T16517.stderr
+++ b/testsuite/tests/typecheck/should_fail/T16517.stderr
@@ -1,8 +1,10 @@
T16517.hs:5:29: error:
- • Expected kind ‘k’, but ‘a’ has kind ‘k0’
- because kind variable ‘k’ would escape its scope
- This (rigid, skolem) kind variable is bound by
+ • Expected kind ‘k1’, but ‘a’ has kind ‘k’
+ ‘k1’ is a rigid type variable bound by
+ the type signature for ‘m’
+ at T16517.hs:5:22-35
+ ‘k’ is a rigid type variable bound by
the class declaration for ‘C’
at T16517.hs:5:22-35
• In the first argument of ‘Proxy’, namely ‘(a :: k)’
diff --git a/utils/haddock b/utils/haddock
index 3cce1bdee8c6..ad9cbad7312a 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 3cce1bdee8c61bb6daa089059e12435178f50770
+Subproject commit ad9cbad7312a64e6757c32bd9488c55ba4f2fec9
--
GitLab