diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-07-05 16:15:01 -0400 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-10-30 19:38:31 -0400 |
| commit | e9b2578fa17989f13ec6ba8fae0c35b2dac4d900 (patch) | |
| tree | 2032245a504f20b62c0980cd84208673f45c2ac4 | |
| parent | 31fcb55f4ff8c06c5ab100a6817cae8b571295a9 (diff) | |
| download | haskell-wip/T16762.tar.gz | |
Replace HsImplicitBndrs with HsOuterTyVarBndrswip/T16762
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>
80 files changed, 3170 insertions, 2484 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 56d8938886..16d8f427e9 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 2024b61b81..dcb810ed7e 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 b0216fe567..4310d1a5dd 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 76ce16948b..7515c37fb5 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 db6508d581..f6902bae18 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 }) = @@ -1815,10 +2035,6 @@ instance (OutputableBndrId p, OutputableBndrFlag flag) 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 da55ebf89e..e530110cda 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 38162298c4..72e4fe99c3 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 b22d45d182..cb990ec473 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 @@ -893,26 +882,28 @@ repC (L _ (ConDeclH98 { con_name = con } } -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 [] @@ -963,7 +954,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)]) @@ -1015,12 +1006,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. @@ -1040,15 +1038,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)) @@ -1059,8 +1056,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 @@ -1168,6 +1164,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)) @@ -1183,12 +1229,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 @@ -1227,25 +1271,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' @@ -1268,17 +1298,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)] @@ -2924,23 +2951,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 c06373eb62..70bb33b7d0 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 10727e1e17..fc0ad8a007 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 8e85c9493e..94b1ef188a 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. @@ -1480,7 +1478,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 0837cac70e..21f74a878e 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 ac92e300b5..cd5d431ee1 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 f815cd5c4a..cf6ff73057 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 ac8117e4a1..d0b4c5eab4 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 a29a8b6602..43d3231d1e 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 7661000723..a18a29b416 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -501,7 +501,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 @@ -719,18 +719,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 33c0765c69..a2ba8d1dbb 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 8b50d5e719..37dc095f71 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 97d997897f..e1077b883a 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 783e4b3773..524d97077d 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 9c67345b7f..b19598f422 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 dba5bf5874..a1004e07c6 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 170930c2ff..64be6780a3 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 94582b00a9..4ca90ff86a 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2474,14 +2474,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) @@ -2614,7 +2614,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 7f4bcdf871..1bf42d99b2 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. -} @@ -1929,7 +1950,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))} @@ -2238,6 +2259,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 8cf326bac0..e045490fb3 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -2086,7 +2086,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 3983113554..38fc88407c 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 92be85fa06..8e637a1a32 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 cc47d1e348..2c52a89248 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 e470b21ce6..7c51125730 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 71f628aa3a..308569ace0 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 d836b8d947..b47d4319dd 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 7755d3370d..b989ade11a 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -733,8 +733,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 5416e29692..debbbe1341 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -492,7 +492,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) } @@ -524,13 +524,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] @@ -599,10 +604,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 e42fe42799..0ff826bb96 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 c1202f02d7..b8e946ac11 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 5f08249e38..68ef82785d 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 0130989940..2eebda94bd 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 @@ -1727,6 +1747,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). @@ -1753,30 +1776,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 @@ -1860,6 +1881,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 8ba0eefb34..19b0667ceb 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 d41f46a4a2..0e0e795abe 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 d2ec36e5df..02daf9d742 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 d958f9a519..240108c296 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 a919095337..d642d6201c 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 2e5452129b..2d9cede53c 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 d1ff09f56c..b8cb9eedf2 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 dc48459d17..31f8b10c25 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 e869299a76..29377597ae 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 13aa2e6147..a8597046e2 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 8539599660..ae19f0a174 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 0000000000..02c2c57fcd --- /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 e8d84fe3bb..8bb939addd 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 be667ec3a6..8e2d02e9b3 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 f8f4d35768..aa20358e10 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 c9c00c9165..f4dafc0f28 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 7e1507c332..2b0b7b77b1 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 780bbdc63f..f96278a5e7 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 5f8083309c..0bee63f2b3 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 156f8490e8..90a5826266 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 7241e2f7fb..b22e6c7b5b 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 7b550b6c8f..5aa099b0f1 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 0000000000..720f8f5725 --- /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 0000000000..6335fa4c50 --- /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 0000000000..4f56c8b3e9 --- /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 0000000000..0a96f77d82 --- /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 0000000000..cad6bff33f --- /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 0000000000..ffb29b70dc --- /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 0000000000..c74c30ee47 --- /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 0000000000..5be6fbb462 --- /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 5f4ff6d18f..93b0e9aa3d 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 b0b7924444..872fe96684 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 009172537b..a509dfd665 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 e245ef0fbe..af6d93019c 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 c71b772786..002d7b27b3 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 d93b7fda9c..49bce53985 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 0cbae70733..6ea5b32e66 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 09d59fdf62..3599acef73 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 6823cadb8c..161cfe026a 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 1e17286cff..252e8ad793 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 -Subproject 3cce1bdee8c61bb6daa089059e12435178f5077 +Subproject ad9cbad7312a64e6757c32bd9488c55ba4f2fec |