diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2018-11-28 16:06:15 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2018-11-29 17:27:40 +0000 |
| commit | 2257a86daa72db382eb927df12a718669d5491f8 (patch) | |
| tree | 74bc33c17a5c898764be09eb6a9cb33572e91b2d | |
| parent | 79d5427e1f9de02c0b171bf5db46b6b49c6f85e3 (diff) | |
| download | haskell-2257a86daa72db382eb927df12a718669d5491f8.tar.gz | |
Taming the Kind Inference Monster
My original goal was (Trac #15809) to move towards using level numbers
as the basis for deciding which type variables to generalise, rather
than searching for the free varaibles of the environment. However
it has turned into a truly major refactoring of the kind inference
engine.
Let's deal with the level-numbers part first:
* Augment quantifyTyVars to calculate the type variables to
quantify using level numbers, and compare the result with
the existing approach. That is; no change in behaviour,
just a WARNing if the two approaches give different answers.
* To do this I had to get the level number right when calling
quantifyTyVars, and this entailed a bit of care, especially
in the code for kind-checking type declarations.
* However, on the way I was able to eliminate or simplify
a number of calls to solveEqualities.
This work is incomplete: I'm not /using/ level numbers yet.
When I subsequently get rid of any remaining WARNings in
quantifyTyVars, that the level-number answers differ from
the current answers, then I can rip out the current
"free vars of the environment" stuff.
Anyway, this led me into deep dive into kind inference for type and
class declarations, which is an increasingly soggy part of GHC.
Richard already did some good work recently in
commit 5e45ad10ffca1ad175b10f6ef3327e1ed8ba25f3
Date: Thu Sep 13 09:56:02 2018 +0200
Finish fix for #14880.
The real change that fixes the ticket is described in
Note [Naughty quantification candidates] in TcMType.
but I kept turning over stones. So this patch has ended up
with a pretty significant refactoring of that code too.
Kind inference for types and classes
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Major refactoring in the way we generalise the inferred kind of
a TyCon, in kcTyClGroup. Indeed, I made it into a new top-level
function, generaliseTcTyCon. Plus a new Note to explain it
Note [Inferring kinds for type declarations].
* We decided (Trac #15592) not to treat class type variables specially
when dealing with Inferred/Specified/Required for associated types.
That simplifies things quite a bit. I also rewrote
Note [Required, Specified, and Inferred for types]
* Major refactoring of the crucial function kcLHsQTyVars:
I split it into
kcLHsQTyVars_Cusk and kcLHsQTyVars_NonCusk
because the two are really quite different. The CUSK case is
almost entirely rewritten, and is much easier because of our new
decision not to treat the class variables specially
* I moved all the error checks from tcTyClTyVars (which was a bizarre
place for it) into generaliseTcTyCon and/or the CUSK case of
kcLHsQTyVars. Now tcTyClTyVars is extremely simple.
* I got rid of all the all the subtleties in tcImplicitTKBndrs. Indeed
now there is no difference between tcImplicitTKBndrs and
kcImplicitTKBndrs; there is now a single bindImplicitTKBndrs.
Same for kc/tcExplicitTKBndrs. None of them monkey with level
numbers, nor build implication constraints. scopeTyVars is gone
entirely, as is kcLHsQTyVarBndrs. It's vastly simpler.
I found I could get rid of kcLHsQTyVarBndrs entirely, in favour of
the bnew bindExplicitTKBndrs.
Quantification
~~~~~~~~~~~~~~
* I now deal with the "naughty quantification candidates"
of the previous patch in candidateQTyVars, rather than in
quantifyTyVars; see Note [Naughty quantification candidates]
in TcMType.
I also killed off closeOverKindsCQTvs in favour of the same
strategy that we use for tyCoVarsOfType: namely, close over kinds
at the occurrences.
And candidateQTyVars no longer needs a gbl_tvs argument.
* Passing the ContextKind, rather than the expected kind itself,
to tc_hs_sig_type_and_gen makes it easy to allocate the expected
result kind (when we are in inference mode) at the right level.
Type families
~~~~~~~~~~~~~~
* I did a major rewrite of the impenetrable tcFamTyPats. The result
is vastly more comprehensible.
* I got rid of kcDataDefn entirely, quite a big function.
* I re-did the way that checkConsistentFamInst works, so
that it allows alpha-renaming of invisible arguments.
* The interaction of kind signatures and family instances is tricky.
Type families: see Note [Apparently-nullary families]
Data families: see Note [Result kind signature for a data family instance]
and Note [Eta-reduction for data families]
* The consistent instantation of an associated type family is tricky.
See Note [Checking consistent instantiation] and
Note [Matching in the consistent-instantation check]
in TcTyClsDecls. It's now checked in TcTyClsDecls because that is
when we have the relevant info to hand.
* I got tired of the compromises in etaExpandFamInst, so I did the
job properly by adding a field cab_eta_tvs to CoAxBranch.
See Coercion.etaExpandCoAxBranch.
tcInferApps and friends
~~~~~~~~~~~~~~~~~~~~~~~
* I got rid of the mysterious and horrible ClsInstInfo argument
to tcInferApps, checkExpectedKindX, and various checkValid
functions. It was horrible!
* I got rid of [Type] result of tcInferApps. This list was used
only in tcFamTyPats, when checking the LHS of a type instance;
and if there is a cast in the middle, the list is meaningless.
So I made tcInferApps simpler, and moved the complexity
(not much) to tcInferApps.
Result: tcInferApps is now pretty comprehensible again.
* I refactored the many function in TcMType that instantiate skolems.
Smaller things
* I rejigged the error message in checkValidTelescope; I think it's
quite a bit better now.
* checkValidType was not rejecting constraints in a kind signature
forall (a :: Eq b => blah). blah2
That led to further errors when we then do an ambiguity check.
So I make checkValidType reject it more aggressively.
* I killed off quantifyConDecl, instead calling kindGeneralize
directly.
* I fixed an outright bug in tyCoVarsOfImplic, where we were not
colleting the tyvar of the kind of the skolems
* Renamed ClsInstInfo to AssocInstInfo, and made it into its
own data type
* Some fiddling around with pretty-printing of family
instances which was trickier than I thought. I wanted
wildcards to print as plain "_" in user messages, although
they each need a unique identity in the CoAxBranch.
Some other oddments
* Refactoring around the trace messages from reportUnsolved.
* A bit of extra tc-tracing in TcHsSyn.commitFlexi
This patch fixes a raft of bugs, and includes tests for them.
* #14887
* #15740
* #15764
* #15789
* #15804
* #15817
* #15870
* #15874
* #15881
157 files changed, 3784 insertions, 3112 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index b7435e5b54..de4fd122b3 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -74,6 +74,7 @@ import Class import Name import PrelNames import Var +import VarSet( emptyVarSet ) import Outputable import Util import BasicTypes @@ -1487,7 +1488,7 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta rhs parent gadt_syn where - binders = mkTyConBindersPreferAnon ktvs liftedTypeKind + binders = mkTyConBindersPreferAnon ktvs emptyVarSet buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 3032c0ccd8..b474c64ca6 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -859,9 +859,10 @@ avoidClashesOccEnv env occs = go env emptyUFM occs tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName env occ@(OccName occ_sp fs) | not (fs `elemUFM` env) - && (fs /= fsLit "_") - -- See Note [Always number wildcard types when tidying] - = (addToUFM env fs 1, occ) -- Desired OccName is free + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + | otherwise = case lookupUFM env base1 of Nothing -> (addToUFM env base1 2, OccName occ_sp base1) @@ -887,33 +888,6 @@ tidyOccName env occ@(OccName occ_sp fs) -- If they are the same (n==1), the former wins -- See Note [TidyOccEnv] -{- -Note [Always number wildcard types when tidying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from the DataFamilyInstanceLHS test case): - - data family Sing (a :: k) - data instance Sing (_ :: MyKind) where - SingA :: Sing A - SingB :: Sing B - -If we're not careful during tidying, then when this program is compiled with --ddump-types, we'll get the following information: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ - -Yikes! We shouldn't have a wildcard type appearing on the RHS like that. To -avoid this issue, during tidying, we always opt to add a numeric suffix to -types that are simply `_`. That way, you instead end up with: - - COERCION AXIOMS - axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 - -Which is at least legal syntax. --} {- ************************************************************************ diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 3e4844772d..b2ab8d8b1a 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -70,7 +70,7 @@ module VarEnv ( -- * TidyEnv and its operation TidyEnv, - emptyTidyEnv + emptyTidyEnv, mkEmptyTidyEnv ) where import GhcPrelude @@ -402,6 +402,9 @@ type TidyEnv = (TidyOccEnv, VarEnv Var) emptyTidyEnv :: TidyEnv emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + {- ************************************************************************ * * diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index d5f5f39682..8ab0fbfd80 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1958,11 +1958,12 @@ lintCoercion co@(AxiomInstCo con ind cos) (zip3 (ktvs ++ cvs) roles cos) ; let lhs' = substTys subst_l lhs rhs' = substTy subst_r rhs + fam_tc = coAxiomTyCon con ; case checkAxInstCo co of Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch con bad_branch + pprCoAxBranch fam_tc bad_branch Nothing -> return () - ; let s2 = mkTyConApp (coAxiomTyCon con) lhs' + ; let s2 = mkTyConApp fam_tc lhs' ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } where bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 0ff36aa712..246f8f9b9b 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -37,7 +37,8 @@ module HsDecls ( -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, - DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS, + DataFamInstDecl(..), LDataFamInstDecl, + pprDataFamInstFlavour, pprHsFamInstLHS, FamInstEqn, LFamInstEqn, FamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, HsTyPats, @@ -701,7 +702,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdRhs = rhs }) = hang (text "type" <+> - pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals) + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals) 4 (ppr rhs) ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -723,8 +724,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where pprLHsBindsForUser methods sigs) ] where top_matter = text "class" - <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) + <+> pp_vanilla_decl_head lclas tyvars fixity context <+> pprFundeps (map unLoc fds) + ppr (XTyClDecl x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) @@ -743,10 +745,10 @@ pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) => Located (IdP (GhcPass p)) -> LHsQTyVars (GhcPass p) -> LexicalFixity - -> HsContext (GhcPass p) + -> LHsContext (GhcPass p) -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context - = hsep [pprHsContext context, pp_tyvars tyvars] + = hsep [pprLHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) | fixity == Infix && length varsr > 1 @@ -1109,7 +1111,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdResultSig = L _ result , fdInjectivityAnn = mb_inj }) = vcat [ pprFlavour info <+> pp_top_level <+> - pp_vanilla_decl_head ltycon tyvars fixity [] <+> + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> pp_kind <+> pp_inj <+> pp_where , nest 2 $ pp_eqns ] where @@ -1399,10 +1401,10 @@ hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta pp_data_defn :: (OutputableBndrId (GhcPass p)) - => (HsContext (GhcPass p) -> SDoc) -- Printing the header + => (LHsContext (GhcPass p) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context +pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) @@ -1453,7 +1455,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con : map (pprHsType . unLoc) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) - cxt = fromMaybe (noLoc []) mcxt + cxt = fromMaybe noLHsContext mcxt pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars , con_mb_cxt = mcxt, con_args = args @@ -1466,7 +1468,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) - cxt = fromMaybe (noLoc []) mcxt + cxt = fromMaybe noLHsContext mcxt ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty @@ -1704,12 +1706,12 @@ ppr_instance_keyword NotTopLevel = empty ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) => TyFamInstEqn (GhcPass p) -> SDoc -ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon +ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }}) - = pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs + = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x @@ -1719,7 +1721,7 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon , feqn_pats = tvs , feqn_fixity = fixity , feqn_rhs = rhs })) - = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] + = text "type" <+> pp_vanilla_decl_head tycon tvs fixity noLHsContext <+> equals <+> ppr rhs ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x @@ -1730,7 +1732,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = tycon + FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity @@ -1738,10 +1740,9 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = = pp_data_defn pp_hdr defn where pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing - -- No need to pass an explicit kind signature to - -- pprFamInstLHS here, since pp_data_defn already - -- pretty-prints that. See #14817. + <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt + -- pp_data_defn pretty-prints the kind sig. See #14817. + pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) = ppr x pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) @@ -1759,35 +1760,28 @@ pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) = ppr x -pprFamInstLHS :: (OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) +pprHsFamInstLHS :: (OutputableBndrId (GhcPass p)) + => IdP (GhcPass p) -> Maybe [LHsTyVarBndr (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity - -> HsContext (GhcPass p) - -> Maybe (LHsKind (GhcPass p)) + -> LHsContext (GhcPass p) -> SDoc -pprFamInstLHS thing bndrs typats fixity context mb_kind_sig - -- explicit type patterns - = hsep [ pprHsContext context, pprHsExplicitForAll bndrs - , pp_pats typats, pp_kind_sig ] +pprHsFamInstLHS thing bndrs typats fixity mb_ctxt + = hsep [ pprHsExplicitForAll bndrs + , pprLHsContext mb_ctxt + , pp_pats typats ] where pp_pats (patl:patr:pats) | Infix <- fixity - = let pp_op_app = hsep [ ppr patl, pprInfixOcc (unLoc thing), ppr patr ] in + = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in case pats of [] -> pp_op_app _ -> hsep (parens pp_op_app : map ppr pats) - pp_pats pats = hsep [ pprPrefixOcc (unLoc thing) + pp_pats pats = hsep [ pprPrefixOcc thing , hsep (map ppr pats)] - pp_kind_sig - | Just k <- mb_kind_sig - = dcolon <+> ppr k - | otherwise - = empty - instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ClsInstDecl p) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index bc909cfe90..993b0202d8 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -24,7 +24,7 @@ module HsTypes ( HsWildCardBndrs(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), - HsContext, LHsContext, + HsContext, LHsContext, noLHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, @@ -63,7 +63,7 @@ module HsTypes ( -- Printing pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, - pprHsContext, pprHsContextNoArrow, pprHsContextMaybe, + pprLHsContext, hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext ) where @@ -90,7 +90,6 @@ import FastString import Maybes( isJust ) import Data.Data hiding ( Fixity, Prefix, Infix ) -import Data.Maybe ( fromMaybe ) {- ************************************************************************ @@ -264,9 +263,16 @@ quantified in left-to-right order in kind signatures is nice since: -- | Located Haskell Context type LHsContext pass = Located (HsContext pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' - -- For details on above see note [Api annotations] in ApiAnnotation +noLHsContext :: LHsContext pass +-- Use this when there is no context in the original program +-- It would really be more kosher to use a Maybe, to distinguish +-- class () => C a where ... +-- from +-- class C a where ... +noLHsContext = noLoc [] + -- | Haskell Context type HsContext pass = [LHsType pass] @@ -1126,7 +1132,7 @@ splitLHsForAllTy body = ([], body) splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy body = (noLoc [], body) +splitLHsQualTy body = (noLHsContext, body) splitLHsInstDeclTy :: LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn) @@ -1307,7 +1313,7 @@ pprHsForAllExtra :: (OutputableBndrId (GhcPass p)) => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAllExtra extra qtvs cxt - = pp_forall <+> pprHsContextExtra (isJust extra) (unLoc cxt) + = pp_forall <+> pprLHsContextExtra (isJust extra) cxt where pp_forall | null qtvs = whenPprDebug (forAllLit <> dot) | otherwise = forAllLit <+> interppSP qtvs <> dot @@ -1319,36 +1325,28 @@ pprHsExplicitForAll :: (OutputableBndrId (GhcPass p)) pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot pprHsExplicitForAll Nothing = empty -pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc -pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe - -pprHsContextNoArrow :: (OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc -pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe - -pprHsContextMaybe :: (OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> Maybe SDoc -pprHsContextMaybe [] = Nothing -pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred -pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) +pprLHsContext :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContext lctxt + | null (unLoc lctxt) = empty + | otherwise = pprLHsContextAlways lctxt -- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (OutputableBndrId (GhcPass p)) - => HsContext (GhcPass p) -> SDoc -pprHsContextAlways [] = parens empty <+> darrow -pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow -pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow +pprLHsContextAlways :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContextAlways (L _ ctxt) + = case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_mono_ty ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndrId (GhcPass p)) - => Bool -> HsContext (GhcPass p) -> SDoc -pprHsContextExtra show_extra ctxt - | not show_extra - = pprHsContext ctxt - | null ctxt - = char '_' <+> darrow - | otherwise - = parens (sep (punctuate comma ctxt')) <+> darrow +pprLHsContextExtra :: (OutputableBndrId (GhcPass p)) + => Bool -> LHsContext (GhcPass p) -> SDoc +pprLHsContextExtra show_extra lctxt@(L _ ctxt) + | not show_extra = pprLHsContext lctxt + | null ctxt = char '_' <+> darrow + | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow where ctxt' = map ppr ctxt ++ [char '_'] @@ -1386,10 +1384,10 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) - = sep [pprHsForAll tvs (noLoc []), ppr_mono_lty ty] + = sep [pprHsForAll tvs noLHsContext, ppr_mono_lty ty] -ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) - = sep [pprHsContextAlways ctxt, ppr_mono_lty ty] +ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) + = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 2e63fbc22f..1bf4ca9c81 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -211,12 +211,13 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem -- This is just like CoAxBranch -data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbCoVars :: [IfaceIdBndr] - , ifaxbLHS :: IfaceAppArgs - , ifaxbRoles :: [Role] - , ifaxbRHS :: IfaceType - , ifaxbIncomps :: [BranchIndex] } +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbEtaTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceAppArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom data IfaceConDecls @@ -556,11 +557,19 @@ pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc -- The TyCon might be local (just an OccName), or this might -- be a branch for an imported TyCon, so it would be an ExtName -- So it's easier to take an SDoc here +-- +-- This function is used +-- to print interface files, +-- in debug messages +-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon +-- For user error messages we use Coercion.pprCoAxiom and friends pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs , ifaxbLHS = pat_tys , ifaxbRHS = rhs , ifaxbIncomps = incomps }) - = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) + hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ nest 2 maybe_incomps where @@ -890,10 +899,9 @@ pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon , ifAxBranches = branches }) - = hang (text "axiom" <+> ppr name <> dcolon) + = hang (text "axiom" <+> ppr name <+> dcolon) 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) - pprCType :: Maybe CType -> SDoc pprCType Nothing = Outputable.empty pprCType (Just cType) = text "C type:" <+> ppr cType @@ -1073,13 +1081,14 @@ instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, ifRuleOrph = orph }) - = sep [hsep [pprRuleName name, - if isOrphan orph then text "[orphan]" else Outputable.empty, - ppr act, - text "forall" <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - text "=" <+> ppr rhs]) - ] + = sep [ hsep [ pprRuleName name + , if isOrphan orph then text "[orphan]" else Outputable.empty + , ppr act + , pp_foralls ] + , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + text "=" <+> ppr rhs]) ] + where + pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot instance Outputable IfaceClsInst where ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag @@ -1856,13 +1865,14 @@ instance Binary IfaceAT where return (IfaceAT dec defs) instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 get bh = do a1 <- get bh a2 <- get bh @@ -1870,7 +1880,8 @@ instance Binary IfaceAxBranch where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index e3d1b824be..acd6c46bb6 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -22,6 +22,7 @@ module MkIface ( RecompileRequired(..), recompileRequired, mkIfaceExports, + coAxiomToIfaceDecl, tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -1634,18 +1635,16 @@ coAxBranchToIfaceBranch tc lhs_s -- use this one for standalone branches without incompatibles coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_eta_tvs = eta_tvs , cab_lhs = lhs , cab_roles = roles, cab_rhs = rhs }) - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs - , ifaxbCoVars = map toIfaceIdBndr cvs - , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs - , ifaxbRoles = roles - , ifaxbRHS = tidyToIfaceType env1 rhs - , ifaxbIncomps = [] } - where - (env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs - -- Don't re-bind in-scope tyvars - -- See Note [CoAxBranch type variables] in CoAxiom + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs + , ifaxbLHS = toIfaceTcArgs tc lhs + , ifaxbRoles = roles + , ifaxbRHS = toIfaceType rhs + , ifaxbIncomps = [] } ----------------- tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) @@ -1708,6 +1707,7 @@ tyConToIfaceDecl env tycon (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) tc_tyvars = binderVars tc_binders if_binders = toIfaceTyCoVarBinders tc_binders + -- No tidying of the binders; they are already tidy if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) if_syn_type ty = tidyToIfaceType tc_env1 ty if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon @@ -1718,19 +1718,16 @@ tyConToIfaceDecl env tycon (tidyToIfaceTcArgs tc_env1 tc ty) Nothing -> IfNoParent - to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon + to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) where defs = fromBranches $ coAxiomBranches ax ibr = map (coAxBranchToIfaceBranch' tycon) defs axn = coAxiomName ax - to_if_fam_flav (ClosedSynFamilyTyCon Nothing) - = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon - to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 34bcdb7cd5..29893ca319 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -857,17 +857,24 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] tc_ax_branch prev_branches - (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs + (IfaceAxBranch { ifaxbTyVars = tv_bndrs + , ifaxbEtaTyVars = eta_tv_bndrs + , ifaxbCoVars = cv_bndrs , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyConBinders_AT (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom bindIfaceIds cv_bndrs $ \ cvs -> do - { tc_lhs <- tcIfaceAppArgs lhs - ; tc_rhs <- tcIfaceType rhs - ; let br = CoAxBranch { cab_loc = noSrcSpan + { tc_lhs <- tcIfaceAppArgs lhs + ; tc_rhs <- tcIfaceType rhs + ; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return + ; this_mod <- getIfModule + ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS` + moduleNameFS (moduleName this_mod)) + br = CoAxBranch { cab_loc = loc , cab_tvs = binderVars tvs + , cab_eta_tvs = eta_tvs , cab_cvs = cvs , cab_lhs = tc_lhs , cab_roles = roles @@ -1768,6 +1775,13 @@ bindIfaceTyVar (occ,kind) thing_inside ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars [] thing_inside = thing_inside [] +bindIfaceTyVars (bndr:bndrs) thing_inside + = bindIfaceTyVar bndr $ \tv -> + bindIfaceTyVars bndrs $ \tvs -> + thing_inside (tv : tvs) + mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind diff --git a/compiler/nativeGen/CFG.hs b/compiler/nativeGen/CFG.hs index 820785995e..b5b0fd7ca9 100644 --- a/compiler/nativeGen/CFG.hs +++ b/compiler/nativeGen/CFG.hs @@ -489,7 +489,6 @@ getCfgProc weights (CmmProc _info _lab _live graph) | null (toBlockList graph) = mapEmpty | otherwise = getCfg weights graph - getCfg :: D.CfgWeights -> CmmGraph -> CFG getCfg weights graph = foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 8c78fb5a0e..9712034b7a 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -871,12 +871,12 @@ equalsDots = text "= ..." checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () -checkDatatypeContext (Just (dL->L loc c)) +checkDatatypeContext (Just c) = do allowed <- extension datatypeContextsEnabled unless allowed $ - parseErrorSDoc loc - (text "Illegal datatype context (use DatatypeContexts):" <+> - pprHsContext c) + parseErrorSDoc (getLoc c) + (text "Illegal datatype context (use DatatypeContexts):" + <+> pprLHsContext c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 4147cff53b..10034de650 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -255,12 +255,17 @@ mkTemplateKindVars :: [Kind] -> [TyVar] -- k0 with unique (mkAlphaTyVarUnique 0) -- k1 with unique (mkAlphaTyVarUnique 1) -- ... etc +mkTemplateKindVars [kind] + = [mkTyVar (mk_tv_name 0 "k") kind] + -- Special case for one kind: just "k" + mkTemplateKindVars kinds - = [ mkTyVar name kind - | (kind, u) <- kinds `zip` [0..] - , let occ = mkTyVarOccFS (mkFastString ('k' : show u)) - name = mkInternalName (mkAlphaTyVarUnique u) occ noSrcSpan - ] + = [ mkTyVar (mk_tv_name u ('k' : show u)) kind + | (kind, u) <- kinds `zip` [0..] ] +mk_tv_name :: Int -> String -> Name +mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString s)) + noSrcSpan mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] -- a with unique (mkAlphaTyVarUnique n) @@ -275,9 +280,7 @@ mkTemplateTyVarsFrom n kinds let ch_ord = index + ord 'a' name_str | ch_ord <= ord 'z' = [chr ch_ord] | otherwise = 't':show index - uniq = mkAlphaTyVarUnique (index + n) - name = mkInternalName uniq occ noSrcSpan - occ = mkTyVarOccFS (mkFastString name_str) + name = mk_tv_name (index + n) name_str ] mkTemplateTyVars :: [Kind] -> [TyVar] diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs index 37057a1c41..c777c4b381 100644 --- a/compiler/typecheck/ClsInst.hs +++ b/compiler/typecheck/ClsInst.hs @@ -3,7 +3,8 @@ module ClsInst ( matchGlobalInst, ClsInstResult(..), - InstanceWhat(..), safeOverlap + InstanceWhat(..), safeOverlap, + AssocInstInfo(..), isNotAssociated ) where #include "HsVersions.h" @@ -30,6 +31,7 @@ import Type import MkCore ( mkStringExprFS, mkNaturalExpr ) import Name ( Name ) +import VarEnv ( VarEnv ) import DataCon import TyCon import Class @@ -40,6 +42,30 @@ import Data.Maybe {- ******************************************************************* * * + A helper for associated types within + class instance declarations +* * +**********************************************************************-} + +-- | Extra information about the parent instance declaration, needed +-- when type-checking associated types. The 'Class' is the enclosing +-- class, the [TyVar] are the /scoped/ type variable of the instance decl. +-- The @VarEnv Type@ maps class variables to their instance types. +data AssocInstInfo + = NotAssociated + | InClsInst { ai_class :: Class + , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance + , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types + -- See Note [Matching in the consistent-instantation check] + } + +isNotAssociated :: AssocInstInfo -> Bool +isNotAssociated NotAssociated = True +isNotAssociated (InClsInst {}) = False + + +{- ******************************************************************* +* * Class lookup * * **********************************************************************-} diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 100919eb16..623d465e63 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -696,14 +696,13 @@ environments (one for the EPS and one for the HPT). checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - no_conflicts = null conflicts ; traceTc "checkForConflicts" $ vcat [ ppr (map fim_instance conflicts) , ppr fam_inst -- , ppr inst_envs ] - ; unless no_conflicts $ conflictInstErr fam_inst conflicts - ; return no_conflicts } + ; reportConflictInstErr fam_inst conflicts + ; return (null conflicts) } -- | Check whether a new open type family equation can be added without -- violating injectivity annotation supplied by the user. Returns True when @@ -739,9 +738,9 @@ makeInjectivityErrors fi_ax axiom inj conflicts = ASSERT2( any id inj, text "No injective type variables" ) let lhs = coAxBranchLHS axiom rhs = coAxBranchRHS axiom - + fam_tc = coAxiomTyCon fi_ax are_conflicts = not $ null conflicts - unused_inj_tvs = unusedInjTvsInRHS (coAxiomTyCon fi_ax) inj lhs rhs + unused_inj_tvs = unusedInjTvsInRHS fam_tc inj lhs rhs inj_tvs_unused = not $ and (isEmptyVarSet <$> unused_inj_tvs) tf_headed = isTFHeaded rhs bare_variables = bareTvInRHSViolated lhs rhs @@ -749,7 +748,7 @@ makeInjectivityErrors fi_ax axiom inj conflicts err_builder herald eqns = ( hang herald - 2 (vcat (map (pprCoAxBranch fi_ax) eqns)) + 2 (vcat (map (pprCoAxBranchUser fam_tc) eqns)) , coAxBranchSpan (head eqns) ) errorIf p f = if p then [f err_builder axiom] else [] in errorIf are_conflicts (conflictInjInstErr conflicts ) @@ -850,16 +849,6 @@ bareTvInRHSViolated pats rhs | isTyVarTy rhs bareTvInRHSViolated _ _ = [] -conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () -conflictInstErr fam_inst conflictingMatch - | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch - = let (err, span) = makeFamInstsErr - (text "Conflicting family instance declarations:") - [fam_inst, confInst] - in setSrcSpan span $ addErr err - | otherwise - = panic "conflictInstErr" - -- | Type of functions that use error message and a list of axioms to build full -- error message (with a source location) for injective type families. type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan) @@ -933,18 +922,21 @@ bareVariableInRHSErr tys errorBuilder famInst text "variables:" <+> pprQuotedList tys) [famInst] -makeFamInstsErr :: SDoc -> [FamInst] -> (SDoc, SrcSpan) -makeFamInstsErr herald insts - = ASSERT( not (null insts) ) - ( hang herald - 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 - | fi <- sorted ]) - , srcSpan ) +reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +reportConflictInstErr _ [] + = return () -- No conflicts +reportConflictInstErr fam_inst (match1 : _) + | FamInstMatch { fim_instance = conf_inst } <- match1 + , let sorted = sortWith getSpan [fam_inst, conf_inst] + fi1 = head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + = setSrcSpan span $ addErr $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) where getSpan = getSrcLoc . famInstAxiom - sorted = sortWith getSpan insts - fi1 = head sorted - srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 4f380d37a8..afc6370c17 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -484,17 +484,28 @@ no longer cut it, but it seems fine for now. -} --------------------------- --- | This is used to instantiate binders when type-checking *types* only. --- The @VarEnv Kind@ gives some known instantiations. +-- | Instantantiate the TyConBinders of a forall type, +-- given its decomposed form (tvs, ty) +tcInstTyBinders :: HasDebugCallStack + => ([TyCoBinder], TcKind) -- ^ The type (forall bs. ty) + -> TcM ([TcType], TcKind) -- ^ Instantiated bs, substituted ty +-- Takes a pair because that is what splitPiTysInvisible returns -- See also Note [Bidirectional type checking] -tcInstTyBinders :: TCvSubst -> Maybe (VarEnv Kind) - -> [TyBinder] -> TcM (TCvSubst, [TcType]) -tcInstTyBinders subst mb_kind_info bndrs - = do { (subst, args) <- mapAccumLM (tcInstTyBinder mb_kind_info) subst bndrs - ; traceTc "instantiating tybinders:" - (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg) - bndrs args) - ; return (subst, args) } +tcInstTyBinders (bndrs, ty) + | null bndrs -- It's fine for bndrs to be empty e.g. + = return ([], ty) -- Check that (Maybe :: forall {k}. k->*), + -- and see the call to instTyBinders in checkExpectedKind + -- A user bug to be reported as such; it is not a compiler crash! + + | otherwise + = do { (subst, args) <- mapAccumLM (tcInstTyBinder Nothing) empty_subst bndrs + ; ty' <- zonkTcType (substTy subst ty) + -- Why zonk the result? So that tcTyVar can + -- obey (IT6) of Note [The tcType invariant] in TcHsType + -- ToDo: SLPJ: I don't think this is needed + ; return (args, ty') } + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) -- | Used only in *types* tcInstTyBinder :: Maybe (VarEnv Kind) diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 73f39eda1d..f3611921ea 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -208,7 +208,7 @@ check_inst sig_inst = do (tvs, theta, pred) }} origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - (cts, tclvl) <- pushTcLevelM $ do + (tclvl,cts) <- pushTcLevelM $ do wanted <- newWanted origin (Just TypeLevel) (substTy skol_subst pred) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 11a0e20828..abdce588a3 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1451,7 +1451,6 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvFromSig sig_inst thing_inside | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs] = tcExtendNameTyVarEnv wcs $ tcExtendNameTyVarEnv skol_prs $ thing_inside @@ -1591,29 +1590,6 @@ Example for (E2), we generate The beta is untoucable, but floats out of the constraint and can be solved absolutely fine. -Note [Use tcExtendTyVar not scopeTyVars in tcRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, any place that corresponds to Λ or ∀ in Core should be flagged -with a call to scopeTyVars, which arranges for an implication constraint -to be made, bumps the TcLevel, and (crucially) prevents a unification -variable created outside the scope of a local skolem to unify with that -skolem. - -We do not need to do this here, however. - -- Note that this happens only in the case of a partial signature. - Complete signatures go via tcPolyCheck, not tcPolyInfer. - -- The TcLevel is incremented in tcPolyInfer, right outside the call - to tcMonoBinds. We thus don't have to worry about outer metatvs unifying - with local skolems. - -- The other potential concern is that we need SkolemInfo associated with - the skolems. This, too, is OK, though: the constraints pass through - simplifyInfer (which doesn't report errors), at the end of which - the skolems will get quantified and put into an implication constraint. - Thus, by the time any errors are reported, the SkolemInfo will be - in place. ************************************************************************ * * diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index fe29c3d1d0..f085e07f14 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -198,9 +198,6 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; let tc_item = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn - -- tcExtendTyVarEnv here (instead of scopeTyVars) is OK: - -- the tcDefMeth calls checkConstraints to bump the TcLevel - -- and make the implication constraint ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_item op_items @@ -517,7 +514,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) tvs' = scopedSort tv' cvs' = scopedSort cv' ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' fam_tc pat_tys' rhs' -- NB: no validity check. We check validity of default instances -- in the class definition. Because type instance arguments cannot diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 4ee0f23de0..e2a314c6a2 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -617,7 +617,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode)) ; traceTc "Deriving strategy (standalone deriving)" $ vcat [ppr mb_deriv_strat, ppr deriv_ty] ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys')) - <- tcDerivStrategy ctxt mb_deriv_strat $ do + <- tcDerivStrategy mb_deriv_strat $ do (tvs, deriv_ctxt, cls, inst_tys) <- tcStandaloneDerivInstType ctxt deriv_ty pure (tvs, (deriv_ctxt, cls, inst_tys)) @@ -718,19 +718,19 @@ tcStandaloneDerivInstType ctxt | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body , L _ [wc_pred] <- theta , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred - = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys) - <- tcHsClsInstType ctxt $ - HsIB { hsib_ext = vars - , hsib_body - = L (getLoc deriv_ty_body) $ - HsForAllTy { hst_bndrs = tvs - , hst_xforall = noExt - , hst_body = rho }} - pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys) + = do dfun_ty <- tcHsClsInstType ctxt $ + HsIB { hsib_ext = vars + , hsib_body + = L (getLoc deriv_ty_body) $ + HsForAllTy { hst_bndrs = tvs + , hst_xforall = noExt + , hst_body = rho }} + let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, InferContext (Just wc_span), cls, inst_tys) | otherwise - = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys) - <- tcHsClsInstType ctxt deriv_ty - pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys) + = do dfun_ty <- tcHsClsInstType ctxt deriv_ty + let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty + pure (tvs, SupplyContext theta, cls, inst_tys) tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcStandaloneDerivInstType" @@ -746,7 +746,8 @@ warnUselessTypeable ------------------------------------------------------------------ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance - -- Can be a data instance, hence [Type] args + -- Can be a data instance, hence [Type] args + -- and in that case the TyCon is the /family/ tycon -> Maybe (DerivStrategy GhcRn) -- The optional deriving strategy -> LHsSigType GhcRn -- The deriving predicate -> TcM (Maybe EarlyDerivSpec) @@ -759,9 +760,6 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item do { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds)) - -- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars. - -- Their kinds are fully settled. No need to worry about skolem - -- escape. <- tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention -- the type variables for the type constructor, hence tcExtendTyVarenv @@ -771,7 +769,7 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred -- Typeable is special, because Typeable :: forall k. k -> Constraint -- so the argument kind 'k' is not decomposable by splitKindFunTys -- as is the case for all other derivable type classes - tcDerivStrategy TcType.DerivClauseCtxt mb_deriv_strat $ + tcDerivStrategy mb_deriv_strat $ tcHsDeriv deriv_pred ; when (cls_arg_kinds `lengthIsNot` 1) $ @@ -786,7 +784,8 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred -- we want to drop type variables from T so that (C d (T a)) is well-kinded let (arg_kinds, _) = splitFunTys cls_arg_kind n_args_to_drop = length arg_kinds - n_args_to_keep = tyConArity tc - n_args_to_drop + n_args_to_keep = length tc_args - n_args_to_drop + -- See Note [tc_args and tycon arity] (tc_args_to_keep, args_to_drop) = splitAt n_args_to_keep tc_args inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) @@ -891,7 +890,24 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred ; return $ Just spec } } -{- +{- Note [tc_args and tycon arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if we could use (tyConArity tc) at this point, rather +than (length tc_args). But for data families the two can differ! The +tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which +in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them +from DataFamInstTyCon: + +| DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in FamInstEnv + +Notice that the arg tys might not be the same as the family tycon arity +(= length tyConTyVars). + Note [Unify kinds in deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (Trac #8534) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 3f4192fb42..b026f1d68c 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -683,7 +683,7 @@ simplifyDeriv pred tvs thetas -- with the skolemized variables. Start "one level down" because -- we are going to wrap the result in an implication with tvs_skols, -- in step [DAC RESIDUAL] - ; (wanteds, tc_lvl) <- pushTcLevelM $ + ; (tc_lvl, wanteds) <- pushTcLevelM $ mapM mk_wanteds thetas ; traceTc "simplifyDeriv inputs" $ diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 946cb5c136..d32272bfc5 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -467,18 +467,10 @@ tcExtendKindEnv extra_env thing_inside ----------------------- -- Scoped type and kind variables --- Before using this function, consider using TcHsType.scopeTyVars, which --- bumps the TcLevel and thus prevents any of these TyVars from appearing --- in kinds of tyvars in an outer scope. --- Indeed, you should always use scopeTyVars unless some other code nearby --- bumps the TcLevel. tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside --- Before using this function, consider using TcHsType.scopeTyVars2, which --- bumps the TcLevel and thus prevents any of these TyVars from appearing --- in kinds of tyvars in an outer scope. tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendNameTyVarEnv binds thing_inside -- this should be used only for explicitly mentioned scoped variables. @@ -569,7 +561,7 @@ tc_extend_local_env top_lvl extra_env thing_inside -- -- Invariant: the ATcIds are fully zonked. Reasons: -- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in zonkQuantifiedTyVar) +-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) -- (b) There are no via-Indirect occurrences of the bound variables -- in the types, because instantiation does not look through such things -- (c) The call to tyCoVarsOfTypes is ok without looking through refs diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 7c3383469d..cfd364fb47 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -148,8 +148,9 @@ reportUnsolved wanted | warn_out_of_scope = HoleWarn | otherwise = HoleDefer - ; report_unsolved binds_var type_errors expr_holes - type_holes out_of_scope_holes wanted + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted ; ev_binds <- getTcEvBindsMap binds_var ; return (evBindMapBinds ev_binds)} @@ -164,8 +165,8 @@ reportUnsolved wanted reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds - ; report_unsolved ev_binds TypeError - HoleError HoleError HoleError wanted } + ; report_unsolved TypeError HoleError HoleError HoleError + ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to -- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in @@ -173,26 +174,26 @@ reportAllUnsolved wanted warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds - ; report_unsolved ev_binds (TypeWarn NoReason) - HoleWarn HoleWarn HoleWarn wanted } + ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn + ev_binds wanted } -- | Report unsolved goals as errors or warnings. -report_unsolved :: EvBindsVar -- cec_binds - -> TypeErrorChoice -- Deferred type errors +report_unsolved :: TypeErrorChoice -- Deferred type errors -> HoleChoice -- Expression holes -> HoleChoice -- Type holes -> HoleChoice -- Out of scope holes + -> EvBindsVar -- cec_binds -> WantedConstraints -> TcM () -report_unsolved mb_binds_var type_errors expr_holes - type_holes out_of_scope_holes wanted +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted | isEmptyWC wanted = return () | otherwise - = do { traceTc "reportUnsolved warning/error settings:" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) ; wanted <- zonkWC wanted -- Zonk to reveal all information @@ -221,10 +222,11 @@ report_unsolved mb_binds_var type_errors expr_holes -- See Trac #15539 and c.f. setting ic_status -- in TcSimplify.setImplicationStatus , cec_warn_redundant = warn_redundant - , cec_binds = mb_binds_var } + , cec_binds = binds_var } ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted } + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } -------------------------------------------- -- Internal functions diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index b194eac59a..701df5ffdc 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -62,7 +62,8 @@ import SrcLoc import TyCon import TcEnv import TcType -import TcValidity ( checkValidTyFamEqn ) +import TcValidity ( checkValidCoAxBranch ) +import CoAxiom ( coAxiomSingleBranch ) import TysPrim import TysWiredIn import Type @@ -1867,11 +1868,10 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty mk_atf_inst fam_tc = do rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) rep_lhs_tys - let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs' + let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' fam_tc rep_lhs_tys rep_rhs_ty -- Check (c) from Note [GND and associated type families] in TcDeriv - checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs' - rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc + checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) newFamInst SynFamilyInst axiom where cls_tvs = classTyVars cls @@ -1888,7 +1888,6 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs rep_tvs' = scopedSort rep_tvs rep_cvs' = scopedSort rep_cvs - pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys) -- Same as inst_tys, but with the last argument type replaced by the -- representation type. diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 6372c66912..abc7d59a55 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -436,7 +436,7 @@ tc_mkRepFamInsts gk tycon inst_tys = (tv', cv') = partition isTyVar tcv' tvs' = scopedSort tv' cvs' = scopedSort cv' - axiom = mkSingleCoAxiom Nominal rep_name tvs' cvs' + axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' fam_tc inst_tys repTy' ; newFamInst SynFamilyInst axiom } diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 450a7d9a86..16cee703b8 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -40,7 +40,8 @@ module TcHsSyn ( zonkTyVarOcc, zonkCoToCo, zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX + zonkTcMethInfoToMethInfoX, + lookupTyVarOcc ) where #include "HsVersions.h" @@ -1770,9 +1771,9 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi zonk_meta mtv_env ref Flexi = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; let ty = commitFlexi flexi tv kind + ; ty <- commitFlexi flexi tv kind ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta mtv_env (commitFlexi flexi tv kind) } + ; finish_meta mtv_env ty } zonk_meta mtv_env _ (Indirect ty) = do { zty <- zonkTcTypeToTypeX env ty @@ -1783,17 +1784,27 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi ; writeTcRef mtv_env_ref mtv_env' ; return ty } -commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> Type +lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar +lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv + = lookupVarEnv tv_env tv + +commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type +-- Only monadic so we can do tc-tracing commitFlexi flexi tv zonked_kind = case flexi of - SkolemiseFlexi -> mkTyVarTy (mkTyVar name zonked_kind) - - DefaultFlexi | isRuntimeRepTy zonked_kind - -> liftedRepTy - | otherwise - -> anyTypeOfKind zonked_kind - - RuntimeUnkFlexi -> mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk) + SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) + + DefaultFlexi + | isRuntimeRepTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) + ; return liftedRepTy } + | otherwise + -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) + ; return (anyTypeOfKind zonked_kind) } + + RuntimeUnkFlexi + -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) + ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } -- This is where RuntimeUnks are born: -- otherwise-unconstrained unification variables are -- turned into RuntimeUnks as they leave the diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 1181f384fa..4a4d49b81e 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -20,16 +20,18 @@ module TcHsType ( tcHsDeriv, tcDerivStrategy, tcHsTypeApp, UserTypeCtxt(..), - tcImplicitTKBndrs, tcImplicitQTKBndrs, - tcExplicitTKBndrs, - kcExplicitTKBndrs, kcImplicitTKBndrs, + bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, + bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, + bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + ContextKind(..), -- Type checking type and class decls - kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars, - tcDataKindSig, + kcLookupTcTyCon, bindTyClTyVars, + etaExpandAlgTyCon, tcbVisibilities, -- tyvars - scopeTyVars, scopeTyVars2, + zonkAndScopedSort, -- Kind-checking types -- No kind generalisation, no checkValidType @@ -44,7 +46,7 @@ module TcHsType ( typeLevelMode, kindLevelMode, - kindGeneralize, checkExpectedKindX, instantiateTyUntilN, + kindGeneralize, checkExpectedKindX, reportFloatingKvs, -- Sort-checking kinds @@ -77,7 +79,7 @@ import TcHsSyn import TcErrors ( reportAllUnsolved ) import TcType import Inst ( tcInstTyBinders, tcInstTyBinder ) -import TyCoRep( TyCoBinder(..), TyBinder ) -- Used in tcDataKindSig +import TyCoRep( TyCoBinder(..), TyBinder ) -- Used in etaExpandAlgTyCon import Type import Coercion import RdrName( lookupLocalRdrOcc ) @@ -96,6 +98,7 @@ import SrcLoc import Constants ( mAX_CTUPLE_SIZE ) import ErrUtils( MsgDoc ) import Unique +import UniqSet import Util import UniqSupply import Outputable @@ -104,7 +107,7 @@ import PrelNames hiding ( wildCardName ) import qualified GHC.LanguageExtensions as LangExt import Maybes -import Data.List ( find, mapAccumR ) +import Data.List ( find ) import Control.Monad {- @@ -182,20 +185,24 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcHsSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () -kcHsSigType skol_info names (HsIB { hsib_body = hs_ty +kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () +kcHsSigType names (HsIB { hsib_body = hs_ty , hsib_ext = sig_vars }) = addSigCtxt (funsSigCtxt names) hs_ty $ discardResult $ - tcImplicitTKBndrs skol_info sig_vars $ + bindImplicitTKBndrs_Skol sig_vars $ tc_lhs_type typeLevelMode hs_ty liftedTypeKind -kcHsSigType _ _ (XHsImplicitBndrs _) = panic "kcHsSigType" + +kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType" tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType skol_info names sig_ty = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - tc_hs_sig_type_and_gen skol_info sig_ty liftedTypeKind + tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + -- Do not zonk-to-Type, nor perform a validity check + -- We are in a knot with the class and associated types + -- Zonking and validity checking is done by tcClassDecl tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking @@ -203,15 +210,10 @@ tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type tcHsSigType ctxt sig_ty = addSigCtxt ctxt (hsSigType sig_ty) $ do { traceTc "tcHsSigType {" (ppr sig_ty) - ; kind <- case expectedKindInCtxt ctxt of - AnythingKind -> newMetaKindVar - TheKind k -> return k - OpenKind -> newOpenTypeKind - -- The kind is checked by checkValidType, and isn't necessarily - -- of kind * in a Template Haskell quote eg [t| Maybe |] -- Generalise here: see Note [Kind generalisation] - ; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind + ; ty <- tc_hs_sig_type skol_info sig_ty + (expectedKindInCtxt ctxt) ; ty <- zonkTcType ty ; checkValidType ctxt ty @@ -220,27 +222,59 @@ tcHsSigType ctxt sig_ty where skol_info = SigTypeSkol ctxt -tc_hs_sig_type_and_gen :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type +tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn + -> ContextKind -> TcM Type -- Kind-checks/desugars an 'LHsSigType', -- solve equalities, -- and then kind-generalizes. -- This will never emit constraints, as it uses solveEqualities interally. -- No validity checking or zonking -tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext = sig_vars - , hsib_body = hs_ty }) kind - = do { ((tkvs, ty), wanted) <- captureConstraints $ - tcImplicitTKBndrs skol_info sig_vars $ - tc_lhs_type typeLevelMode hs_ty kind - -- Any remaining variables (unsolved in the solveLocalEqualities - -- in the tcImplicitTKBndrs) should be in the global tyvars, - -- and therefore won't be quantified over - - ; let ty1 = mkSpecForAllTys tkvs ty +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))) + <- pushTcLevelM $ + solveLocalEqualitiesX "tc_hs_sig_type" $ + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + + ; tc_lhs_type typeLevelMode hs_ty kind } + -- Any remaining variables (unsolved in the solveLocalEqualities) + -- should be in the global tyvars, and therefore won't be quantified + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty ; kvs <- kindGeneralizeLocal wanted ty1 - ; emitConstraints wanted -- we still need to solve these + ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) + tc_lvl wanted + ; return (mkInvForAllTys kvs ty1) } -tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen" +tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen" + +tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type +-- tcTopLHsType is used for kind-checking top-level HsType 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 +tcTopLHsType hs_sig_type ctxt_kind + | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type + = do { traceTc "tcTopLHsType {" (ppr hs_ty) + ; (spec_tkvs, ty) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Skol sig_vars $ + do { kind <- newExpectedKind ctxt_kind + ; tc_lhs_type typeLevelMode hs_ty kind } + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralize ty1 + ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) + ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) + ; return final_ty} + +tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType" ----------------- tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind])) @@ -251,18 +285,13 @@ tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind])) -- returns ([k], C, [k, Int], [k->k]) -- Return values are fully zonked tcHsDeriv hs_ty - = do { cls_kind <- newMetaKindVar - -- always safe to kind-generalize, because there - -- can be no covars in an outer scope - ; ty <- checkNoErrs $ - -- avoid redundant error report with "illegal deriving", below - tc_hs_sig_type_and_gen (SigTypeSkol DerivClauseCtxt) hs_ty cls_kind - ; cls_kind <- zonkTcTypeToType cls_kind - ; ty <- zonkTcTypeToType ty - ; let (tvs, pred) = splitForAllTys ty - ; let (args, _) = splitFunTys cls_kind + = do { ty <- checkNoErrs $ -- Avoid redundant error report + -- with "illegal deriving", below + tcTopLHsType hs_ty AnyKind + ; let (tvs, pred) = splitForAllTys ty + (kind_args, _) = splitFunTys (typeKind pred) ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, (cls, tys, args)) + Just (cls, tys) -> return (tvs, (cls, tys, kind_args)) Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } -- | Typecheck something within the context of a deriving strategy. @@ -278,15 +307,14 @@ tcHsDeriv hs_ty -- the type variable @a@. tcDerivStrategy :: forall a. - UserTypeCtxt - -> Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy + Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the -- deriving strategy, which might quantify some type -- variables of its own. -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a) -- ^ The typechecked deriving strategy, all quantified tyvars, and -- the payload of the typechecked thing. -tcDerivStrategy user_ctxt mds thing_inside +tcDerivStrategy mds thing_inside = case mds of Nothing -> boring_case Nothing Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds @@ -298,10 +326,8 @@ tcDerivStrategy user_ctxt mds thing_inside tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy tc_deriv_strategy (ViaStrategy ty) = do - cls_kind <- newMetaKindVar ty' <- checkNoErrs $ - tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) ty cls_kind - ty' <- zonkTcTypeToType ty' + tcTopLHsType ty AnyKind let (via_tvs, via_pred) = splitForAllTys ty' tcExtendTyVarEnv via_tvs $ do (thing_tvs, thing) <- thing_inside @@ -314,20 +340,18 @@ tcDerivStrategy user_ctxt mds thing_inside tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> LHsSigType GhcRn - -> TcM ([TyVar], ThetaType, Class, [Type]) + -> TcM Type -- Like tcHsSigType, but for a class instance declaration tcHsClsInstType user_ctxt hs_inst_ty = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ - {- We want to fail here if the tc_hs_sig_type_and_gen emits constraints. - First off, we know we'll never solve the constraints, as classes are - always at top level, and their constraints do not inform the kind checking - of method types. So failing isn't wrong. Yet, the reason we do it is - to avoid the validity checker from seeing unsolved coercion holes in - types. Much better just to report the kind error directly. -} - do { inst_ty <- failIfEmitsConstraints $ - tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) hs_inst_ty constraintKind - ; inst_ty <- zonkTcTypeToType inst_ty - ; checkValidInstance user_ctxt hs_inst_ty 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) + ; checkValidInstance user_ctxt hs_inst_ty inst_ty + ; return inst_ty } ---------------------------------------------- -- | Type-check a visible type application @@ -335,7 +359,7 @@ tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type -- See Note [Recipe for checking a signature] in TcHsType tcHsTypeApp wc_ty kind | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { ty <- solveLocalEqualities $ + = do { ty <- solveLocalEqualities "tcHsTypeApp" $ -- We are looking at a user-written type, very like a -- signature so we want to solve its equalities right now tcWildCardBinders sig_wcs $ \ _ -> @@ -640,11 +664,18 @@ tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind - = do { (tvs', ty') <- tcExplicitTKBndrs (ForAllSkol (ppr forall)) hs_tvs $ - tc_lhs_type mode ty exp_kind + = do { (tclvl, wanted, (tvs', ty')) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKBndrs_Skol hs_tvs $ + tc_lhs_type mode ty exp_kind -- Do not kind-generalise here! See Note [Kind generalisation] -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let bndrs = mkTyVarBinders Specified tvs' + ; let bndrs = mkTyVarBinders Specified tvs' + skol_info = ForAllSkol (ppr forall) + m_telescope = Just (sep (map ppr hs_tvs)) + + ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted + ; return (mkForAllTys bndrs ty') } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind @@ -857,56 +888,53 @@ bigConstraintTuple arity -- | Apply a type of a given kind to a list of arguments. This instantiates -- invisible parameters as necessary. Always consumes all the arguments, -- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- -- These kinds should be used to instantiate invisible kind variables; -- they come from an enclosing class for an associated type/data family. tcInferApps :: TcTyMode - -> Maybe (VarEnv Kind) -- ^ Possibly, kind info (see above) -> LHsType GhcRn -- ^ Function (for printing only) -> TcType -- ^ Function -> TcKind -- ^ Function kind (zonked) -> [LHsType GhcRn] -- ^ Args - -> TcM (TcType, [TcType], TcKind) -- ^ (f args, args, result kind) + -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -- Precondition: typeKind fun_ty = fun_ki -- Reason: we will return a type application like (fun_ty arg1 ... argn), -- and that type must be well-kinded -- See Note [The tcType invariant] -- Postcondition: Result kind is zonked. -tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args +tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki) - ; (f_args, args, res_k) <- go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args + ; (f_args, res_k) <- go 1 empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args ; traceTc "tcInferApps }" empty - ; res_k <- zonkTcType res_k -- nec'y to uphold (IT4) of Note [The tcType invariant] - ; return (f_args, args, res_k) } + ; res_k <- zonkTcType res_k -- Uphold (IT4) of Note [The tcType invariant] + ; return (f_args, res_k) } where empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfType fun_ki (orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki go :: Int -- the # of the next argument - -> [TcType] -- already type-checked args, in reverse order -> TCvSubst -- instantiating substitution -> TcType -- function applied to some args -> [TyBinder] -- binders in function kind (both vis. and invis.) -> TcKind -- function kind body (not a Pi-type) -> [LHsType GhcRn] -- un-type-checked args - -> TcM (TcType, [TcType], TcKind) -- same as overall return type + -> TcM (TcType, TcKind) -- same as overall return type -- no user-written args left. We're done! - go _ acc_args subst fun ki_binders inner_ki [] + go _ subst fun ki_binders inner_ki [] = return ( fun - , reverse acc_args , nakedSubstTy subst $ mkPiTys ki_binders inner_ki) -- nakedSubstTy: see Note [The well-kinded type invariant] -- The function's kind has a binder. Is it visible or invisible? - go n acc_args subst fun (ki_binder:ki_binders) inner_ki + go n subst fun (ki_binder:ki_binders) inner_ki all_args@(arg:args) | isInvisibleBinder ki_binder -- It's invisible. Instantiate. = do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst) - ; (subst', arg') <- tcInstTyBinder mb_kind_info subst ki_binder - ; go n (arg' : acc_args) subst' (mkNakedAppTy fun arg') + ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder + ; go n subst' (mkNakedAppTy fun arg') ki_binders inner_ki all_args } | otherwise @@ -920,15 +948,15 @@ tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args tc_lhs_type mode arg exp_kind ; traceTc "tcInferApps (vis 1)" (ppr exp_kind) ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg' - ; go (n+1) (arg' : acc_args) subst' + ; go (n+1) subst' (mkNakedAppTy fun arg') -- See Note [The well-kinded type invariant] ki_binders inner_ki args } -- We've run out of known binders in the functions's kind. - go n acc_args subst fun [] inner_ki all_args + go n subst fun [] inner_ki all_args | not (null new_ki_binders) -- But, after substituting, we have more binders. - = go n acc_args zapped_subst fun new_ki_binders new_inner_ki all_args + = go n zapped_subst fun new_ki_binders new_inner_ki all_args | otherwise -- Even after substituting, still no binders. Use matchExpectedFunKind @@ -936,7 +964,7 @@ tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k] subst' = zapped_subst `extendTCvInScopeSet` new_in_scope - ; go n acc_args subst' + ; go n subst' (fun `mkNakedCastTy` co) -- See Note [The well-kinded type invariant] [mkAnonBinder arg_k] res_k all_args } @@ -959,7 +987,7 @@ tcTyApps :: TcTyMode -> TcM (TcType, TcKind) -- ^ (f args, result kind) result kind is zonked -- Precondition: see precondition for tcInferApps tcTyApps mode orig_hs_ty fun_ty fun_ki args - = do { (ty', _args, ki') <- tcInferApps mode Nothing orig_hs_ty fun_ty fun_ki args + = do { (ty', ki') <- tcInferApps mode orig_hs_ty fun_ty fun_ki args ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') } -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant] @@ -972,29 +1000,28 @@ checkExpectedKind :: HasDebugCallStack -> TcKind -- the known kind of that type -> TcKind -- the expected kind -> TcM TcType -checkExpectedKind hs_ty ty act exp - = fstOf3 <$> checkExpectedKindX Nothing (ppr hs_ty) ty act exp +checkExpectedKind hs_ty ty act exp = checkExpectedKindX (ppr hs_ty) ty act exp checkExpectedKindX :: HasDebugCallStack - => Maybe (VarEnv Kind) -- Possibly, instantiations for kind vars - -> SDoc -- HsType whose kind we're checking + => SDoc -- HsType whose kind we're checking -> TcType -- the type whose kind we're checking -> TcKind -- the known kind of that type, k -> TcKind -- the expected kind, exp_kind - -> TcM (TcType, [TcType], TcCoercionN) + -> TcM TcType -- (the new args, the coercion) -- Instantiate a kind (if necessary) and then call unifyType -- (checkExpectedKind ty act_kind exp_kind) -- checks that the actual kind act_kind is compatible -- with the expected kind exp_kind -checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind +checkExpectedKindX pp_hs_ty ty act_kind exp_kind = do { -- We need to make sure that both kinds have the same number of implicit -- foralls out front. If the actual kind has more, instantiate accordingly. -- Otherwise, just pass the type & kind through: the errors are caught -- in unifyType. - let (exp_bndrs, _) = splitPiTysInvisible exp_kind - n_exp = length exp_bndrs - ; (new_args, act_kind') <- instantiateTyUntilN mb_kind_env n_exp act_kind + let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind + n_act_invis_bndrs = invisibleTyBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind) ; let origin = TypeEqOrigin { uo_actual = act_kind' , uo_expected = exp_kind @@ -1009,54 +1036,14 @@ checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind , text "exp_kind:" <+> ppr exp_kind ] ; if act_kind' `tcEqType` exp_kind - then return (ty', new_args, mkTcNomReflCo exp_kind) -- This is very common + then return ty' -- This is very common else do { co_k <- uType KindLevel origin act_kind' exp_kind ; traceTc "checkExpectedKind" (vcat [ ppr act_kind , ppr exp_kind , ppr co_k ]) ; let result_ty = ty' `mkNakedCastTy` co_k -- See Note [The tcType invariant] - ; return (result_ty, new_args, co_k) } } - --- | Instantiate @n@ invisible arguments to a type. If @n <= 0@, no instantiation --- occurs. If @n@ is too big, then all available invisible arguments are instantiated. --- (In other words, this function is very forgiving about bad values of @n@.) --- Why zonk the result? So that tcTyVar can obey (IT6) of Note [The tcType invariant] -instantiateTyN :: Maybe (VarEnv Kind) -- ^ Predetermined instantiations - -- (for assoc. type patterns) - -> Int -- ^ @n@ - -> [TyBinder] -> TcKind -- ^ its kind (zonked) - -> TcM ([TcType], TcKind) -- ^ The inst'ed type, new args, kind (zonked) -instantiateTyN mb_kind_env n bndrs inner_ki - | n <= 0 - = return ([], ki) - - | otherwise - = do { (subst, inst_args) <- tcInstTyBinders empty_subst mb_kind_env inst_bndrs - ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki - ; ki' <- zonkTcType (substTy subst rebuilt_ki) - ; traceTc "instantiateTyN" (vcat [ ppr ki - , ppr n - , ppr subst - , ppr rebuilt_ki - , ppr ki' ]) - ; return (inst_args, ki') } - where - -- NB: splitAt is forgiving with invalid numbers - (inst_bndrs, leftover_bndrs) = splitAt n bndrs - ki = mkPiTys bndrs inner_ki - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki)) - --- | Instantiate a type to have at most @n@ invisible arguments. -instantiateTyUntilN :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars - -> Int -- ^ @n@ - -> TcKind -- ^ its kind - -> TcM ([TcType], TcKind) -- ^ The new args, final kind -instantiateTyUntilN mb_kind_env n ki - = let (bndrs, inner_ki) = splitPiTysInvisible ki - num_to_inst = length bndrs - n - in - instantiateTyN mb_kind_env num_to_inst bndrs inner_ki + ; return result_ty } } --------------------------- tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] @@ -1144,11 +1131,13 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant] | otherwise - = do { tc_kind <- zonkTcType (tyConKind tc) - ; let (tc_kind_bndrs, tc_inner_ki) = splitPiTysInvisible tc_kind - ; (tc_args, kind) <- instantiateTyN Nothing (length (tyConBinders tc)) - tc_kind_bndrs tc_inner_ki - ; let is_saturated = tc_args `lengthAtLeast` tyConArity tc + = do { let tc_arity = tyConArity tc + ; tc_kind <- zonkTcType (tyConKind tc) + ; (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN tc_arity tc_kind) + -- Instantiate enough invisible arguments + -- to saturate the family TyCon + + ; let is_saturated = tc_args `lengthAtLeast` tc_arity tc_ty | is_saturated = mkTyConApp tc tc_args `mkNakedCastTy` mkNomReflCo kind -- mkNakedCastTy is for (IT5) of Note [The tcType invariant] @@ -1371,51 +1360,6 @@ Sidenote: It's quite possible that later, we'll consider (t -> s) as a degenerate case of some (pi (x :: t) -> s) and then this will all get more permissive. -Note [Kind generalisation and TyVarTvs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T (a :: k1) x = MkT (S a ()) - data S (b :: k2) y = MkS (T b ()) - -While we are doing kind inference for the mutually-recursive S,T, -we will end up unifying k1 and k2 together. So they can't be skolems. -We therefore make them TyVarTvs, which can unify with type variables, -but not with general types. All this is very similar at the level -of terms: see Note [Quantified variables in partial type signatures] -in TcBinds. - -There are some wrinkles - -* We always want to kind-generalise over TyVarTvs, and /not/ default - them to Type. Another way to say this is: a TyVarTv should /never/ - stand for a type, even via defaulting. Hence the check in - TcSimplify.defaultTyVarTcS, and TcMType.defaultTyVar. Here's - another example (Trac #14555): - data Exp :: [TYPE rep] -> TYPE rep -> Type where - Lam :: Exp (a:xs) b -> Exp xs (a -> b) - We want to kind-generalise over the 'rep' variable. - Trac #14563 is another example. - -* Consider Trac #11203 - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - Here we will unify k1 with k2, but this time doing so is an error, - because k1 and k2 are bound in the same declaration. - - We sort this out using findDupTyVarTvs, in TcHsType.tcTyClTyVars; very much - as we do with partial type signatures in mk_psig_qtvs in - TcBinds.chooseInferredQuantifiers - -* Even the Required arguments should be made into TyVarTvs, not skolems. - Consider - - data T k (a :: k) - - Here, k is a Required, dependent variable. For uniformity, it is helpful - to have k be a TyVarTv, in parallel with other dependent variables. - (This is key in the call to quantifyTyVars in kcTyClGroup, where quantifyTyVars - expects not to see unknown skolems.) - Note [Keeping scoped variables in order: Explicit] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the user writes `forall a b c. blah`, we bring a, b, and c into @@ -1508,7 +1452,6 @@ To avoid the double-zonk, we do two things: 2. When we are generalizing: kindGeneralize does not require a zonked type -- it zonks as it gathers free variables. So this way effectively sidesteps step 3. - -} tcWildCardBinders :: [Name] @@ -1520,6 +1463,44 @@ tcWildCardBinders wc_names thing_inside ; tcExtendNameTyVarEnv wc_prs $ thing_inside wc_prs } +newWildTyVar :: Name -> TcM TcTyVar +-- ^ New unification variable for a wildcard +newWildTyVar _name + = do { kind <- newMetaKindVar + ; uniq <- newUnique + ; details <- newMetaDetails TauTv + ; let name = mkSysTvName uniq (fsLit "w") + tyvar = (mkTcTyVar name kind details) + ; traceTc "newWildTyVar" (ppr tyvar) + ; return tyvar } + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +{- Note [The initial kind of a type constructor] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcLHsQTyVars is responsible for getting the initial kind of +a type constructor. + +It has two cases: + + * The TyCon has a CUSK. In that case, find the full, final, + poly-kinded kind of the TyCon. It's very like a term-level + binding where we have a complete type signature for the + function. + + * It does not have a CUSK. Find a monomorphic kind, with + unification variables in it; they will be generalised later. + It's very like a term-level binding where we do not have + a type signature (or, more accurately, where we have a + partial type signature), so we infer the type and generalise. +-} + + +------------------------------ -- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete, -- user-supplied kind signature (CUSK), generalise the result. -- Used in 'getInitialKind' (for tycon kinds and other kinds) @@ -1534,90 +1515,77 @@ kcLHsQTyVars :: Name -- ^ of the thing being checked -> LHsQTyVars GhcRn -> TcM Kind -- ^ The result kind -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcLHsQTyVars name flav cusk +kcLHsQTyVars name flav cusk tvs thing_inside + | cusk = kcLHsQTyVars_Cusk name flav tvs thing_inside + | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside + + +kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk + :: Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn + -> TcM Kind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon + +------------------------------ +kcLHsQTyVars_Cusk name flav user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns , hsq_dependent = dep_names } , hsq_explicit = hs_tvs }) thing_inside - | cusk - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls + -- CUSK case + -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls = addTyConFlavCtxt name flav $ do { (scoped_kvs, (tc_tvs, res_kind)) - <- solveEqualities $ - tcImplicitQTKBndrs skol_info kv_ns $ - kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside - - ; let class_tc_binders - | Just class_tc <- tyConFlavourAssoc_maybe flav - = tyConBinders class_tc -- class has a CUSK, so these are zonked - -- and fully settled - | otherwise - = [] - - class_tv_set = mkVarSet (binderVars class_tc_binders) - local_specified = filterOut (`elemVarSet` class_tv_set) scoped_kvs - -- NB: local_specified are guaranteed to be in a well-scoped - -- order because of tcImplicitQTKBndrs - - -- NB: candidateQTyVarsOfType is OK with unzonked input - ; candidates <- candidateQTyVarsOfType class_tv_set $ - mkSpecForAllTys local_specified $ - mkSpecForAllTys tc_tvs $ - res_kind - -- The type above is a bit wrong, in that we're using foralls for all - -- the tc_tvs, even those that aren't dependent. This is OK, though, - -- because we're building the type only to extract the variables to - -- quantify. We use mk_tc_binder below to get this right. - - ; local_inferred <- quantifyTyVars class_tv_set candidates - - ; local_specified <- mapM zonkTyCoVarKind local_specified - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs - ; res_kind <- zonkTcType res_kind - - ; let dep_tv_set = tyCoVarsOfTypes (res_kind : map tyVarKind tc_tvs) - local_tcbs = concat [ mkNamedTyConBinders Inferred local_inferred - , mkNamedTyConBinders Specified local_specified - , map (mkRequiredTyConBinder dep_tv_set) tc_tvs ] - - free_class_tv_set = tyCoVarsOfTypes (res_kind : map binderType local_tcbs) - `delVarSetList` map binderVar local_tcbs - - used_class_tcbs = filter ((`elemVarSet` free_class_tv_set) . binderVar) - class_tc_binders - - -- Suppose we have class C k where type F (x :: k). We can't have - -- k *required* in F, so it becomes Specified - to_invis_tcb tcb - | Required <- tyConBinderArgFlag tcb - = mkNamedTyConBinder Specified (binderVar tcb) - | otherwise - = tcb - - used_class_tcbs_invis = map to_invis_tcb used_class_tcbs - - all_tcbs = used_class_tcbs_invis ++ local_tcbs - + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol kv_ns $ + bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ + thing_inside + + -- Now, because we're in a CUSK, + -- we quantify over the mentioned kind vars + ; let spec_req_tkvs = scoped_kvs ++ tc_tvs + all_kinds = res_kind : map tyVarKind spec_req_tkvs + + ; candidates <- candidateQTyVarsOfKinds all_kinds + -- 'candidates' are all the variables that we are going to + -- skolemise and then quantify over. We do not include spec_req_tvs + -- because they are /already/ skolems + + ; let inf_candidates = candidates `delCandidates` spec_req_tkvs + + ; inferred <- quantifyTyVars emptyVarSet inf_candidates + -- NB: 'inferred' comes back sorted in dependency order + + ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs + ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs + ; res_kind <- zonkTcType res_kind + + ; let mentioned_kv_set = candidateKindVars candidates + specified = scopedSort scoped_kvs + -- NB: maintain the L-R order of scoped_kvs + + final_tc_binders = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + tycon = mkTcTyCon name (ppr user_tyvars) + final_tc_binders + res_kind + all_tv_prs + True {- it is generalised -} flav -- If the ordering from -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls -- doesn't work, we catch it here, before an error cascade - ; checkValidTelescope all_tcbs (ppr user_tyvars) + ; checkValidTelescope tycon - -- If any of the all_kvs aren't actually mentioned in a binder's + -- If any of the specified tyvars aren't actually mentioned in a binder's -- kind (or the return kind), then we're in the CUSK case from -- Note [Free-floating kind vars] - ; let all_kvs = concat [ map binderVar used_class_tcbs_invis - , local_inferred - , local_specified ] - - all_mentioned_tvs = dep_tv_set `unionVarSet` - tyCoVarsOfTypes (map tyVarKind all_kvs) + ; let unmentioned_kvs = filterOut (`elemVarSet` mentioned_kv_set) specified + ; reportFloatingKvs name flav (map binderVar final_tc_binders) unmentioned_kvs - unmentioned_kvs = filterOut (`elemVarSet` all_mentioned_tvs) all_kvs - ; reportFloatingKvs name flav (map binderVar all_tcbs) unmentioned_kvs - - ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name (ppr user_tyvars) all_tcbs res_kind - all_tv_prs True {- it is generalised -} flav ; traceTc "kcLHsQTyVars: cusk" $ vcat [ text "name" <+> ppr name @@ -1627,23 +1595,41 @@ kcLHsQTyVars name flav cusk , text "scoped_kvs" <+> ppr scoped_kvs , text "tc_tvs" <+> ppr tc_tvs , text "res_kind" <+> ppr res_kind - , text "all_tcbs" <+> ppr all_tcbs - , text "mkTyConKind all_tcbs res_kind" - <+> ppr (mkTyConKind all_tcbs res_kind) + , text "candidates" <+> ppr candidates + , text "inferred" <+> ppr inferred + , text "specified" <+> ppr specified + , text "final_tc_binders" <+> ppr final_tc_binders + , text "mkTyConKind final_tc_bndrs res_kind" + <+> ppr (mkTyConKind final_tc_binders res_kind) , text "all_tv_prs" <+> ppr all_tv_prs ] ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind - | otherwise +kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" + +------------------------------ +kcLHsQTyVars_NonCusk name flav + user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns + , hsq_dependent = dep_names } + , hsq_explicit = hs_tvs }) thing_inside + -- Non_CUSK case + -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls = do { (scoped_kvs, (tc_tvs, res_kind)) - -- Why kcImplicitTKBndrs which uses newTyVarTyVar? - -- See Note [Kind generalisation and TyVarTvs] - <- kcImplicitTKBndrs kv_ns $ - kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside + -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? + -- See Note [Inferring kinds for type declarations] in TcTyClsDecls + <- bindImplicitTKBndrs_Q_Tv kv_ns $ + bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ + thing_inside + -- Why "_Tv" not "_Skol"? See third wrinkle in + -- Note [Inferring kinds for type declarations] in TcTyClsDecls, ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they -- might unify with kind vars in other types in a mutually - -- recursive group. See Note [Kind generalisation and TyVarTvs] + -- recursive group. + -- See Note [Inferring kinds for type declarations] in TcTyClsDecls tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs -- Also, note that tc_binders has the tyvars from only the -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] @@ -1655,11 +1641,12 @@ kcLHsQTyVars name flav cusk ; traceTc "kcLHsQTyVars: not-cusk" $ vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names + , ppr scoped_kvs , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] ; return tycon } where - open_fam = tcFlavourIsOpen flav - skol_info = TyConSkol flav name + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind mk_tc_binder :: LHsTyVarBndr GhcRn -> TyVar -> TyConBinder -- See Note [Dependent LHsQTyVars] @@ -1669,79 +1656,8 @@ kcLHsQTyVars name flav cusk | otherwise = mkAnonTyConBinder tv -kcLHsQTyVars _ _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" - -kcLHsQTyVarBndrs :: Bool -- True <=> bump the TcLevel when bringing vars into scope - -> Bool -- True <=> Default un-annotated tyvar - -- binders to kind * - -> SkolemInfo - -> [LHsTyVarBndr GhcRn] - -> TcM r - -> TcM ([TyVar], r) --- There may be dependency between the explicit "ty" vars. --- So, we have to handle them one at a time. -kcLHsQTyVarBndrs _ _ _ [] thing - = do { stuff <- thing; return ([], stuff) } - -kcLHsQTyVarBndrs cusk open_fam skol_info (L _ hs_tv : hs_tvs) thing - = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv - -- NB: Bring all tvs into scope, even non-dependent ones, - -- as they're needed in type synonyms, data constructors, etc. - - ; (tvs, stuff) <- bind_unless_scoped tv_pair $ - kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs $ - thing - - ; return ( tv : tvs, stuff ) } - where - -- | Bind the tyvar in the env't unless the bool is True - bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a - bind_unless_scoped (_, True) thing_inside = thing_inside - bind_unless_scoped (tv, False) thing_inside - | cusk = scopeTyVars skol_info [tv] thing_inside - | otherwise = tcExtendTyVarEnv [tv] thing_inside - -- These variables haven't settled down yet, so we don't want to bump - -- the TcLevel. If we do, then we'll have metavars of too high a level - -- floating about. Changing this causes many, many failures in the - -- `dependent` testsuite directory. - - kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool) - -- Special handling for the case where the binder is already in scope - -- See Note [Associated type tyvar names] in Class and - -- Note [TyVar binders for associated decls] in HsDecls - kc_hs_tv (UserTyVar _ (L _ name)) - = do { mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of -- See Note [TyVar binders for associated decls] - Just (ATyVar _ tv) -> return (tv, True) - _ -> do { kind <- if open_fam - then return liftedTypeKind - else newMetaKindVar - -- Open type/data families default their variables - -- variables to kind *. But don't default in-scope - -- class tyvars, of course - ; tv <- new_tv name kind - ; return (tv, False) } } - - kc_hs_tv (KindedTyVar _ lname@(L _ name) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt name) lhs_kind - ; mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) - -> do { discardResult $ - unifyKind (Just (HsTyVar noExt NotPromoted lname)) - kind (tyVarKind tv) - ; return (tv, True) } - _ -> do { tv <- new_tv name kind - ; return (tv, False) } } - - kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv" - - - new_tv :: Name -> Kind -> TcM TcTyVar - new_tv - | cusk = newSkolemTyVar - | otherwise = newTyVarTyVar - -- Third wrinkle in Note [Kind generalisation and TyVarTvs] +kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" + {- Note [Kind-checking tyvar binders for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1759,7 +1675,7 @@ See Note [Associated type tyvar names] in Class and We must do the same for family instance decls, where the in-scope variables may be bound by the enclosing class instance decl. -Hence the use of tcImplicitQTKBndrs in tcFamTyPats. +Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. Note [Kind variable ordering for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1797,41 +1713,64 @@ these first. -} +{- ********************************************************************* +* * + Expected kinds +* * +********************************************************************* -} + +-- | Describes the kind expected in a certain context. +data ContextKind = TheKind Kind -- ^ a specific kind + | AnyKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + +----------------------- +newExpectedKind :: ContextKind -> TcM Kind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind + +----------------------- +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt (TySynCtxt _) = AnyKind +expectedKindInCtxt ThBrackCtxt = AnyKind +expectedKindInCtxt GhciCtxt = AnyKind +-- The types in a 'default' decl can have varying kinds +-- See Note [Extended defaults]" in TcEnv +expectedKindInCtxt DefaultDeclCtxt = AnyKind +expectedKindInCtxt TypeAppCtxt = AnyKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind + + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + -------------------------------------- -- Implicit binders -------------------------------------- --- | Bring implicitly quantified type/kind variables into scope during --- kind checking. Uses TyVarTvs, as per Note [Use TyVarTvs in kind-checking pass] --- in TcTyClsDecls. -kcImplicitTKBndrs :: [Name] -- of the vars - -> TcM a - -> TcM ([TcTyVar], a) -- returns the tyvars created - -- these are *not* dependency ordered -kcImplicitTKBndrs var_ns thing_inside - -- NB: Just use tyvars that are in scope, if any. Otherwise, we - -- get #15711, where GHC forgets that a variable used in an associated - -- type is the same as the one used in the enclosing class - = do { tkvs_pairs <- mapM (newFlexiKindedQTyVar newTyVarTyVar) var_ns - ; let tkvs_to_scope = [ tkv | (tkv, True) <- tkvs_pairs ] - ; result <- tcExtendTyVarEnv tkvs_to_scope thing_inside - ; return (map fst tkvs_pairs, result) } - -tcImplicitTKBndrs, tcImplicitTKBndrsSig, tcImplicitQTKBndrs - :: SkolemInfo - -> [Name] +bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, + bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv + :: [Name] -> TcM a -> TcM ([TcTyVar], a) -tcImplicitTKBndrs = tcImplicitTKBndrsX newFlexiKindedSkolemTyVar -tcImplicitTKBndrsSig = tcImplicitTKBndrsX newFlexiKindedTyVarTyVar -tcImplicitQTKBndrs = tcImplicitTKBndrsX - (\nm -> fst <$> newFlexiKindedQTyVar newSkolemTyVar nm) - -tcImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function - -> SkolemInfo - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) -- these tyvars are dependency-ordered +bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar +bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) + +bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function + -> [Name] + -> TcM a + -> TcM ([TcTyVar], a) -- these tyvars are dependency-ordered -- * Guarantees to call solveLocalEqualities to unify -- all constraints from thing_inside. -- @@ -1841,39 +1780,19 @@ tcImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function -- -- * Returned TcTyVars have zonked kinds -- See Note [Keeping scoped variables in order: Implicit] -tcImplicitTKBndrsX new_tv skol_info tv_names thing_inside - | null tv_names -- Short cut for the common case where there - -- are no implicit type variables to bind - = do { result <- solveLocalEqualities thing_inside - ; return ([], result) } - - | otherwise - = do { (skol_tvs, result) - <- solveLocalEqualities $ - checkTvConstraints skol_info Nothing $ - do { tkvs <- mapM new_tv tv_names - ; result <- tcExtendTyVarEnv tkvs thing_inside - ; return (tkvs, result) } - - ; skol_tvs <- mapM zonkTcTyCoVarBndr skol_tvs - -- use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv - - -- do a stable topological sort, following - -- Note [Ordering of implicit variables] in RnTypes - ; let final_tvs = scopedSort skol_tvs - ; traceTc "tcImplicitTKBndrs" (ppr tv_names $$ ppr final_tvs) - ; return (final_tvs, result) } - -newFlexiKindedQTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM (TcTyVar, Bool) --- Make a new tyvar for an implicit binder in a type/class/type --- instance declaration, with a flexi-kind --- But check for in-scope-ness, and if so return that instead --- Returns True as second return value iff this created a real new tyvar -newFlexiKindedQTyVar mk_tv name +bindImplicitTKBndrsX new_tv tv_names thing_inside + = do { tkvs <- mapM new_tv tv_names + ; result <- tcExtendTyVarEnv tkvs thing_inside + ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) + ; return (tkvs, result) } + +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, False) - _ -> (, True) <$> newFlexiKindedTyVar mk_tv name } + Just (ATyVar _ tv) -> return tv + _ -> new_tv name } newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar newFlexiKindedTyVar new_tv name @@ -1890,126 +1809,132 @@ newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar -- Explicit binders -------------------------------------- --- | Used during the "kind-checking" pass in TcTyClsDecls only, --- and even then only for data-con declarations. --- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls -kcExplicitTKBndrs :: [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM a -kcExplicitTKBndrs [] thing_inside = thing_inside -kcExplicitTKBndrs (L _ hs_tv : hs_tvs) thing_inside - = do { tv <- tcHsTyVarBndr newTyVarTyVar hs_tv - ; tcExtendTyVarEnv [tv] $ - kcExplicitTKBndrs hs_tvs thing_inside } - -tcExplicitTKBndrs :: SkolemInfo - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) -tcExplicitTKBndrs skol_info hs_tvs thing_inside --- Used for the forall'd binders in type signatures of various kinds: --- - function signatures --- - data con signatures in GADT-style decls --- - pattern synonym signatures --- - expression type signatures --- --- Specifically NOT used for the binders of a data type --- or type family decl. So the forall'd variables always /shadow/ --- anything already in scope, and the complications of --- tcHsQTyVarName to not apply. --- --- This function brings into scope a telescope of binders as written by --- the user. At first blush, it would then seem that we should bring --- them into scope one at a time, bumping the TcLevel each time. --- (Recall that we bump the level to prevent skolem escape from happening.) --- However, this leads to terrible error messages, because we end up --- failing to unify with some `k0`. Better would be to allow type inference --- to work, potentially creating a skolem-escape problem, and then to --- notice that the telescope is out of order. That's what we do here, --- following the logic of tcImplicitTKBndrsX. --- See also Note [Keeping scoped variables in order: Explicit] --- --- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs - | null hs_tvs -- Short cut that avoids creating an implication - -- constraint in the common case where none is needed - = do { result <- thing_inside - ; return ([], result) } +bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv + :: [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) - | otherwise - = do { (skol_tvs, result) <- checkTvConstraints skol_info (Just doc) $ - bind_tvbs hs_tvs +bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar) - ; traceTc "tcExplicitTKBndrs" $ - vcat [ text "Hs vars:" <+> ppr hs_tvs - , text "tvs:" <+> pprTyVars skol_tvs ] +bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv + :: ContextKind + -> [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) - ; return (skol_tvs, result) } +bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) +bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) +-- | Used during the "kind-checking" pass in TcTyClsDecls only, +-- and even then only for data-con declarations. +bindExplicitTKBndrsX + :: (HsTyVarBndr GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) +bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) + ; go hs_tvs } where - bind_tvbs [] = do { result <- thing_inside - ; return ([], result) } - bind_tvbs (L _ tvb : tvbs) - = do { tv <- tcHsTyVarBndr newSkolemTyVar tvb - ; tcExtendTyVarEnv [tv] $ - do { (tvs, result) <- bind_tvbs tvbs - ; return (tv : tvs, result) }} - - doc = sep (map ppr hs_tvs) + go [] = do { res <- thing_inside + ; return ([], res) } + go (L _ hs_tv : hs_tvs) + = do { tv <- tc_tv hs_tv + ; (tvs, res) <- tcExtendTyVarEnv [tv] (go hs_tvs) + ; return (tv:tvs, res) } ----------------- tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) -> HsTyVarBndr GhcRn -> TcM TcTyVar --- Return a TcTyVar, built using the provided function --- Typically the Kind inside the HsTyVarBndr will be a tyvar --- with a mutable kind in it. --- -- Returned TcTyVar has the same name; no cloning tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) - = newFlexiKindedTyVar new_tv tv_nm + = do { kind <- newMetaKindVar + ; new_tv tv_nm kind } tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; new_tv tv_nm kind } tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr" ----------------- -newWildTyVar :: Name -> TcM TcTyVar --- ^ New unification variable for a wildcard -newWildTyVar _name - = do { kind <- newMetaKindVar - ; uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "w") - tyvar = (mkTcTyVar name kind details) - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } +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 } } --------------------------- --- Bringing tyvars into scope --------------------------- +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 hs_tv) + kind (tyVarKind tv) + -- This unify rejects: + -- class C (m :: * -> *) where + -- type F (m :: *) = ... + ; return tv } + + _ -> new_tv tv_nm kind } + where + hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm) + -- Used for error messages only --- | Bring tyvars into scope, wrapping the thing_inside in an implication --- constraint. The implication constraint is necessary to provide SkolemInfo --- for the tyvars and to ensure that no unification variables made outside --- the scope of these tyvars (i.e. lower TcLevel) unify with the locally-scoped --- tyvars (i.e. higher TcLevel). --- --- INVARIANT: The thing_inside must check only types, never terms. --- --- Use this (not tcExtendTyVarEnv) wherever you expect a Λ or ∀ in Core. --- Use tcExtendTyVarEnv otherwise. -scopeTyVars :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a -scopeTyVars skol_info tvs = scopeTyVars2 skol_info [(tyVarName tv, tv) | tv <- tvs] - --- | Like 'scopeTyVars', but allows you to specify different scoped names --- than the Names stored within the tyvars. -scopeTyVars2 :: SkolemInfo -> [(Name, TcTyVar)] -> TcM a -> TcM a -scopeTyVars2 skol_info prs thing_inside - = fmap snd $ -- discard the TcEvBinds, which will always be empty - checkConstraints skol_info (map snd prs) [{- no EvVars -}] $ - tcExtendNameTyVarEnv prs $ - thing_inside +tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr" + + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name + -> ([TyConBinder] -> Kind -> TcM a) -> TcM a +-- ^ Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- kcLookupTcTyCon tycon_name + ; let scoped_prs = tcTyConScopedTyVars tycon + res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders) + ; tcExtendNameTyVarEnv scoped_prs $ + thing_inside binders res_kind } + +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Look it up in the local environment. This is used only for tycons +-- that we're currently type-checking, so we're sure to find a TcTyCon. +kcLookupTcTyCon :: Name -> TcM TcTyCon +kcLookupTcTyCon nm + = do { tc_ty_thing <- tcLookup nm + ; return $ case tc_ty_thing of + ATcTyCon tc -> tc + _ -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- mapM zonkTcTyCoVarBndr spec_tkvs + -- Use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in RnTypes + ; return (scopedSort spec_tkvs) } ------------------- kindGeneralize :: TcType -> TcM [KindVar] -- Quantify the free kind variables of a kind or type -- In the latter case the type is closed, so it has no free @@ -2017,7 +1942,18 @@ kindGeneralize :: TcType -> TcM [KindVar] -- Input needn't be zonked. -- NB: You must call solveEqualities or solveLocalEqualities before -- kind generalization -kindGeneralize = kindGeneralizeLocal emptyWC +-- +-- NB: this function is just a specialised version of +-- kindGeneralizeLocal emptyWC kind_or_type +-- +kindGeneralize kind_or_type + = do { kt <- zonkTcType kind_or_type + ; traceTc "kindGeneralise1" (ppr kt) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked + ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type + , ppr dvs ]) + ; quantifyTyVars gbl_tvs dvs } -- | This variant of 'kindGeneralize' refuses to generalize over any -- variables free in the given WantedConstraints. Instead, it promotes @@ -2039,17 +1975,38 @@ kindGeneralizeLocal wanted kind_or_type -- use the "Kind" variant here, as any types we see -- here will already have all type variables quantified; -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind mono_tvs kind_or_type + ; dvs <- candidateQTyVarsOfKind kind_or_type - ; traceTc "kindGeneralizeLocal" (vcat [ ppr wanted - , ppr kind_or_type - , ppr constrained - , ppr mono_tvs - , ppr dvs ]) + ; traceTc "kindGeneralizeLocal" $ + vcat [ text "Wanted:" <+> ppr wanted + , text "Kind or type:" <+> ppr kind_or_type + , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted)) + , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained) + , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs) + , text "dvs:" <+> ppr dvs ] ; quantifyTyVars mono_tvs dvs } -{- +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residiual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + Note [Kind generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We do kind generalisation only at the outer level of a type signature. @@ -2090,186 +2047,12 @@ look through unification variables! Hence using zonked_kinds when forming tvs'. -Note [Free-floating kind vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T = MkT (forall (a :: k). Proxy a) - -- from test ghci/scripts/T7873 - -This is not an existential datatype, but a higher-rank one (the forall -to the right of MkT). Also consider - - data S a = MkS (Proxy (a :: k)) - -According to the rules around implicitly-bound kind variables, in both -cases those k's scope over the whole declaration. The renamer grabs -it and adds it to the hsq_implicits field of the HsQTyVars of the -tycon. So it must be in scope during type-checking, but we want to -reject T while accepting S. - -Why reject T? Because the kind variable isn't fixed by anything. For -a variable like k to be implicit, it needs to be mentioned in the kind -of a tycon tyvar. But it isn't. - -Why accept S? Because kind inference tells us that a has kind k, so it's -all OK. - -Our approach depends on whether or not the datatype has a CUSK. - -Non-CUSK: In the first pass (kcTyClTyVars) we just bring -k into scope. In the second pass (tcTyClTyVars), -we check to make sure that k has been unified with some other variable -(or generalized over, making k into a skolem). If it hasn't been, then -it must be a free-floating kind var. Error. - -CUSK: When we determine the tycon's final, never-to-be-changed kind -in kcLHsQTyVars, we check to make sure all implicitly-bound kind -vars are indeed mentioned in a kind somewhere. If not, error. - -We also perform free-floating kind var analysis for type family instances -(see #13985). Here is an interesting example: - - type family T :: k - type instance T = (Nothing :: Maybe a) - -Upon a cursory glance, it may appear that the kind variable `a` is -free-floating above, since there are no (visible) LHS patterns in `T`. However, -there is an *invisible* pattern due to the return kind, so inside of GHC, the -instance looks closer to this: - - type family T @k :: k - type instance T @(Maybe a) = (Nothing :: Maybe a) - -Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in -fact not free-floating. Contrast that with this example: - - type instance T = Proxy (Nothing :: Maybe a) - -This would looks like this inside of GHC: - - type instance T @(*) = Proxy (Nothing :: Maybe a) - -So this time, `a` is neither bound by a visible nor invisible type pattern on -the LHS, so it would be reported as free-floating. - -Finally, here's one more brain-teaser (from #9574). In the example below: - - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> *) - -As it turns out, `o` is not free-floating in this example. That is because `o` -bound by the kind signature of the LHS type pattern 'KProxy. To make this more -obvious, one can also write the instance like so: - - instance Funct ('KProxy :: KProxy o) where - type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) - -} --------------------- --- getInitialKind has made a suitably-shaped kind for the type or class --- Look it up in the local environment. This is used only for tycons --- that we're currently type-checking, so we're sure to find a TcTyCon. -kcLookupTcTyCon :: Name -> TcM TcTyCon -kcLookupTcTyCon nm - = do { tc_ty_thing <- tcLookup nm - ; return $ case tc_ty_thing of - ATcTyCon tc -> tc - _ -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) } - ------------------------ --- | Bring tycon tyvars into scope. This is used during the "kind-checking" --- pass in TcTyClsDecls. (Never in getInitialKind, never in the --- "type-checking"/desugaring pass.) --- Never emits constraints, though the thing_inside might. -kcTyClTyVars :: Name -> TcM a -> TcM a -kcTyClTyVars tycon_name thing_inside - -- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls - = do { tycon <- kcLookupTcTyCon tycon_name - ; tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside } - -tcTyClTyVars :: Name - -> ([TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- on the second full pass (type-checking/desugaring) in TcTyClDecls. --- This is *not* used in the initial-kind run, nor in the "kind-checking" pass. --- Accordingly, everything passed to the continuation is fully zonked. --- --- (tcTyClTyVars T [a,b] thing_inside) --- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * --- calls thing_inside with arguments --- [k1,k2,a,b] [k1:*, k2:*, Anon (k1 -> *), Anon k1] (k2 -> *) --- having also extended the type environment with bindings --- for k1,k2,a,b --- --- Never emits constraints. --- --- The LHsTyVarBndrs is always user-written, and the full, generalised --- kind of the tycon is available in the local env. -tcTyClTyVars tycon_name thing_inside - = do { tycon <- kcLookupTcTyCon tycon_name - - -- Do checks on scoped tyvars - -- See Note [Free-floating kind vars] - ; let flav = tyConFlavour tycon - scoped_prs = tcTyConScopedTyVars tycon - scoped_tvs = map snd scoped_prs - still_sig_tvs = filter isTyVarTyVar scoped_tvs - - ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_prs) - - ; checkNoErrs $ reportFloatingKvs tycon_name flav - scoped_tvs still_sig_tvs - - ; let res_kind = tyConResKind tycon - binders = correct_binders (tyConBinders tycon) res_kind - ; traceTc "tcTyClTyVars" (ppr tycon_name <+> ppr binders) - ; scopeTyVars2 (TyConSkol flav tycon_name) scoped_prs $ - thing_inside binders res_kind } - where - report_sig_tv_err (n1, n2) - = setSrcSpan (getSrcSpan n2) $ - addErrTc (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - - -- Given some TyConBinders and a TyCon's result kind, make sure that the - -- correct any wrong Named/Anon choices. For example, consider - -- type Syn k = forall (a :: k). Proxy a - -- At first, it looks like k should be named -- after all, it appears on the RHS. - -- However, the correct kind for Syn is (* -> *). - -- (Why? Because k is the kind of a type, so k's kind is *. And the RHS also has - -- kind *.) See also #13963. - correct_binders :: [TyConBinder] -> Kind -> [TyConBinder] - correct_binders binders kind - = binders' - where - (_, binders') = mapAccumR go (tyCoVarsOfType kind) binders - - go :: TyCoVarSet -> TyConBinder -> (TyCoVarSet, TyConBinder) - go fvs binder - | isNamedTyConBinder binder - , not (tv `elemVarSet` fvs) - = (new_fvs, mkAnonTyConBinder tv) - - | not (isNamedTyConBinder binder) - , tv `elemVarSet` fvs - = (new_fvs, mkNamedTyConBinder Required tv) - -- always Required, because it was anonymous (i.e. visible) previously - - | otherwise - = (new_fvs, binder) - - where - tv = binderVar binder - new_fvs = fvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv) - ----------------------------------- -tcDataKindSig :: [TyConBinder] - -> Kind - -> TcM ([TyConBinder], Kind) +etaExpandAlgTyCon :: [TyConBinder] + -> Kind + -> TcM ([TyConBinder], Kind) -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T a :: * -> * -> * where ... -- This function makes up suitable (kinded) TyConBinders for the @@ -2278,7 +2061,7 @@ tcDataKindSig :: [TyConBinder] -- Never emits constraints. -- It's a little trickier than you might think: see -- Note [TyConBinders for the result kind signature of a data type] -tcDataKindSig tc_bndrs kind +etaExpandAlgTyCon tc_bndrs kind = do { loc <- getSrcSpanM ; uniqs <- newUniqueSupply ; rdr_env <- getLocalRdrEnv @@ -2322,13 +2105,37 @@ badKindSig check_for_type kind text "return kind" ]) 2 (ppr kind) +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correpondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + go fun_kind subst all_args@(arg : args) + | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind + = case tcb of + Anon _ -> AnonTCB : go inner_kind subst args + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + {- Note [TyConBinders for the result kind signature of a data type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given data T (a::*) :: * -> forall k. k -> * we want to generate the extra TyConBinders for T, so we finally get (a::*) (b::*) (k::*) (c::k) -The function tcDataKindSig generates these extra TyConBinders from +The function etaExpandAlgTyCon generates these extra TyConBinders from the result kind signature. We need to take care to give the TyConBinders @@ -2393,8 +2200,8 @@ tcHsPartialSigType ctxt sig_ty = addSigCtxt ctxt hs_ty $ do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) <- tcWildCardBinders sig_wcs $ \ wcs -> - tcImplicitTKBndrsSig skol_info implicit_hs_tvs $ - tcExplicitTKBndrs skol_info explicit_hs_tvs $ + bindImplicitTKBndrs_Tv implicit_hs_tvs $ + bindExplicitTKBndrs_Tv explicit_hs_tvs $ do { -- Instantiate the type-class context; but if there -- is an extra-constraints wildcard, just discard it here (theta, wcx) <- tcPartialContext hs_ctxt @@ -2424,18 +2231,18 @@ tcHsPartialSigType ctxt sig_ty -- everything (and solved equalities in the tcImplicit call) -- we need to promote the TyVarTvs so we don't violate the TcLevel -- invariant - ; all_tvs <- mapM zonkPromoteTyCoVarBndr (implicit_tvs ++ explicit_tvs) - -- zonkPromoteTyCoVarBndr deals well with TyVarTvs + ; implicit_tvs <- zonkAndScopedSort implicit_tvs + ; explicit_tvs <- mapM zonkTcTyCoVarBndr explicit_tvs + ; theta <- mapM zonkTcType theta + ; tau <- zonkTcType tau - ; theta <- mapM zonkPromoteType theta - ; tau <- zonkPromoteType tau + ; let all_tvs = implicit_tvs ++ explicit_tvs ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau) ; traceTc "tcHsPartialSigType" (ppr all_tvs) ; return (wcs, wcx, tv_names, all_tvs, theta, tau) } - where - skol_info = SigTypeSkol ctxt + tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType" tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType" @@ -2735,18 +2542,6 @@ zonkPromoteTcTyVar tv zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType -zonkPromoteTyCoVarBndr :: TyCoVar -> TcM TyCoVar -zonkPromoteTyCoVarBndr tv - | isTyVarTyVar tv - = tcGetTyVar "zonkPromoteTyCoVarBndr TyVarTv" <$> zonkPromoteTcTyVar tv - - | isTcTyVar tv && isSkolemTyVar tv - = do { tc_lvl <- getTcLevel - ; zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) } - - | otherwise - = zonkPromoteTyCoVarKind tv - zonkPromoteCoercion :: Coercion -> TcM Coercion zonkPromoteCoercion = mapCoercion zonkPromoteMapper () @@ -2765,7 +2560,7 @@ tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind tcLHsKindSig ctxt hs_kind -- See Note [Recipe for checking a signature] in TcHsType -- Result is zonked - = do { kind <- solveLocalEqualities $ + = do { kind <- solveLocalEqualities "tcLHsKindSig" $ tc_lhs_kind kindLevelMode hs_kind ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) -- No generalization, so we must promote @@ -2828,13 +2623,83 @@ badPatTyVarTvs sig_ty bad_tvs ************************************************************************ -} --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) + +{- Note [Free-floating kind vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data S a = MkS (Proxy (a :: k)) + +According to the rules around implicitly-bound kind variables, +that k scopes over the whole declaration. The renamer grabs +it and adds it to the hsq_implicits field of the HsQTyVars of the +tycon. So we get + S :: forall {k}. k -> Type + +That's fine. But consider this variant: + data T = MkT (forall (a :: k). Proxy a) + -- from test ghci/scripts/T7873 + +This is not an existential datatype, but a higher-rank one (the forall +to the right of MkT). Again, 'k' scopes over the whole declaration, +but we do not want to get + T :: forall {k}. Type +Why not? Because the kind variable isn't fixed by anything. For +a variable like k to be implicit, it needs to be mentioned in the kind +of a tycon tyvar. But it isn't. + +Rejecting T depends on whether or not the datatype has a CUSK. + +Non-CUSK (handled in TcTyClsDecls.kcTyClGroup (generalise)): + When generalising the TyCon we check that every Specified 'k' + appears free in the kind of the TyCon; that is, in the kind of + one of its Required arguments, or the result kind. + +CUSK (handled in TcHsType.kcLHsQTyVars, the CUSK case): + When we determine the tycon's final, never-to-be-changed kind + in kcLHsQTyVars, we check to make sure all implicitly-bound kind + vars are indeed mentioned in a kind somewhere. If not, error. + +We also perform free-floating kind var analysis for type family instances +(see #13985). Here is an interesting example: + + type family T :: k + type instance T = (Nothing :: Maybe a) + +Upon a cursory glance, it may appear that the kind variable `a` is +free-floating above, since there are no (visible) LHS patterns in `T`. However, +there is an *invisible* pattern due to the return kind, so inside of GHC, the +instance looks closer to this: + + type family T @k :: k + type instance T @(Maybe a) = (Nothing :: Maybe a) + +Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in +fact not free-floating. Contrast that with this example: + + type instance T = Proxy (Nothing :: Maybe a) + +This would looks like this inside of GHC: + + type instance T @(*) = Proxy (Nothing :: Maybe a) + +So this time, `a` is neither bound by a visible nor invisible type pattern on +the LHS, so it would be reported as free-floating. + +Finally, here's one more brain-teaser (from #9574). In the example below: + + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> *) + +As it turns out, `o` is not free-floating in this example. That is because `o` +bound by the kind signature of the LHS type pattern 'KProxy. To make this more +obvious, one can also write the instance like so: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) +-} -- See Note [Free-floating kind vars] reportFloatingKvs :: Name -- of the tycon @@ -2865,17 +2730,27 @@ reportFloatingKvs tycon_name flav all_tvs bad_tvs ppr_tv_bndrs tvs = sep (map pp_tv tvs) pp_tv tv = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) --- | If the inner action emits constraints, reports them as errors and fails; +-- | If the inner action emits constraints, report them as errors and fail; -- otherwise, propagates the return value. Useful as a wrapper around -- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be -- another chance to solve constraints failIfEmitsConstraints :: TcM a -> TcM a failIfEmitsConstraints thing_inside - = do { (res, lie) <- captureConstraints thing_inside - ; checkNoErrs $ reportAllUnsolved lie + = checkNoErrs $ -- We say that we fail if there are constraints! + -- c.f same checkNoErrs in solveEqualities + do { (res, lie) <- captureConstraints thing_inside + ; reportAllUnsolved lie ; return res } +-- | Make an appropriate message for an error in a function argument. +-- Used for both expressions and types. +funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc +funAppCtxt fun arg arg_no + = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) + 2 (quotes (ppr arg)) + -- | Add a "In the data declaration for T" or some such. addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a addTyConFlavCtxt name flav diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index ba2fd7588e..b8eb17fb57 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -31,6 +31,7 @@ import TcMType import TcType import BuildTyCl import Inst +import ClsInst( AssocInstInfo(..), isNotAssociated ) import InstEnv import FamInst import FamInstEnv @@ -58,7 +59,6 @@ import ErrUtils import FastString import Id import ListSetOps -import MkId import Name import NameSet import Outputable @@ -69,6 +69,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Maybes +import Data.List( mapAccumL ) {- @@ -449,11 +450,11 @@ tcLocalInstDecl :: LInstDecl GhcRn -- -- We check for respectable instance type, and context tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) - = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl) + = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) ; return ([], [fam_inst], []) } tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) - = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl) + = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl) ; return ([], [fam_inst], maybeToList m_deriv_info) } tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) @@ -465,69 +466,85 @@ tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl" tcClsInstDecl :: LClsInstDecl GhcRn -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) -- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds +tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) = setSrcSpan loc $ - addErrCtxt (instDeclCtxt1 poly_ty) $ - do { (tyvars, theta, clas, inst_tys) - <- tcHsClsInstType (InstDeclCtxt False) poly_ty + addErrCtxt (instDeclCtxt1 hs_ty) $ + do { traceTc "tcLocalInstDecl" (ppr hs_ty) + ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty + ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance - ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env - mb_info = Just (clas, tyvars, mini_env) + ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars + ; let tv_skol_prs = [ (tyVarName tv, skol_tv) + | (tv, skol_tv) <- tyvars `zip` skol_tvs ] + n_inferred = countWhile ((== Inferred) . binderArgFlag) $ + fst $ splitForAllVarBndrs dfun_ty + visible_skol_tvs = drop n_inferred skol_tvs + + ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs $$ ppr visible_skol_tvs) -- Next, process any associated types. - ; traceTc "tcLocalInstDecl" (ppr poly_ty) - ; tyfam_insts0 <- scopeTyVars InstSkol tyvars $ - mapAndRecoverM (tcTyFamInstDecl mb_info) ats - ; datafam_stuff <- scopeTyVars InstSkol tyvars $ - mapAndRecoverM (tcDataFamInstDecl mb_info) adts - ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff - deriv_infos = catMaybes m_deriv_infos + ; (datafam_stuff, tyfam_insts) + <- tcExtendNameTyVarEnv tv_skol_prs $ + do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env + mb_info = InClsInst { ai_class = clas + , ai_tyvars = visible_skol_tvs + , ai_inst_env = mini_env } + ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts + ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats + + -- Check for missing associated types and build them + -- from their defaults (if available) + ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) + (classATItems clas) + + ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } - -- Check for missing associated types and build them - -- from their defaults (if available) - ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) - `unionNameSet` - mkNameSet (map (unLoc . feqn_tycon - . hsib_body - . dfid_eqn - . unLoc) adts) - ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats) - (classATItems clas) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty)) + ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) -- Dfun location is that of instance *header* - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta - clas inst_tys + ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + tyvars theta clas inst_tys + + ; let inst_binds = InstBindings + { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings + , ib_pragmas = uprags + , ib_extensions = [] + , ib_derived = False } + inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } - ; let inst_info = InstInfo { iSpec = ispec - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = map Var.varName tyvars -- Scope over bindings - , ib_pragmas = uprags - , ib_extensions = [] - , ib_derived = False } } + (datafam_insts, m_deriv_infos) = unzip datafam_stuff + deriv_infos = catMaybes m_deriv_infos + all_insts = tyfam_insts ++ datafam_insts -- In hs-boot files there should be no bindings ; is_boot <- tcIsHsBootOrSig ; let no_binds = isEmptyLHsBinds binds && null uprags ; failIfTc (is_boot && not no_binds) badBootDeclErr - ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts - , deriv_infos ) } + ; return ( [inst_info], all_insts, deriv_infos ) } + where + defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSet` + mkNameSet (map (unLoc . feqn_tycon + . hsib_body + . dfid_eqn + . unLoc) adts) + tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl" {- ************************************************************************ * * - Type checking family instances + Type family instances * * ************************************************************************ @@ -537,37 +554,18 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). -} -tcFamInstDeclCombined :: Maybe ClsInstInfo - -> Located Name -> TcM TyCon -tcFamInstDeclCombined mb_clsinfo fam_tc_lname - = do { -- Type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; traceTc "tcFamInstDecl" (ppr fam_tc_lname) - ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl fam_tc_lname - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Look up the family TyCon and check for validity including - -- check that toplevel type instances are not for associated types. - ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname - ; when (isNothing mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc_lname) - - ; return fam_tc } - -tcTyFamInstDecl :: Maybe ClsInstInfo +tcTyFamInstDecl :: AssocInstInfo -> LTyFamInstDecl GhcRn -> TcM FamInst -- "type instance" + -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ do { let fam_lname = feqn_tycon (hsib_body eqn) - ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname + ; fam_tc <- tcLookupLocatedTyCon fam_lname + ; tcFamInstDeclChecks mb_clsinfo fam_tc -- (0) Check it's an open type family - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) @@ -575,90 +573,151 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo (L (getLoc fam_lname) eqn) + -- (2) check for validity - ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch + ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch + ; checkValidCoAxBranch fam_tc co_ax_branch -- (3) construct coercion axiom ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; newFamInst SynFamilyInst axiom } -tcDataFamInstDecl :: Maybe ClsInstInfo + +--------------------- +tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () +-- Used for both type and data families +tcFamInstDeclChecks mb_clsinfo fam_tc + = do { -- Type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; traceTc "tcFamInstDecl" (ppr fam_tc) + ; type_families <- xoptM LangExt.TypeFamilies + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl fam_tc + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Check that it is a family TyCon, and that + -- oplevel type instances are not for associated types. + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + + ; when (isNotAssociated mb_clsinfo && -- Not in a class decl + isTyConAssoc fam_tc) -- but an associated type + (addErr $ assocInClassErr fam_tc) + } + +{- Note [Associated type instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow this: + class C a where + type T x a + instance C Int where + type T (S y) Int = y + type T Z Int = Char + +Note that + a) The variable 'x' is not bound by the class decl + b) 'x' is instantiated to a non-type-variable in the instance + c) There are several type instance decls for T in the instance + +All this is fine. Of course, you can't give any *more* instances +for (T ty Int) elsewhere, because it's an *associated* type. + + +************************************************************************ +* * + Data family instances +* * +************************************************************************ + +For some reason data family instances are a lot more complicated +than type family instances +-} + +tcDataFamInstDecl :: AssocInstInfo -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) -- "newtype instance" and "data instance" tcDataFamInstDecl mb_clsinfo - (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names + (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_bndrs = mb_bndrs - , feqn_pats = pats - , feqn_tycon = fam_tc_name + , feqn_pats = hs_pats + , feqn_tycon = lfam_name@(L _ fam_name) , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType - , dd_ctxt = ctxt - , dd_cons = cons + , feqn_rhs = HsDataDefn { dd_ND = new_or_data + , dd_cType = cType + , 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 <- tcFamInstDeclCombined mb_clsinfo fam_tc_name - - -- Check that the family declaration is for the right kind - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + do { fam_tc <- tcLookupLocatedTyCon lfam_name - -- Kind check type patterns - ; let mb_kind_env = thdOf3 <$> mb_clsinfo - ; tcFamTyPats fam_tc mb_clsinfo tv_names mb_bndrs pats - (kcDataDefn mb_kind_env decl) $ - \tvs pats res_kind -> - do { stupid_theta <- solveEqualities $ tcHsContext ctxt + ; tcFamInstDeclChecks mb_clsinfo fam_tc - -- Zonk the patterns etc into the Type world - ; (ze, tvs') <- zonkTyBndrs tvs - ; pats' <- zonkTcTypesToTypesX ze pats - ; res_kind' <- zonkTcTypeToTypeX ze res_kind - ; stupid_theta' <- zonkTcTypesToTypesX ze stupid_theta - - ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons - - -- Construct representation tycon - ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' - ; axiom_name <- newFamInstAxiomName fam_tc_name [pats'] - - ; let (eta_pats, etad_tvs) = eta_reduce pats' - eta_tvs = filterOut (`elem` etad_tvs) tvs' - -- NB: the "extra" tvs from tcDataKindSig would always be eta-reduced - - full_tcbs = mkTyConBindersPreferAnon (eta_tvs ++ etad_tvs) res_kind' + -- Check that the family declaration is for the right kind + ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons + -- Do /not/ check that the number of patterns = tyConArity fam_tc + -- See [Arity of data families] in FamInstEnv + + ; (qtvs, pats, res_kind, stupid_theta) + <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs + fixity hs_ctxt hs_pats m_ksig hs_cons + + -- Eta-reduce the axiom if possible + -- Quite tricky: see Note [Eta-reduction for data families] + ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats + eta_tvs = map binderVar eta_tcbs + post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs + + full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs + (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) + ++ eta_tcbs -- Put the eta-removed tyvars at the end - -- Remember, tvs' is in arbitrary order (except kind vars are - -- first, so there is no reason to suppose that the etad_tvs + -- Remember, qtvs is in arbitrary order, except kind vars are + -- first, so there is no reason to suppose that the eta_tvs -- (obtained from the pats) are at the end (Trac #11148) - -- Deal with any kind signature. - -- See also Note [Arity of data families] in FamInstEnv - ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind' - ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind') - + -- Eta-expand the representation tycon until it has reult kind * + -- See also Note [Arity of data families] in FamInstEnv + -- NB: we can do this after eta-reducing the axiom, because if + -- we did it before the "extra" tvs from etaExpandAlgTyCon + -- would always be eta-reduced + ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind + ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind) ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats' `chkAppend` extra_pats + all_pats = pats `chkAppend` extra_pats orig_res_ty = mkTyConApp fam_tc all_pats + ty_binders = full_tcbs `chkAppend` extra_tcbs + + ; traceTc "tcDataFamInstDecl" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "ty_binders" <+> ppr ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { let ty_binders = full_tcbs `chkAppend` extra_tcbs - ; data_cons <- tcConDecls rec_rep_tc - ty_binders orig_res_ty cons + do { data_cons <- tcExtendTyVarEnv qtvs $ + -- For H98 decls, the tyvars scope + -- over the data constructors + tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons + + ; rep_tc_name <- newFamInstTyConName lfam_name pats + ; axiom_name <- newFamInstAxiomName lfam_name [pats] ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - -- freshen tyvars - ; let axiom = mkSingleCoAxiom Representational - axiom_name eta_tvs [] fam_tc eta_pats - (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) - parent = DataFamInstTyCon axiom fam_tc all_pats + ; let axiom = mkSingleCoAxiom Representational axiom_name + post_eta_qtvs eta_tvs [] fam_tc eta_pats + (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)) + parent = DataFamInstTyCon axiom fam_tc all_pats -- NB: Use the full ty_binders from the pats. See bullet toward -- the end of Note [Data type families] in TyCon @@ -675,15 +734,12 @@ tcDataFamInstDecl mb_clsinfo -- they involve a coercion. ; return (rep_tc, axiom) } - -- Remember to check validity; no recursion to worry about here - -- Check that left-hand sides are ok (mono-types, no type families, - -- consistent instantiations, etc) - ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats - - -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (tcIsLiftedTypeKind final_res_kind) $ - tooFewParmsErr (tyConArity fam_tc) - + -- Remember to check validity; no recursion to worry about here + -- Check that left-hand sides are ok (mono-types, no type families, + -- consistent instantiations, etc) + ; let ax_branch = coAxiomSingleBranch axiom + ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch + ; checkValidCoAxBranch fam_tc ax_branch ; checkValidTyCon rep_tc ; let m_deriv_info = case derivs of @@ -694,38 +750,182 @@ tcDataFamInstDecl mb_clsinfo , di_ctxt = tcMkDataFamInstCtxt decl } ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom - ; return (fam_inst, m_deriv_info) } } + ; return (fam_inst, m_deriv_info) } where - eta_reduce :: [Type] -> ([Type], [TyVar]) + eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) -- See Note [Eta reduction for data families] in FamInstEnv -- Splits the incoming patterns into two: the [TyVar] -- are the patterns that can be eta-reduced away. -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) -- -- NB: quadratic algorithm, but types are small here - eta_reduce pats - = go (reverse pats) [] - go (pat:pats) etad_tvs + eta_reduce fam_tc pats + = go (reverse (zip3 pats fvs_s vis_s)) [] + where + vis_s :: [TyConBndrVis] + vis_s = tcbVisibilities fam_tc pats + + fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats + -- Each elt is the free vars of all /earlier/ pats + (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats + add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) + + go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` tyCoVarsOfTypes pats) - = go pats (tv : etad_tvs) - go pats etad_tvs = (reverse pats, etad_tvs) + , not (tv `elemVarSet` fvs_to_the_left) + = go pats (Bndr tv tcb_vis : etad_tvs) + go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) + +tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl" + +----------------------- +tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] + -> LexicalFixity -> LHsContext GhcRn + -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] + -> TcM ([TyVar], [Type], Kind, ThetaType) +-- The "header" is the part other than the data constructors themselves +-- e.g. data instance D [a] :: * -> * = ... +-- Here the "header" is the bit before the "=" sign +tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons + = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { stupid_theta <- tcHsContext hs_ctxt + ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc mb_clsinfo hs_pats + ; mapM_ (wrapLocM_ kcConDecl) hs_cons + ; res_kind <- tc_kind_sig m_ksig + ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind + ; return (stupid_theta, lhs_ty, res_kind) } + + -- See Note [Generalising in tcFamTyPatsAndThen] + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars emptyVarSet dvs + + -- Zonk the patterns etc into the Type world + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; res_kind <- zonkTcTypeToTypeX ze res_kind + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + + -- Check that type patterns match the class instance head + ; let pats = unravelFamInstPats lhs_ty + ; return (qtvs, pats, res_kind, stupid_theta) } + where + fam_name = tyConName fam_tc + data_ctxt = DataKindCtxt fam_name + pp_lhs = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt + exp_bndrs = mb_bndrs `orElse` [] + + -- See Note [Result kind signature for a data family instance] + tc_kind_sig Nothing + = return liftedTypeKind + tc_kind_sig (Just hs_kind) + = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind + ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind + ; lvl <- getTcLevel + ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; return (substTy subst inner_kind) } + +{- Note [Result kind signature for a data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expected type might have a forall at the type. Normally, we +can't skolemise in kinds because we don't have type-level lambda. +But here, we're at the top-level of an instance declaration, so +we actually have a place to put the regeneralised variables. +Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise +Examples in indexed-types/should_compile/T12369 + +Note [Eta-reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data D :: * -> * -> * -> * -> * + + data instance D [(a,b)] p q :: * -> * where + D1 :: blah1 + D2 :: blah2 - pp_hs_pats = pprFamInstLHS fam_tc_name mb_bndrs pats fixity (unLoc ctxt) m_ksig +Then we'll generate a representation data type + data Drep a b p q z where + D1 :: blah1 + D2 :: blah2 -tcDataFamInstDecl _ - (L _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn _ }}})) - = panic "tcDataFamInstDecl" -tcDataFamInstDecl _ (L _ (DataFamInstDecl (XHsImplicitBndrs _))) - = panic "tcDataFamInstDecl" -tcDataFamInstDecl _ (L _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) - = panic "tcDataFamInstDecl" +and an axiom to connect them + axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z + +except that we'll eta-reduce the axiom to + axiom AxDrep forall a b. D [(a,b]] = Drep a b +There are several fiddly subtleties lurking here + +* The representation tycon Drep is parameerised over the free + variables of the pattern, in no particular order. So there is no + guarantee that 'p' and 'q' will come last in Drep's parameters, and + in the right order. So, if the /patterns/ of the family insatance + are eta-redcible, we re-order Drep's parameters to put the + eta-reduced type variables last. + +* Although we eta-reduce the axiom, we eta-/expand/ the representation + tycon Drep. The kind of D says it takses four arguments, but the + data instance header only supplies three. But the AlgTyCOn for Drep + itself must have enough TyConBinders so that its result kind is Type. + So, with etaExpandAlgTyCon we make up some extra TyConBinders + +* The result kind in the instance might be a polykind, like this: + data family DP a :: forall k. k -> * + data instance DP [b] :: forall k1 k2. (k1,k2) -> * + + So in type-checking the LHS (DP Int) we need to check that it is + more polymorphic than the signature. To do that we must skolemise + the siganture and istantiate the call of DP. So we end up with + data instance DP [b] @(k1,k2) (z :: (k1,k2)) where + + Note that we must parameterise the representation tycon DPrep over + 'k1' and 'k2', as well as 'b'. + + The skolemise bit is done in tc_kind_sig, while the instantiate bit + is done by the checkExpectedKind that immediately follows. + +* Very fiddly point. When we eta-reduce to + axiom AxDrep forall a b. D [(a,b]] = Drep a b + + we want the kind of (D [(a,b)]) to be the same as the kind of + (Drep a b). This ensures that applying the axiom doesn't change the + kind. Why is that hard? Because the kind of (Drep a b) depends on + the TyConBndrVis on Drep's arguments. In particular do we have + (forall (k::*). blah) or (* -> blah)? + + We must match whatever D does! In Trac #15817 we had + data family X a :: forall k. * -> * -- Note: a forall that is not used + data instance X Int b = MkX + + So the data intance is really + data istance X Int @k b = MkX + + The axiom will look like + axiom X Int = Xrep + + and it's important that XRep :: forall k * -> *, following X. + + To achieve this we get the TyConBndrVis flags from tcbVisibilities, + and use those flags for any eta-reduced arguments. Sigh. + +* The final turn of the knife is that tcbVisibilities is itself + tricky to sort out. Consider + data family D k :: k + Then consider D (forall k2. k2 -> k2) Type Type + The visibilty flags on an application of D may affected by the arguments + themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities + does. + +-} {- ********************************************************************* * * - Type-checking instance declarations, pass 2 + Class instance declarations, pass 2 * * ********************************************************************* -} @@ -794,7 +994,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars @@ -1253,8 +1453,6 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys , ib_pragmas = sigs , ib_extensions = exts , ib_derived = is_derived }) - -- tcExtendTyVarEnv (not scopeTyVars) is OK because the TcLevel is pushed - -- in checkInstConstraints = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ -- The lexical_tvs scope over the 'where' part do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) @@ -1872,8 +2070,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) = addErrCtxt (spec_ctxt prag) $ - do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty - ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys + do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where @@ -1912,17 +2109,12 @@ notFamily tycon = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] -tooFewParmsErr :: Arity -> SDoc -tooFewParmsErr arity - = text "Family instance has too few parameters; expected" <+> - ppr arity - -assocInClassErr :: Located Name -> SDoc +assocInClassErr :: TyCon -> SDoc assocInClassErr name = text "Associated type" <+> quotes (ppr name) <+> text "must be inside a class instance" -badFamInstDecl :: Located Name -> SDoc +badFamInstDecl :: TyCon -> SDoc badFamInstDecl tc_name = vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index c3786e20bf..3500b72a54 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -41,6 +41,7 @@ module TcMType ( newEvVar, newEvVars, newDict, newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, + emitDerivedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, newCoercionHole, fillCoercionHole, isFilledCoercionHole, @@ -53,11 +54,10 @@ module TcMType ( newMetaTyVarTyVars, newMetaTyVarTyVarX, newTyVarTyVar, newTauTyVar, newSkolemTyVar, newWildCardX, tcInstType, - tcInstSkolTyVars,tcInstSkolTyVarsX, - tcInstSuperSkolTyVarsX, - tcSkolDFunType, tcSuperSkolTyVars, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - instSkolTyCoVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, + freshenTyVarBndrs, freshenCoVarBndrsX, -------------------------------- -- Zonking and tidying @@ -67,9 +67,10 @@ module TcMType ( zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkTyCoVarsAndFVList, - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, CandidatesQTvs(..), - zonkQuantifiedTyVar, defaultTyVar, + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + CandidatesQTvs(..), delCandidates, candidateKindVars, + skolemiseQuantifiedTyVar, defaultTyVar, quantifyTyVars, zonkTcTyCoVarBndr, zonkTyConBinders, zonkTcType, zonkTcTypes, zonkCo, @@ -113,7 +114,6 @@ import PrelNames import Util import Outputable import FastString -import SrcLoc import Bag import Pair import UniqSet @@ -121,7 +121,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Maybes -import Data.List ( mapAccumL, partition ) +import Data.List ( mapAccumL ) import Control.Arrow ( second ) import qualified Data.Semigroup as Semi @@ -232,6 +232,20 @@ emitWanted origin pty ; emitSimple $ mkNonCanonical ev ; return $ ctEvTerm ev } +emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new derived nominal equalities +emitDerivedEqs origin pairs + | null pairs + = return () + | otherwise + = do { loc <- getCtLocM origin Nothing + ; emitSimples (listToBag (map (mk_one loc) pairs)) } + where + mk_one loc (ty1, ty2) + = mkNonCanonical $ + CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 + , ctev_loc = loc } + -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2 @@ -507,108 +521,101 @@ tcSuperSkolTyVar subst tv -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the --- skolems, and the list of newly bound skolems. See also --- tcInstSkolTyVars' for a precondition. The resulting --- skolems are non-overlappable; see Note [Overlap and deriving] --- for an example where this matters. +-- skolems, and the list of newly bound skolems. tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX = tcInstSkolTyVars' False +-- See Note [Skolemising type variables] +tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- See Note [Skolemising type variables] tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst - -tcInstSkolTyVars' :: Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] --- Get the location from the monad; this is a complete freshening operation -tcInstSkolTyVars' overlappable subst tvs - = do { loc <- getSrcSpanM - ; lvl <- getTcLevel - ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs } - -mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyCoVarMaker gbl lcl --- Allocates skolems whose level is ONE GREATER THAN the passed-in tc_lvl --- See Note [Skolem level allocation] -mkTcSkolTyVar tc_lvl loc overlappable old_name kind - = do { uniq <- newUnique - ; let name = mkInternalName uniq (getOccName old_name) loc - ; return (mkTcTyVar name kind details) } +-- See Note [Skolemising type variables] +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst + +tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +-- Skolemise one level deeper, hence pushTcLevel +-- See Note [Skolemising type variables] +tcInstSkolTyVarsPushLevel overlappable subst tvs + = do { tc_lvl <- getTcLevel + ; let pushed_lvl = pushTcLevel tc_lvl + ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } + +tcInstSkolTyVarsAt :: TcLevel -> Bool + -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsAt lvl overlappable subst tvs + = freshenTyCoVarsX new_skol_tv subst tvs where - details = SkolemTv (pushTcLevel tc_lvl) overlappable - -- pushTcLevel: see Note [Skolem level allocation] - -{- Note [Skolem level allocation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We generally allocate skolems /before/ calling pushLevelAndCaptureConstraints. -So we want their level to the level of the soon-to-be-created implication, -which has a level one higher than the current level. Hence the pushTcLevel. -It feels like a slight hack. Applies also to vanillaSkolemTv. - --} + details = SkolemTv lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind details ------------------ -freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar]) +freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay -- as TyVars, rather than becoming TcTyVars -- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = instSkolTyCoVars mk_tv - where - mk_tv old_name kind - = do { uniq <- newUnique - ; return (mkTyVar (setNameUnique old_name uniq) kind) } +freshenTyVarBndrs = freshenTyCoVars mkTyVar -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar]) +freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) -- ^ Give fresh uniques to a bunch of CoVars -- Used in FamInst.newFamInst -freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst - where - mk_cv old_name kind - = do { uniq <- newUnique - ; return (mkCoVar (setNameUnique old_name uniq) kind) } +freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst ------------------ -type TcTyCoVarMaker gbl lcl = Name -> Kind -> TcRnIf gbl lcl TyCoVar - -- The TcTyCoVarMaker should make a fresh Name, based on the old one - -- Freshness is critical. See Note [Skolems in zonkSyntaxExpr] in TcHsSyn - -instSkolTyCoVars :: TcTyCoVarMaker gbl lcl -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) -instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst - -instSkolTyCoVarsX :: TcTyCoVarMaker gbl lcl - -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) -instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv) - -instSkolTyCoVarX :: TcTyCoVarMaker gbl lcl - -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar) -instSkolTyCoVarX mk_tcv subst tycovar - = do { new_tcv <- mk_tcv old_name kind - ; let subst1 | isTyVar new_tcv - = extendTvSubstWithClone subst tycovar new_tcv - | otherwise - = extendCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } - where - old_name = tyVarName tycovar - kind = substTyUnchecked subst (tyVarKind tycovar) +freshenTyCoVars :: (Name -> Kind -> TyCoVar) + -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst + +freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> [TyCoVar] + -> TcM (TCvSubst, [TyCoVar]) +freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) + +freshenTyCoVarX :: (Name -> Kind -> TyCoVar) + -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) +-- This a complete freshening operation: +-- the skolems have a fresh unique, and a location from the monad +-- See Note [Skolemising type variables] +freshenTyCoVarX mk_tcv subst tycovar + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let old_name = tyVarName tycovar + new_name = mkInternalName uniq (getOccName old_name) loc + new_kind = substTyUnchecked subst (tyVarKind tycovar) + new_tcv = mk_tcv new_name new_kind + subst1 = extendTCvSubstWithClone subst tycovar new_tcv + ; return (subst1, new_tcv) } + +{- Note [Skolemising type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcInstSkolTyVars family of functions instantiate a list of TyVars +to fresh skolem TcTyVars. Important notes: + +a) Level allocation. We generally skolemise /before/ calling + pushLevelAndCaptureConstraints. So we want their level to the level + of the soon-to-be-created implication, which has a level ONE HIGHER + than the current level. Hence the pushTcLevel. It feels like a + slight hack. + +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 + non-overlappable for tcInstSkolTyVars, + but overlappable for tcInstSuperSkolTyVars + See TcDerivInfer Note [Overlap and deriving] for an example + of where this matters. -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; let details = MetaTv { mtv_info = FlatSkolTv - , mtv_ref = ref - , mtv_tclvl = tclvl } - name = mkMetaTyVarName uniq (fsLit "fsk") - ; return (mkTcTyVar name (typeKind fam_ty) details) } - -{- Note [Kind substitution when instantiating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we instantiate a bunch of kind and type variables, first we @@ -648,9 +655,10 @@ but this restriction was dropped, and ScopedTypeVariables can now refer to full types (GHC Proposal 29). The remaining uses of newTyVarTyVars are -* in kind signatures, see Note [Kind generalisation and TyVarTvs] - and Note [Use TyVarTvs in kind-checking pass] -* in partial type signatures, see Note [Quantified variables in partial type signatures] +* In kind signatures, see + TcTyClsDecls Note [Inferring kinds for type declarations] + and Note [Kind checking for GADTs] +* In partial type signatures, see Note [Quantified variables in partial type signatures] -} -- see Note [TyVarTv] @@ -667,6 +675,17 @@ newSkolemTyVar :: Name -> Kind -> TcM TcTyVar newSkolemTyVar name kind = do { lvl <- getTcLevel ; return (mkTcTyVar name kind (SkolemTv lvl False)) } +newFskTyVar :: TcType -> TcM TcTyVar +newFskTyVar fam_ty + = do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; let details = MetaTv { mtv_info = FlatSkolTv + , mtv_ref = ref + , mtv_tclvl = tclvl } + name = mkMetaTyVarName uniq (fsLit "fsk") + ; return (mkTcTyVar name (typeKind fam_ty) details) } + newFmvTyVar :: TcType -> TcM TcTyVar -- Very like newMetaTyVar, except sets mtv_tclvl to one less -- so that the fmv is untouchable. @@ -910,27 +929,27 @@ newOpenFlexiTyVarTy = do { kind <- newOpenTypeKind ; newFlexiTyVarTy kind } -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst - newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables -- Note that this works for a sequence of kind, type, and coercion variables -- variables. Eg [ (k:*), (a:k->k) ] -- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = mapAccumLM newMetaTyVarX emptyTCvSubst +newMetaTyVars = newMetaTyVarsX emptyTCvSubst -- emptyTCvSubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. +newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +-- Just like newMetaTyVars, but start with an existing substitution. +newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst + newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar -newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst +newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv @@ -1006,13 +1025,9 @@ instance Outputable CandidatesQTvs where , text "dv_tvs =" <+> ppr tvs , text "dv_cvs =" <+> ppr cvs ]) -closeOverKindsCQTvs :: TyCoVarSet -- globals - -> CandidatesQTvs -> TcM CandidatesQTvs --- Don't close the covars; this is done in quantifyTyVars. Note that --- closing over the CoVars would introduce tyvars into the CoVarSet. -closeOverKindsCQTvs gbl_tvs dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) - = do { let all_kinds = map tyVarKind (dVarSetElems (kvs `unionDVarSet` tvs)) - ; foldlM (collect_cand_qtvs True gbl_tvs) dv all_kinds } + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) {- Note [Dependent type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1081,40 +1096,43 @@ Note [CandidatesQTvs determinism and order] Note [Naughty quantification candidates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14880, dependent/should_compile/T14880-2) +Consider (#14880, dependent/should_compile/T14880-2), suppose +we are trying to generalise this type: forall arg. ... (alpha[tau]:arg) ... -We have a metavariable alpha whose kind is a locally bound (skolem) variable. +We have a metavariable alpha whose kind mentions a skolem variable +boudn inside the very type we are generalising. This can arise while type-checking a user-written type signature -(see the test case for the full code). According to -Note [Recipe for checking a signature] in TcHsType, we try to solve -all constraints that arise during checking before looking to kind-generalize. -However, in the case above, this solving pass does not unify alpha, because -it is utterly unconstrained. The question is: what to do with alpha? - -We can't generalize it, because it would have to be generalized *after* -arg, and implicit generalization always goes before explicit generalization. -We can't simply leave it be, because this type is about to go into the -typing environment (as the type of some let-bound variable, say), and then -chaos erupts when we try to instantiate. In any case, we'll never learn -anything more about alpha anyway. +(see the test case for the full code). + +We cannot generalise over alpha! That would produce a type like + forall {a :: arg}. forall arg. ...blah... +The fact that alpha's kind mentions arg renders it completely +ineligible for generaliation. + +However, we are not going to learn any new constraints on alpha, +because its kind isn't even in scope in the outer context. So alpha +is entirely unconstrained. + +What then should we do with alpha? During generalization, every +metavariable is either (A) promoted, (B) generalized, or (C) zapped +(according again to Note [Recipe for checking a signature] in +TcHsType). + + * We can't generalise it. + * We can't promote it, because its kind prevents that + * We can't simply leave it be, because this type is about to + go into the typing environment (as the type of some let-bound + variable, say), and then chaos erupts when we try to instantiate. So, we zap it, eagerly, to Any. We don't have to do this eager zapping in terms (say, in `length []`) because terms are never re-examined before the final zonk (which zaps any lingering metavariables to Any). -The right time to do this eager zapping is during generalization, when -every metavariable is either (A) promoted, (B) generalized, or (C) zapped -(according again to Note [Recipe for checking a signature] in TcHsType). - -Accordingly, when quantifyTyVars is skolemizing the variables to quantify, -these naughty ones are zapped to Any. We identify the naughty ones by -looking for out-of-scope tyvars in the candidate tyvars' kinds, where -we assume that all in-scope tyvars are in the gbl_tvs passed to quantifyTyVars. -In the example above, we would have `alpha` in the CandidatesQTvs, but -`arg` wouldn't be in the gbl_tvs. Hence, alpha is naughty, and zapped to -Any. Naughty variables are discovered by is_naughty_tv in quantifyTyVars. +We do this eager zapping in candidateQTyVars, which always precedes +generalisation, because at that moment we have a clear picture of +what skolems are in scope. -} @@ -1123,21 +1141,31 @@ Any. Naughty variables are discovered by is_naughty_tv in quantifyTyVars. -- in both sets, if it's used in both a type and a kind. -- See Note [CandidatesQTvs determinism and order] -- See Note [Dependent type variables] -candidateQTyVarsOfType :: TcTyVarSet -- zonked set of global/mono tyvars - -> TcType -- not necessarily zonked +candidateQTyVarsOfType :: TcType -- not necessarily zonked -> TcM CandidatesQTvs -candidateQTyVarsOfType gbl_tvs ty = closeOverKindsCQTvs gbl_tvs =<< - collect_cand_qtvs False gbl_tvs mempty ty +candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty + +-- | Like 'splitDepVarsOfType', but over a list of types +candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs +candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys -- | Like 'candidateQTyVarsOfType', but consider every free variable -- to be dependent. This is appropriate when generalizing a *kind*, -- instead of a type. (That way, -XNoPolyKinds will default the variables -- to Type.) -candidateQTyVarsOfKind :: TcTyVarSet -- zonked set of global/mono tyvars - -> TcKind -- not necessarily zonked +candidateQTyVarsOfKind :: TcKind -- not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty + +candidateQTyVarsOfKinds :: [TcKind] -- not necessarily zonked -> TcM CandidatesQTvs -candidateQTyVarsOfKind gbl_tvs ty = closeOverKindsCQTvs gbl_tvs =<< - collect_cand_qtvs True gbl_tvs mempty ty +candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys + +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } collect_cand_qtvs :: Bool -- True <=> consider every fv in Type to be dependent -> VarSet -- bound variables (both locally bound and globally bound) @@ -1145,6 +1173,11 @@ collect_cand_qtvs :: Bool -- True <=> consider every fv in Type to be dependen collect_cand_qtvs is_dep bound dvs ty = go dvs ty where + is_bound tv = tv `elemVarSet` bound + + ----------------- + go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs + -- Uses accumulating-parameter style go dv (AppTy t1 t2) = foldlM go dv [t1, t2] go dv (TyConApp _ tys) = foldlM go dv tys go dv (FunTy arg res) = foldlM go dv [arg, res] @@ -1154,50 +1187,50 @@ collect_cand_qtvs is_dep bound dvs ty go dv (CoercionTy co) = collect_cand_qtvs_co bound dv co go dv (TyVarTy tv) - | is_bound tv - = return dv - - | isImmutableTyVar tv - = WARN(True, (sep [ text "Note [Naughty quantification candidates] skolem:" - , ppr tv <+> dcolon <+> ppr (tyVarKind tv) ])) - return dv -- This happens when processing kinds of variables affected by - -- Note [Naughty quantification candidates] - -- NB: CandidatesQTvs stores only MetaTvs, so don't store an - -- immutable tyvar here. - - | otherwise - = ASSERT2( isMetaTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) $$ ppr ty $$ ppr bound ) - do { m_contents <- isFilledMetaTyVar_maybe tv - ; case m_contents of - Just ind_ty -> go dv ind_ty - - Nothing -> return $ insert_tv dv tv } + | is_bound tv = return dv + | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv + ; case m_contents of + Just ind_ty -> go dv ind_ty + Nothing -> go_tv dv tv } go dv (ForAllTy (Bndr tv _) ty) = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv) ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty } - is_bound tv = tv `elemVarSet` bound + ----------------- + go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv + | is_dep + = case tv `elemDVarSet` kvs of + True -> return dv -- We have met this tyvar aleady + False | intersectsVarSet bound (tyCoVarsOfType tv_kind) + -> -- See Note [Naughty quantification candidates] + zap_naughty + | otherwise + -> collect_cand_qtvs True emptyVarSet dv' tv_kind + where + dv' = dv { dv_kvs = kvs `extendDVarSet` tv } + -- See Note [Order of accumulation] - insert_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv } - | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv } - -- You might be tempted (like I was) to use unitDVarSet and mappend here. - -- However, the union algorithm for deterministic sets depends on (roughly) - -- the size of the sets. The elements from the smaller set end up to the - -- right of the elements from the larger one. When sets are equal, the - -- left-hand argument to `mappend` goes to the right of the right-hand - -- argument. In our case, if we use unitDVarSet and mappend, we learn that - -- the free variables of (a -> b -> c -> d) are [b, a, c, d], and we then - -- quantify over them in that order. (The a comes after the b because we - -- union the singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, - -- the size criterion works to our advantage.) This is just annoying to - -- users, so I use `extendDVarSet`, which unambiguously puts the new element - -- to the right. Note that the unitDVarSet/mappend implementation would not - -- be wrong against any specification -- just suboptimal and confounding to users. + | otherwise + = case tv `elemDVarSet` kvs || tv `elemDVarSet` tvs of + True -> return dv -- We have met this tyvar aleady + False | intersectsVarSet bound (tyCoVarsOfType tv_kind) + -> -- See Note [Naughty quantification candidates] + zap_naughty + | otherwise + -> collect_cand_qtvs True emptyVarSet dv' tv_kind + where + dv' = dv { dv_tvs = tvs `extendDVarSet` tv } + -- See Note [Order of accumulation] + where + tv_kind = tyVarKind tv + zap_naughty = do { traceTc "Zapping naughty quantifier" (pprTyVar tv) + ; writeMetaTyVar tv (anyTypeOfKind tv_kind) + ; collect_cand_qtvs True bound dv tv_kind } collect_cand_qtvs_co :: VarSet -- bound variables - -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs + -> CandidatesQTvs -> Coercion + -> TcM CandidatesQTvs collect_cand_qtvs_co bound = go_co where go_co dv (Refl ty) = collect_cand_qtvs True bound dv ty @@ -1222,13 +1255,9 @@ collect_cand_qtvs_co bound = go_co go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole case m_co of Just co -> go_co dv co - Nothing -> return $ insert_cv dv (coHoleCoVar hole) + Nothing -> go_cv dv (coHoleCoVar hole) - go_co dv (CoVarCo cv) - | is_bound cv - = return dv - | otherwise - = return $ insert_cv dv cv + go_co dv (CoVarCo cv) = go_cv dv cv go_co dv (ForAllCo tcv kind_co co) = do { dv1 <- go_co dv kind_co @@ -1242,16 +1271,36 @@ collect_cand_qtvs_co bound = go_co go_prov dv (ProofIrrelProv co) = go_co dv co go_prov dv (PluginProv _) = return dv - insert_cv dv@(DV { dv_cvs = cvs }) cv - = dv { dv_cvs = cvs `extendVarSet` cv } + go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs + go_cv dv@(DV { dv_cvs = cvs }) cv + | is_bound cv = return dv + | cv `elemVarSet` cvs = return dv + | otherwise = collect_cand_qtvs True emptyVarSet + (dv { dv_cvs = cvs `extendVarSet` cv }) + (idType cv) is_bound tv = tv `elemVarSet` bound --- | Like 'splitDepVarsOfType', but over a list of types -candidateQTyVarsOfTypes :: TyCoVarSet -- zonked global ty/covars - -> [Type] -> TcM CandidatesQTvs -candidateQTyVarsOfTypes gbl_tvs tys = closeOverKindsCQTvs gbl_tvs =<< - foldlM (collect_cand_qtvs False gbl_tvs) mempty tys +{- Note [Order of accumulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might be tempted (like I was) to use unitDVarSet and mappend +rather than extendDVarSet. However, the union algorithm for +deterministic sets depends on (roughly) the size of the sets. The +elements from the smaller set end up to the right of the elements from +the larger one. When sets are equal, the left-hand argument to +`mappend` goes to the right of the right-hand argument. + +In our case, if we use unitDVarSet and mappend, we learn that the free +variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify +over them in that order. (The a comes after the b because we union the +singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, +the size criterion works to our advantage.) This is just annoying to +users, so I use `extendDVarSet`, which unambiguously puts the new +element to the right. + +Note that the unitDVarSet/mappend implementation would not be wrong +against any specification -- just suboptimal and confounding to users. +-} {- ********************************************************************* * * @@ -1268,7 +1317,7 @@ It takes these free type/kind variables (partitioned into dependent and non-dependent variables) and 1. Zonks them and remove globals and covars 2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) - 3. Calls zonkQuantifiedTyVar on each + 3. Calls skolemiseQuantifiedTyVar on each Step (2) is often unimportant, because the kind variable is often also free in the type. Eg @@ -1309,8 +1358,10 @@ quantifyTyVars -- associated type declarations. Also accepts covars, but *never* returns any. quantifyTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars }) - = do { traceTc "quantifyTyVars 1" (vcat [ppr dvs, ppr gbl_tvs]) - ; let mono_tvs = gbl_tvs `unionVarSet` closeOverKinds covars + = do { outer_tclvl <- getTcLevel + ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs]) + ; let co_tvs = closeOverKinds covars + mono_tvs = gbl_tvs `unionVarSet` co_tvs -- NB: All variables in the kind of a covar must not be -- quantified over, as we don't quantify over the covar. @@ -1332,19 +1383,33 @@ quantifyTyVars gbl_tvs -- they are all in dep_tkvs -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV - -- See Note [Naughty quantification candidates] - (naughty_deps, final_dep_kvs) = partition (is_naughty_tv mono_tvs) dep_kvs - (naughty_nondeps, final_nondep_tvs) = partition (is_naughty_tv mono_tvs) nondep_tvs - - ; mapM_ zap_naughty_tv (naughty_deps ++ naughty_nondeps) + -- This block uses level numbers to decide what to quantify + -- and emits a warning if the two methods do not give the same answer + ; let dep_kvs2 = dVarSetElemsWellScoped $ + filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs + nondep_tvs2 = filter (quantifiableTv outer_tclvl) $ + dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) + + all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2 + bad_msg = hang (text "Quantification by level numbers would fail") + 2 (vcat [ text "Outer level =" <+> ppr outer_tclvl + , text "dep_tkvs =" <+> ppr dep_tkvs + , text "co_vars =" <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv) + | cv <- nonDetEltsUniqSet covars ] + , text "co_tvs =" <+> ppr co_tvs + , text "dep_kvs =" <+> ppr dep_kvs + , text "dep_kvs2 =" <+> ppr dep_kvs2 + , text "nondep_tvs =" <+> ppr nondep_tvs + , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ]) + ; WARN( not all_ok, bad_msg ) return () -- In the non-PolyKinds case, default the kind variables -- to *, and zonk the tyvars as usual. Notice that this -- may make quantifyTyVars return a shorter list -- than it was passed, but that's ok ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) final_dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) final_nondep_tvs + ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs + ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs ; let final_qtvs = dep_kvs' ++ nondep_tvs' -- Because of the order, any kind variables -- mentioned in the kinds of the nondep_tvs' @@ -1364,11 +1429,6 @@ quantifyTyVars gbl_tvs ; return final_qtvs } where - -- See Note [Naughty quantification candidates] - is_naughty_tv mono_tvs tv - = anyVarSet (isSkolemTyVar <&&> (not . (`elemVarSet` mono_tvs))) $ - tyCoVarsOfType (tyVarKind tv) - -- zonk_quant returns a tyvar if it should be quantified over; -- otherwise, it returns Nothing. The latter case happens for -- * Kind variables, with -XNoPolyKinds: don't quantify over these @@ -1378,21 +1438,28 @@ quantifyTyVars gbl_tvs = return Nothing -- this can happen for a covar that's associated with -- a coercion hole. Test case: typecheck/should_compile/T2494 - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types, we have the class variables - -- in scope, and they are TyVars not TcTyVars + | not (isTcTyVar tkv) -- I don't think this can ever happen. + -- Hence the assert + = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv) + return (Just tkv) + | otherwise = do { deflt_done <- defaultTyVar default_kind tkv ; case deflt_done of True -> return Nothing - False -> do { tv <- zonkQuantifiedTyVar tkv + False -> do { tv <- skolemiseQuantifiedTyVar tkv ; return (Just tv) } } - zap_naughty_tv tv - = WARN(True, text "naughty quantification candidate: " <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)) - writeMetaTyVar tv (anyTypeOfKind (tyVarKind tv)) +quantifiableTv :: TcLevel -- Level of the context, outside the quantification + -> TcTyVar + -> Bool +quantifiableTv outer_tclvl tcv + | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separtely + = tcTyVarLevel tcv > outer_tclvl + | otherwise + = False -zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables -- The meta tyvar is updated to point to the new skolem TyVar. Now any @@ -1404,7 +1471,7 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -zonkQuantifiedTyVar tv +skolemiseQuantifiedTyVar tv = case tcTyVarDetails tv of SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind) } @@ -1413,7 +1480,7 @@ zonkQuantifiedTyVar tv MetaTv {} -> skolemiseUnboundMetaTyVar tv - _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- RuntimeUnk + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk defaultTyVar :: Bool -- True <=> please default this kind variable to * -> TcTyVar -- If it's a MetaTyVar then it is unbound @@ -1427,7 +1494,7 @@ defaultTyVar default_kind tv -- Do not default TyVarTvs. Doing so would violate the invariants -- on TyVarTvs; see Note [Signature skolems] in TcType. -- Trac #13343 is an example; #14555 is another - -- See Note [Kind generalisation and TyVarTvs] + -- See Note [Inferring kinds for type declarations] in TcTyClsDecls = return False @@ -1671,13 +1738,13 @@ zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv | otherwise = ASSERT2( isCoVar tv, ppr tv ) mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv -- Hackily, when typechecking type and class decls - -- we have TyVars in scopeadded (only) in - -- TcHsType.tcTyClTyVars, but it seems + -- we have TyVars in scope added (only) in + -- TcHsType.bindTyClTyVars, but it seems -- painful to make them into TcTyVars there zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars = - tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) +zonkTyCoVarsAndFV tycovars + = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) -- It's OK to use nonDetEltsUniqSet here because we immediately forget about -- the ordering by turning it into a nondeterministic set and the order -- of zonking doesn't matter for determinism. @@ -1685,8 +1752,8 @@ zonkTyCoVarsAndFV tycovars = -- Takes a list of TyCoVars, zonks them and returns a -- deterministically ordered list of their free variables. zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars = - tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars +zonkTyCoVarsAndFVList tycovars + = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 7ac0dd4356..19ec6de622 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -410,7 +410,7 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty - -- Using tcExtendNameTyVarEnv is appropriate here (not scopeTyVars2) + -- Using tcExtendNameTyVarEnv is appropriate here -- because we're not really bringing fresh tyvars into scope. -- We're *naming* existing tyvars. Note that it is OK for a tyvar -- from an outer scope to mention one of these tyvars in its kind. diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index eefdb97f16..4942a8be83 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -146,23 +146,29 @@ tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details tcPat PatSyn lpat exp_ty $ mapM tcLookupId arg_names - ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args - - ; (qtvs, req_dicts, ev_binds, residual, _) + ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' + + named_taus = (name, pat_ty) : map mk_named_tau args + mk_named_tau arg + = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) + -- The mkSpecForAllTys is important (Trac #14552), albeit + -- slightly artifical (there is no variable with this funny type). + -- We do not want to quantify over variable (alpha::k) + -- that mention the existentially-bound type variables + -- ex_tvs in its kind k. + -- See Note [Type variables whose kind is captured] + + ; (univ_tvs, req_dicts, ev_binds, residual, _) <- simplifyInfer tclvl NoRestrictions [] named_taus wanted ; top_ev_binds <- checkNoErrs (simplifyTop residual) ; addTopEvBinds top_ev_binds $ - do { let (ex_tvs, prov_dicts) = tcCollectEx lpat' - ex_tv_set = mkVarSet ex_tvs - univ_tvs = filterOut (`elemVarSet` ex_tv_set) qtvs - req_theta = map evVarPred req_dicts - - ; prov_dicts <- mapM zonkId prov_dicts + do { prov_dicts <- mapM zonkId prov_dicts ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts -- Filtering: see Note [Remove redundant provided dicts] (prov_theta, prov_evs) = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) + req_theta = map evVarPred req_dicts -- Report coercions that esacpe -- See Note [Coercions that escape] @@ -226,7 +232,37 @@ dependentArgErr (arg, bad_cos) where bad_co_list = dVarSetElems bad_cos -{- Note [Remove redundant provided dicts] +{- Note [Type variables whose kind is captured] +~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data AST a = Sym [a] + class Prj s where { prj :: [a] -> Maybe (s a) + pattern P x <= Sym (prj -> Just x) + +Here we get a matcher with this type + $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r + +No problem. But note that 's' is not fixed by the type of the +pattern (AST a), nor is it existentially bound. It's really only +fixed by the type of the continuation. + +Trac #14552 showed that this can go wrong if the kind of 's' mentions +existentially bound variables. We obviously can't make a type like + $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) + -> r -> r +But neither is 's' itself existentially bound, so the forall (s::k->*) +can't go in the inner forall either. (What would the matcher apply +the continuation to?) + +Solution: do not quantiify over any unification variable whose kind +mentions the existentials. We can conveniently do that by making the +"taus" passed to simplifyInfer look like + forall ex_tvs. arg_ty + +After that, Note [Naughty quantification candidates] in TcMType takes +over, and zonks any such naughty variables to Any. + +Note [Remove redundant provided dicts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recall that HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index c65a3b9724..dfa61777ad 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -79,13 +79,14 @@ import TcRnExports import TcEvidence import qualified BooleanFormula as BF import PprTyThing( pprTyThingInContext ) -import Coercion( pprCoAxiom ) import CoreFVs( orphNamesOfFamInst ) import FamInst import InstEnv -import FamInstEnv +import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons + , famInstEnvElts, extendFamInstEnvList, normaliseType ) import TcAnnotations import TcBinds +import MkIface ( coAxiomToIfaceDecl ) import HeaderInfo ( mkPrelImports ) import TcDefaults import TcEnv @@ -1889,7 +1890,7 @@ However the GHCi debugger creates top-level bindings for Ids whose types have free RuntimeUnk skolem variables, standing for unknown types. If we don't register these free TyVars as global TyVars then the typechecker will try to quantify over them and fall over in -zonkQuantifiedTyVar. so we must add any free TyVars to the +skolemiseQuantifiedTyVar. so we must add any free TyVars to the typechecker's global TyVar set. That is most conveniently by using tcExtendLocalTypeEnv, which automatically extends the global TyVar set. @@ -2731,7 +2732,7 @@ ppr_types debug type_env ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc ppr_tycons debug fam_insts type_env = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons - , ppr_things "COERCION AXIOMS" pprCoAxiom + , ppr_things "COERCION AXIOMS" ppr_ax (typeEnvCoAxioms type_env) ] where fi_tycons = famInstsRepTyCons fam_insts @@ -2747,7 +2748,7 @@ ppr_tycons debug fam_insts type_env = vcat [ ppWhen show_roles $ hang (text "type role" <+> ppr tc) 2 (hsep (map ppr roles)) - , hang (ppr tc <+> dcolon) + , hang (ppr tc <> braces (ppr (tyConArity tc)) <+> dcolon) 2 (ppr (tidyTopType (tyConKind tc))) ] where show_roles = debug || not (all (== boring_role) roles) @@ -2756,6 +2757,8 @@ ppr_tycons debug fam_insts type_env | otherwise = Representational -- Matches the choice in IfaceSyn, calls to pprRoles + ppr_ax ax = ppr (coAxiomToIfaceDecl ax) + ppr_datacons :: Bool -> TypeEnv -> SDoc ppr_datacons debug type_env = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 667d8664a3..fe769a9d1e 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -1542,21 +1542,23 @@ pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside = do { env <- getLclEnv ; let tclvl' = pushTcLevel (tcl_tclvl env) + ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ captureConstraints thing_inside + ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') ; return (tclvl', lie, res) } pushTcLevelM_ :: TcM a -> TcM a pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x -pushTcLevelM :: TcM a -> TcM (a, TcLevel) +pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in TcType pushTcLevelM thing_inside = do { env <- getLclEnv ; let tclvl' = pushTcLevel (tcl_tclvl env) ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) thing_inside - ; return (res, tclvl') } + ; return (tclvl', res) } -- Returns pushed TcLevel pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 04f17ccdca..ad3122badc 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1984,8 +1984,12 @@ tyCoFVsOfImplic :: Implication -> FV tyCoFVsOfImplic (Implic { ic_skols = skols , ic_given = givens , ic_wanted = wanted }) - = FV.delFVs (mkVarSet skols `unionVarSet` mkVarSet givens) - (tyCoFVsOfWC wanted `unionFV` tyCoFVsOfTypes (map evVarPred givens)) + | isEmptyWC wanted + = emptyFV + | otherwise + = tyCoFVsVarBndrs skols $ + tyCoFVsVarBndrs givens $ + tyCoFVsOfWC wanted tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV @@ -3507,8 +3511,10 @@ data CtOrigin | NegateOrigin -- Occurrence of syntactic negation | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc + | AssocFamPatOrigin -- When matching the patterns of an associated + -- family instance with that of its parent class | SectionOrigin - | TupleOrigin -- (..,..) + | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty | PatOrigin -- Instantiating a polytyped pattern at a constructor @@ -3726,6 +3732,9 @@ pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) = hang (ctoHerald <+> text "a kind equality arising from") 2 (sep [ppr t1, char '~', ppr t2]) +pprCtOrigin AssocFamPatOrigin + = text "when matching a family LHS with its class instance head" + pprCtOrigin (KindEqOrigin t1 Nothing _ _) = hang (ctoHerald <+> text "a kind equality when matching") 2 (ppr t1) @@ -3797,6 +3806,7 @@ pprCtO IfOrigin = text "an if expression" pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin = text "an operator section" +pprCtO AssocFamPatOrigin = text "the LHS of a famly instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 4bcd203a2b..2955704e56 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -83,11 +83,11 @@ tcRule (HsRule { rd_ext = ext do { traceTc "---- Rule ------" (pprFullRuleName rname) -- Note [Typechecking rules] - ; (stuff,_) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + ; (tc_lvl, stuff) <- pushTcLevelM $ + generateRuleConstraints ty_bndrs tm_bndrs lhs rhs ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty, tc_lvl) = stuff + , rhs', rhs_wanted, rule_ty) = stuff ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname , ppr lhs_wanted @@ -112,7 +112,7 @@ tcRule (HsRule { rd_ext = ext ; let tpl_ids = lhs_evs ++ id_bndrs ; gbls <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level -- monomorphic bindings from the MR; test tc111 - ; forall_tkvs <- candidateQTyVarsOfTypes gbls $ + ; forall_tkvs <- candidateQTyVarsOfTypes $ map (mkSpecForAllTys tv_bndrs) $ -- don't quantify over lexical tyvars rule_ty : map idType tpl_ids ; qtkvs <- quantifyTyVars gbls forall_tkvs @@ -152,40 +152,34 @@ generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] , [TcId] , LHsExpr GhcTc, WantedConstraints , LHsExpr GhcTc, WantedConstraints - , TcType - , TcLevel ) + , TcType ) generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs, lvl), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs + = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ + tcRuleBndrs ty_bndrs tm_bndrs -- bndr_wanted constraints can include wildcard hole -- constraints, which we should not forget about. -- It may mention the skolem type variables bound by -- the RULE. c.f. Trac #10072 - ; setTcLevel lvl $ - tcExtendTyVarEnv tv_bndrs $ + ; tcExtendTyVarEnv tv_bndrs $ tcExtendIdEnv id_bndrs $ do { -- See Note [Solve order for RULES] ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) ; (rhs', rhs_wanted) <- captureConstraints $ tcMonoExpr rhs (mkCheckExpType rule_ty) ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty, lvl) } } + ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } -- See Note [TcLevel in type checking rules] tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar],[Id],TcLevel) + -> TcM ([TcTyVar], [Id]) tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms,lvl)) <- tcExplicitTKBndrs - (ForAllSkol (pprHsExplicitForAll (Just bndrs))) - bndrs $ do { lvl <- getTcLevel - ; (tys,tms) <- tcRuleTmBndrs xs - ; return (tys,tms,lvl) } - ; return (tys1 ++ tys2, tms, lvl) } + = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ + tcRuleTmBndrs xs + ; return (tys1 ++ tys2, tms) } + tcRuleBndrs Nothing xs - = do { lvl <- getTcLevel - ; (tys,tms) <- tcRuleTmBndrs xs - ; return (tys,tms,lvl) } + = tcRuleTmBndrs xs -- See Note [TcLevel in type checking rules] tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index adcfdbe383..69f58b9002 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2868,7 +2868,7 @@ checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside) -- does not emit any work-list constraints new_tcs_env = tcs_env { tcs_worklist = wl_panic } - ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $ + ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $ thing_inside new_tcs_env ; unless (null wanteds) $ @@ -2908,7 +2908,7 @@ checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside) -- does not emit any work-list constraints new_tcs_env = tcs_env { tcs_worklist = wl_panic } - ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $ + ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $ thing_inside new_tcs_env ; ev_binds_var <- TcM.newTcEvBinds diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index f7a41e58bf..5925fc8975 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -42,8 +42,6 @@ import Type( mkTyVarBinders ) import DynFlags import Var ( TyVar, tyVarKind ) -import VarSet -import VarEnv ( mkInScopeSet ) import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName ) import BasicTypes @@ -311,7 +309,7 @@ equalites, rather than leaving them in the ambient constraints to be solved later. Pattern synonyms are top-level, so there's no problem with completely solving them. -(NB: this solveEqualities wraps tcImplicitTKBndrs, which itself +(NB: this solveEqualities wraps newImplicitTKBndrs, which itself does a solveLocalEqualities; so solveEqualities isn't going to make any further progress; it'll just report any unsolved ones, and fail, as it should.) @@ -327,11 +325,11 @@ tcPatSynSig name sig_ty , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty) ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) - <- solveEqualities $ - -- See Note [solveEqualities in tcPatSynSig] - tcImplicitTKBndrs skol_info implicit_hs_tvs $ - tcExplicitTKBndrs skol_info univ_hs_tvs $ - tcExplicitTKBndrs skol_info ex_hs_tvs $ + <- pushTcLevelM_ $ + solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] + bindImplicitTKBndrs_Skol implicit_hs_tvs $ + bindExplicitTKBndrs_Skol univ_hs_tvs $ + bindExplicitTKBndrs_Skol ex_hs_tvs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty @@ -349,7 +347,7 @@ tcPatSynSig name sig_ty -- These are /signatures/ so we zonk to squeeze out any kind -- unification variables. Do this after kindGeneralize which may -- default kind variables to *. - ; implicit_tvs <- mapM zonkTyCoVarKind implicit_tvs + ; implicit_tvs <- zonkAndScopedSort implicit_tvs ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs ; req <- zonkTcTypes req @@ -359,6 +357,7 @@ tcPatSynSig name sig_ty -- Skolems have TcLevels too, though they're used only for debugging. -- If you don't do this, the debugging checks fail in TcPatSyn. -- Test case: patsyn/should_compile/T13441 +{- ; tclvl <- getTcLevel ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs @@ -367,6 +366,13 @@ tcPatSynSig name sig_ty req' = substTys env3 req prov' = substTys env3 prov body_ty' = substTy env3 body_ty +-} + ; let implicit_tvs' = implicit_tvs + univ_tvs' = univ_tvs + ex_tvs' = ex_tvs + req' = req + prov' = prov + body_ty' = body_ty -- Now do validity checking ; checkValidType ctxt $ @@ -395,7 +401,6 @@ tcPatSynSig name sig_ty , patsig_body_ty = body_ty' }) } where ctxt = PatSynCtxt name - skol_info = SigTypeSkol ctxt build_patsyn_type kvs imp univ req ex prov body = mkInvForAllTys kvs $ @@ -432,11 +437,12 @@ tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) , sig_inst_theta = theta , sig_inst_tau = tau }) } -tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) +tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty + , sig_ctxt = ctxt + , sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + do { traceTc "Staring partial sig {" (ppr hs_sig) + ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty -- Clone the quantified tyvars -- Reason: we might have f, g :: forall a. a -> _ -> a @@ -445,31 +451,18 @@ tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty -- the easiest way to do so, and is very similar to -- the tcInstType in the CompleteSig case -- See Trac #14643 - ; let in_scope = mkInScopeSet $ closeOverKinds $ unionVarSets - [ mkVarSet (map snd wcs) - , maybe emptyVarSet tyCoVarsOfType wcx - , mkVarSet tvs - , tyCoVarsOfTypes theta - , tyCoVarsOfType tau ] - -- the in_scope is a bit bigger than nec'y, but too big is always - -- safe - empty_subst = mkEmptyTCvSubst in_scope - ; (subst, tvs') <- instSkolTyCoVarsX mk_sig_tv empty_subst tvs + ; (subst, tvs') <- newMetaTyVarTyVars tvs + -- Why newMetaTyVarTyVars? See TcBinds + -- Note [Quantified variables in partial type signatures] ; let tv_prs = tv_names `zip` tvs' - - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = substTys subst theta - , sig_inst_tau = substTy subst tau - }) } - where - mk_sig_tv old_name kind - = do { uniq <- newUnique - ; newTyVarTyVar (setNameUnique old_name uniq) kind } - -- Why newTyVarTyVar? See TcBinds - -- Note [Quantified variables in partial type signatures] + inst_sig = TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = wcs + , sig_inst_wcx = wcx + , sig_inst_theta = substTys subst theta + , sig_inst_tau = substTy subst tau } + ; traceTc "End partial sig }" (ppr inst_sig) + ; return inst_sig } {- Note [Pattern bindings and complete signatures] diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 6ef62c80a8..ac283fad7c 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -7,7 +7,7 @@ module TcSimplify( simplifyDefault, simplifyTop, simplifyTopImplic, simplifyInteractive, - solveEqualities, solveLocalEqualities, + solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, simplifyWantedsTcM, tcCheckSatisfiability, tcNormalise, @@ -121,9 +121,7 @@ simplifyTop wanteds ; return (final_wc, unsafe_ol) } ; traceTc "End simplifyTop }" empty - ; traceTc "reportUnsolved {" empty ; binds2 <- reportUnsolved final_wc - ; traceTc "reportUnsolved }" empty ; traceTc "reportUnsolved (unsafe overlapping) {" empty ; unless (isEmptyCts unsafe_ol) $ do { @@ -145,24 +143,30 @@ simplifyTop wanteds ; return (evBindMapBinds binds1 `unionBags` binds2) } + -- | Type-check a thing that emits only equality constraints, solving any -- constraints we can and re-emitting constraints that we can't. The thing_inside -- should generally bump the TcLevel to make sure that this run of the solver -- doesn't affect anything lying around. -solveLocalEqualities :: TcM a -> TcM a -solveLocalEqualities thing_inside - = do { traceTc "solveLocalEqualities {" empty +solveLocalEqualities :: String -> TcM a -> TcM a +solveLocalEqualities callsite thing_inside + = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside + ; emitConstraints wanted + ; return res } + +solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) +solveLocalEqualitiesX callsite thing_inside + = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) ; (result, wanted) <- captureConstraints thing_inside - ; traceTc "solveLocalEqualities: running solver {" (ppr wanted) - ; reduced_wanted <- runTcSEqualities (solveWanteds wanted) - ; traceTc "solveLocalEqualities: running solver }" (ppr reduced_wanted) + ; traceTc "solveLocalEqualities: running solver" (ppr wanted) + ; residual_wanted <- runTcSEqualities (solveWanteds wanted) - ; emitConstraints reduced_wanted + ; traceTc "solveLocalEqualitiesX end }" $ + text "residual_wanted =" <+> ppr residual_wanted - ; traceTc "solveLocalEqualities end }" empty - ; return result } + ; return (residual_wanted, result) } -- | Type-check a thing that emits only equality constraints, then -- solve those constraints. Fails outright if there is trouble. @@ -171,16 +175,18 @@ solveLocalEqualities thing_inside solveEqualities :: TcM a -> TcM a solveEqualities thing_inside = checkNoErrs $ -- See Note [Fail fast on kind errors] - do { (result, wanted) <- captureConstraints thing_inside - ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted + do { lvl <- TcM.getTcLevel + ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) + + ; (result, wanted) <- captureConstraints thing_inside + + ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted ; final_wc <- runTcSEqualities $ simpl_top wanted -- NB: Use simpl_top here so that we potentially default RuntimeRep -- vars to LiftedRep. This is needed to avoid #14991. - ; traceTc "End solveEqualities }" empty - ; traceTc "reportAllUnsolved {" empty + ; traceTc "End solveEqualities }" empty ; reportAllUnsolved final_wc - ; traceTc "reportAllUnsolved }" empty ; return result } -- | Simplify top-level constraints, but without reporting any unsolved @@ -514,9 +520,7 @@ simplifyDefault theta = do { traceTc "simplifyDefault" empty ; wanteds <- newWanteds DefaultOrigin theta ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; traceTc "reportUnsolved {" empty ; reportAllUnsolved unsolved - ; traceTc "reportUnsolved }" empty ; return () } ------------------ @@ -674,7 +678,7 @@ simplifyInfer :: TcLevel -- Used when generating the constraints simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyCoVars - ; dep_vars <- candidateQTyVarsOfTypes gbl_tvs (map snd name_taus) + ; dep_vars <- candidateQTyVarsOfTypes (map snd name_taus) ; qtkvs <- quantifyTyVars gbl_tvs dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } @@ -1084,7 +1088,7 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates -- Default any kind/levity vars ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes mono_tvs candidates + <- candidateQTyVarsOfTypes candidates -- any covars should already be handled by -- the logic in decideMonoTyVars, which looks at -- the constraints generated @@ -1154,15 +1158,18 @@ decideQuantifiedTyVars mono_tvs name_taus psigs candidates -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces -- them in that order, so that the final qtvs quantifies in the same -- order as the partial signatures do (Trac #13524) - ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes mono_tvs $ + ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ psig_tys ++ candidates ++ tau_tys ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } ; traceTc "decideQuantifiedTyVars" (vcat - [ text "seed_tys =" <+> ppr seed_tys + [ text "candidates =" <+> ppr candidates + , text "tau_tys =" <+> ppr tau_tys + , text "seed_tys =" <+> ppr seed_tys , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) - , text "grown_tcvs =" <+> ppr grown_tcvs]) + , text "grown_tcvs =" <+> ppr grown_tcvs + , text "dvs =" <+> ppr dvs_plus]) ; quantifyTyVars mono_tvs dvs_plus } @@ -2003,9 +2010,10 @@ promoteTyVarTcS tv defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv | isRuntimeRepVar the_tv - , not (isTyVarTyVar the_tv) -- TyVarTvs should only be unified with a tyvar - -- never with a type; c.f. TcMType.defaultTyVar - -- See Note [Kind generalisation and TyVarTvs] + , not (isTyVarTyVar the_tv) + -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in TcTyClsDecls = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) ; unifyTyVar the_tv liftedRepTy ; return True } @@ -2139,7 +2147,7 @@ approximateWC to produce a list of candidate constraints. Then we MUST To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over +(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. Trac #7641 is a simpler example. diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index b3cf4d97c5..d3e146434f 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -46,6 +46,7 @@ import SrcLoc import THNames import TcUnify import TcEnv +import Coercion( etaExpandCoAxBranch ) import FileCleanup ( newTempName, TempFileLifetime(..) ) import Control.Monad @@ -1189,8 +1190,9 @@ reifyInstances th_nm th_tys do { (rn_ty, fvs) <- rnLHsType doc rdr_ty ; return ((tv_names, rn_ty), fvs) } ; (_tvs, ty) - <- failIfEmitsConstraints $ -- avoid error cascade if there are unsolved - tcImplicitTKBndrs ReifySkol tv_names $ + <- pushTcLevelM_ $ + solveEqualities $ -- Avoid error cascade if there are unsolved + bindImplicitTKBndrs_Skol tv_names $ fst <$> tcLHsType rn_ty ; ty <- zonkTcTypeToType ty -- Substitute out the meta type variables @@ -1692,15 +1694,16 @@ reifyFamilyInstances fam_tc fam_insts reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded -- includes only *visible* tvs -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor - , fi_fam = fam - , fi_tvs = fam_tvs - , fi_tys = lhs - , fi_rhs = rhs }) +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_axiom = ax + , fi_fam = fam }) + | let fam_tc = coAxiomTyCon ax + branch = coAxiomSingleBranch ax + , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch = case flavor of SynFamilyInst -> -- remove kind patterns (#8884) - do { th_tvs <- reifyTyVarsToMaybe fam_tvs + do { th_tvs <- reifyTyVarsToMaybe tvs ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs ; th_lhs <- reifyTypes lhs_types_only ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only @@ -1713,10 +1716,10 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor do { let -- eta-expand lhs types, because sometimes data/newtype -- instances are eta-reduced; See Trac #9692 -- See Note [Eta reduction for data families] in FamInstEnv - (ee_tvs, ee_lhs, _) = etaExpandFamInst fam_tvs lhs rhs - fam' = reifyName fam - dataCons = tyConDataCons rep_tc - isGadt = isGadtSyntaxTyCon rep_tc + (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch + fam' = reifyName fam + dataCons = tyConDataCons rep_tc + isGadt = isGadtSyntaxTyCon rep_tc ; th_tvs <- reifyTyVarsToMaybe ee_tvs ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs @@ -1727,8 +1730,6 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) [] else TH.DataInstD [] fam' th_tvs annot_th_tys Nothing cons [] } - where - fam_tc = famInstTyCon inst ------------------------------ reifyType :: TyCoRep.Type -> TcM TH.Type diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8fbfc33895..c097d50ab3 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -15,10 +15,11 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations - kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, + kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - wrongKindOfFamily, dataConCtxt + unravelFamInstPats, + wrongKindOfFamily ) where #include "HsVersions.h" @@ -36,9 +37,9 @@ import TcTyDecls import TcClassDcl import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) import TcDeriv (DerivInfo) -import TcEvidence ( tcCoercionKind, isEmptyTcEvBinds ) -import TcUnify ( checkConstraints ) import TcHsType +import ClsInst( AssocInstInfo(..) ) +import Inst( tcInstTyBinders ) import TcMType import TysWiredIn ( unitTy ) import TcType @@ -64,7 +65,6 @@ import Outputable import Maybes import Unify import Util -import Pair import SrcLoc import ListSetOps import DynFlags @@ -380,8 +380,7 @@ TcTyCons are used for two distinct purposes Instead of trying, we just store the list of type variables to bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in kcTyClTyVars and - tcTyClTyVars, both in TcHsType. + These tyvars are brought into scope in TcHsType.bindTyClTyVars. In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather than just [TcTyVar]? Consider these mutually-recursive decls @@ -481,12 +480,11 @@ kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon] -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons -- See Note [Kind checking for type and class decls] --- Third return value is Nothing if the tycon be unsaturated; otherwise, --- the arity +-- and Note [Inferring kinds for type declarations] kcTyClGroup decls = do { mod <- getModule ; traceTc "---- kcTyClGroup ---- {" - (text "module" <+> ppr mod $$ vcat (map ppr decls)) + (text "module" <+> ppr mod $$ vcat (map ppr decls)) -- Kind checking; -- 1. Bind kind variables for decls @@ -494,33 +492,39 @@ kcTyClGroup decls -- 3. Generalise the inferred kinds -- See Note [Kind checking for type and class decls] - -- Step 1: Bind kind variables for all decls - ; initial_tcs <- getInitialKinds decls - ; traceTc "kcTyClGroup: initial kinds" $ - ppr_tc_kinds initial_tcs + ; let (cusk_decls, no_cusk_decls) + = partition (hsDeclHasCusk . unLoc) decls - -- Step 2: Set extended envt, kind-check the decls - -- NB: the environment extension overrides the tycon - -- promotion-errors bindings - -- See Note [Type environment evolution] + ; poly_cusk_tcs <- getInitialKinds True cusk_decls - ; solveEqualities $ - tcExtendKindEnvWithTyCons initial_tcs $ - mapM_ kcLTyClDecl decls + ; mono_tcs + <- tcExtendKindEnvWithTyCons poly_cusk_tcs $ + pushTcLevelM_ $ -- We are going to kind-generalise, so + -- unification variables in here must + -- be one level in + solveEqualities $ + do { -- Step 1: Bind kind variables for all decls + mono_tcs <- getInitialKinds False no_cusk_decls - -- Step 3: skolemisation - -- Kind checking done for this group - -- Now we have to kind skolemise the flexis - ; candidates <- gather_quant_candidates initial_tcs - ; _ <- quantifyTyVars emptyVarSet candidates - -- We'll get the actual vars to quantify over later. + ; traceTc "kcTyClGroup: initial kinds" $ + ppr_tc_kinds mono_tcs - -- Step 4: generalisation + -- Step 2: Set extended envt, kind-check the decls + -- NB: the environment extension overrides the tycon + -- promotion-errors bindings + -- See Note [Type environment evolution] + ; tcExtendKindEnvWithTyCons mono_tcs $ + mapM_ kcLTyClDecl no_cusk_decls + + ; return mono_tcs } + + -- Step 3: generalisation -- Finally, go through each tycon and give it its final kind, -- with all the required, specified, and inferred variables -- in order. - ; poly_tcs <- mapAndReportM generalise initial_tcs + ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs + ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) ; return poly_tcs } @@ -528,198 +532,215 @@ kcTyClGroup decls ppr_tc_kinds tcs = vcat (map pp_tc tcs) pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - gather_quant_candidates :: [TcTyCon] -> TcM CandidatesQTvs - gather_quant_candidates tcs = mconcat <$> mapM gather1 tcs +generaliseTcTyCon :: TcTyCon -> TcM TcTyCon +generaliseTcTyCon tc + -- See Note [Required, Specified, and Inferred for types] + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + do { let tc_name = tyConName tc + tc_flav = tyConFlavour tc + tc_res_kind = tyConResKind tc + tc_tvs = tyConTyVars tc + user_tyvars = tcTyConUserTyVars tc -- ToDo: nuke + + (scoped_tv_names, scoped_tvs) = unzip (tcTyConScopedTyVars tc) + -- NB: scoped_tvs includes both specified and required (tc_tvs) + -- ToDo: Is this a good idea? + + -- Step 1: find all the variables we want to quantify over, + -- including Inferred, Specfied, and Required + ; dvs <- candidateQTyVarsOfKinds $ + (tc_res_kind : map tyVarKind scoped_tvs) + ; tc_tvs <- mapM zonkTcTyVarToTyVar tc_tvs + ; let full_dvs = dvs { dv_tvs = mkDVarSet tc_tvs } + + -- Step 2: quantify, mainly meaning skolemise the free variables + ; qtkvs <- quantifyTyVars emptyVarSet full_dvs + -- Returned 'qtkvs' are scope-sorted and skolemised + + -- Step 3: find the final identity of the Specified and Required tc_tvs + -- (remember they all started as TyVarTvs). + -- They have been skolemised by quantifyTyVars. + ; scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs + ; tc_tvs <- mapM zonkTcTyVarToTyVar tc_tvs + ; tc_res_kind <- zonkTcType tc_res_kind + + ; traceTc "Generalise kind pre" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_tvs =" <+> pprTyVars tc_tvs + , text "scoped_tvs =" <+> pprTyVars scoped_tvs ] + + -- Step 4: Find the Specified and Inferred variables + -- First, delete the Required tc_tvs from qtkvs; then + -- partition by whether they are scoped (if so, Specified) + ; let qtkv_set = mkVarSet qtkvs + tc_tv_set = mkVarSet tc_tvs + specified = scopedSort $ + [ tv | tv <- scoped_tvs + , not (tv `elemVarSet` tc_tv_set) + , tv `elemVarSet` qtkv_set ] + -- NB: maintain the L-R order of scoped_tvs + spec_req_set = mkVarSet specified `unionVarSet` tc_tv_set + inferred = filterOut (`elemVarSet` spec_req_set) qtkvs + + -- Step 5: Make the TyConBinders. + dep_fv_set = candidateKindVars dvs + inferred_tcbs = mkNamedTyConBinders Inferred inferred + specified_tcbs = mkNamedTyConBinders Specified specified + required_tcbs = map (mkRequiredTyConBinder dep_fv_set) tc_tvs + + -- Step 6: Assemble the final list. + final_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + + scoped_tv_pairs = scoped_tv_names `zip` scoped_tvs + + -- Step 7: Make the result TcTyCon + tycon = mkTcTyCon tc_name user_tyvars final_tcbs tc_res_kind + scoped_tv_pairs + True {- it's generalised now -} + (tyConFlavour tc) + + ; traceTc "Generalise kind" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_tvs =" <+> pprTyVars tc_tvs + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "scoped_tvs =" <+> pprTyVars scoped_tvs + , text "inferred =" <+> pprTyVars inferred + , text "specified =" <+> pprTyVars specified + , text "required_tcbs =" <+> ppr required_tcbs + , text "final_tcbs =" <+> ppr final_tcbs ] + + -- Step 8: check for floating kind vars + -- See Note [Free-floating kind vars] + -- They are easily identified by the fact that they + -- have not been skolemised by quantifyTyVars + ; let floating_specified = filter isTyVarTyVar scoped_tvs + ; reportFloatingKvs tc_name tc_flav + scoped_tvs floating_specified + + -- Step 9: Check for duplicates + -- E.g. data SameKind (a::k) (b::k) + -- data T (a::k1) (b::k2) = MkT (SameKind a b) + -- Here k1 and k2 start as TyVarTvs, and get unified with each other + ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_tv_pairs) + + -- Step 10: Check for validity. + -- We do this here because we're about to put the tycon into + -- the environment, and we don't want anything malformed in the + -- environment. + ; checkValidTelescope tycon - gather1 :: TcTyCon -> TcM CandidatesQTvs - gather1 tc - | tcTyConIsPoly tc -- these don't need generalisation - = return mempty + ; return tycon } + where + report_sig_tv_err (n1, n2) + = setSrcSpan (getSrcSpan n2) $ + addErrTc (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) - | otherwise - = do { tc_binders <- zonkTyConBinders (tyConBinders tc) - ; tc_res_kind <- zonkTcType (tyConResKind tc) +{- Note [Required, Specified, and Inferred for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each forall'd type variable in a type or kind is one of - ; let tvs = mkDVarSet $ map binderVar tc_binders - kvs = tyCoVarsOfTypesDSet (tc_res_kind : map binderType tc_binders) - `minusDVarSet` tvs + * Required: an argument must be provided at every call site - ; return (mempty { dv_kvs = kvs, dv_tvs = tvs }) } + * Specified: the argument can be inferred at call sites, but + may be instantiated with visible type/kind application - generalise :: TcTyCon -> TcM TcTyCon - generalise tc - | tcTyConIsPoly tc - = return tc -- nothing to do here; we already have the final kind - -- This is just an optimization; generalising is a no-op + * Inferred: the must be inferred at call sites; it + is unavailable for use with visible type/kind application. - | otherwise - -- See Note [Required, Specified, and Inferred for types] - = do { -- Step 0: get the tyvars from the enclosing class (if any) - (all_class_tctvs, class_scoped_tvs) <- get_class_tvs tc - - -- Step 1: gather all the free variables - ; tc_tvs <- mapM zonkTcTyCoVarBndr (map binderVar (tyConBinders tc)) - ; tc_res_kind <- zonkTcType (tyConResKind tc) - ; scoped_tv_pairs <- zonkTyVarTyVarPairs (tcTyConScopedTyVars tc) - - ; let all_fvs = tyCoVarsOfTypesDSet (tc_res_kind : map tyVarKind tc_tvs) - scoped_tvs = map snd scoped_tv_pairs - - ; MASSERT( all ((== Required) . tyConBinderArgFlag) (tyConBinders tc) ) - - -- Step 2: Select out the Required arguments; that is, the tc_binders - ; let no_req_fvs = all_fvs `delDVarSetList` tc_tvs - - -- Step 3: partition remaining variables into class variables and - -- local variables (matters only for associated types) - (class_fvs, local_fvs) - = partitionDVarSet (`elemDVarSet` all_class_tctvs) no_req_fvs - - -- Step 4: For each set so far, use the set to select the scoped_tvs. - -- We take from the scoped_tvs to preserve order. These tvs will become - -- the Specified ones. - class_specified = filter (`elemDVarSet` class_fvs) class_scoped_tvs - local_specified = filter (`elemDVarSet` local_fvs) scoped_tvs - - -- Step 5: Order the specified variables by ScopedSort - -- See Note [ScopedSort] in Type - class_specified_sorted = scopedSort class_specified - local_specified_sorted = scopedSort local_specified - - -- Step 6: Remove the Specified ones from the fv sets. These are the - -- Inferred ones. - class_inferred_set = class_fvs `delDVarSetList` class_specified_sorted - local_inferred_set = local_fvs `delDVarSetList` local_specified_sorted - - class_inferred = dVarSetElemsWellScoped class_inferred_set - local_inferred = dVarSetElemsWellScoped local_inferred_set - - -- Step 7: Make the TyConBinders. - class_inferred_tcbs = mkNamedTyConBinders Inferred class_inferred - class_specified_tcbs = mkNamedTyConBinders Specified class_specified_sorted - local_inferred_tcbs = mkNamedTyConBinders Inferred local_inferred - local_specified_tcbs = mkNamedTyConBinders Specified local_specified_sorted - - mk_req_tcb tv - | tv `elemDVarSet` all_fvs = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder tv - - required_tcbs = map mk_req_tcb tc_tvs - - -- Step 8: Assemble the final list. - final_tcbs = concat [ class_inferred_tcbs - , class_specified_tcbs - , local_inferred_tcbs - , local_specified_tcbs - , required_tcbs ] - - -- Step 9: Check for validity. We do this here because we're about to - -- put the tycon into the environment, and we don't want anything malformed - -- in the environment. - ; let user_tyvars = tcTyConUserTyVars tc - ; setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - checkValidTelescope final_tcbs user_tyvars - - -- Step 10: Make the result TcTyCon - ; let name = tyConName tc - ; traceTc "Generalise kind" $ - vcat [ text "name =" <+> ppr name - , text "all_class_tctvs =" <+> ppr all_class_tctvs - , text "class_scoped_tvs =" <+> ppr class_scoped_tvs - , text "tc_tvs =" <+> ppr tc_tvs - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "scoped_tvs =" <+> ppr scoped_tvs - , text "class_inferred_tcbs =" <+> ppr class_inferred_tcbs - , text "class_specified_tcbs =" <+> ppr class_specified_tcbs - , text "local_inferred_tcbs =" <+> ppr local_inferred_tcbs - , text "local_specified_tcbs =" <+> ppr local_specified_tcbs - , text "required_tcbs =" <+> ppr required_tcbs ] - ; return $ mkTcTyCon name user_tyvars final_tcbs tc_res_kind scoped_tv_pairs - True {- it's generalised now -} (tyConFlavour tc) } - - get_class_tvs :: TcTyCon -> TcM (DTyCoVarSet, [TcTyVar]) - -- returns all tyConTyVars of the enclosing class, as well as its - -- scoped type variables. Both are zonked. - get_class_tvs at_tc - | Just class_tc <- tyConAssoc_maybe at_tc - = do { -- We can't just call tyConTyVars, because the enclosing class - -- hasn't been generalised yet - tc_binders <- zonkTyConBinders (tyConBinders class_tc) - ; tc_res_kind <- zonkTcType (tyConResKind class_tc) - ; scoped_tvs <- mapM zonkTcTyVarToTyVar (map snd (tcTyConScopedTyVars class_tc)) - - ; return ( tyCoVarsOfTypesDSet (tc_res_kind : map binderType tc_binders) - `extendDVarSetList` tyConTyVars class_tc - , scoped_tvs ) } +Why have Inferred at all? Because we just can't make user-facing +promises about the ordering of some variables. These might swizzle +around even between minor released. By forbidding visible type +application, we ensure users aren't caught unawares. - | otherwise - = return (emptyDVarSet, []) +Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. -{- Note [Required, Specified, and Inferred for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have some design choices in how we classify the tyvars bound -in a type declaration. (Here, I use "type" to refer to any TyClDecl.) -Much of the debate is memorialized in #15743. This Note documents -the final conclusion. - -First, a reminder: - * a Required argument is one that must be provided at every call site - * a Specified argument is one that can be inferred at call sites, but - may be instantiated with visible type application - * an Inferred argument is one that must be inferred at call sites; it - is unavailable for use with visible type application. - -Why have Inferred at all? Because we just can't make user-facing promises -about the ordering of some variables. These might swizzle around even between -minor released. By forbidding visible type application, we ensure users -aren't caught unawares. See also -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. - -When inferring the ordering of variables (that is, for those -variables that he user has not specified the order with an explicit `forall`) -we use the following order: - - 1. Inferred variables from an enclosing class (associated types only) - 2. Specified variables from an enclosing class (associated types only) - 3. Inferred variables not from an enclosing class - 4. Specified variables not from an enclosing class - 5. Required variables before a top-level :: - 6. All variables after a top-level :: +The question for this Note is this: + given a TyClDecl, how are its quantified type variables classified? +Much of the debate is memorialized in #15743. + +Here is our design choice. When inferring the ordering of variables +for a TyCl declaration (that is, for those variables that he user +has not specified the order with an explicit `forall`), we use the +following order: + + 1. Inferred variables + 2. Specified variables; in the left-to-right order in which + the user wrote them, modified by scopedSort (see below) + to put them in depdendency order. + 3. Required variables before a top-level :: + 4. All variables after a top-level :: If this ordering does not make a valid telescope, we reject the definition. -This idea is implemented in the generalise function within kcTyClGroup (for -declarations without CUSKs), and in kcLHsQTyVars (for declarations with -CUSKs). Note that neither definition worries about point (6) above, as this +Example: + data SameKind :: k -> k -> * + data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +For X: + - a, c, d, x are Required; they are explicitly listed by the user + as the positional arguments of Bad + - b is Specified; it appears explicitly in a kind signature + - k, the kind of a, is Inferred; it is not mentioned explicitly at all + +Putting variables in the order Inferred, Specified, Required +gives us this telescope: + Inferred: k + Specified: b : Proxy a + Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) + +But this order is ill-scoped, because b's kind mentions a, which occurs +after b in the telescope. So we reject Bad. + +Associated types +~~~~~~~~~~~~~~~~ +For associated types everything above is determined by the +associated-type declaration alone, ignoring the class header. +Here is an example (Trac #15592) + class C (a :: k) b where + type F (x :: b a) + +In the kind of C, 'k' is Specified. But what about F? +In the kind of F, + + * Should k be Inferred or Specified? It's Specified for C, + but not mentioned in F's declaration. + + * In which order should the Specified variables a and b occur? + It's clearly 'a' then 'b' in C's declaration, but the L-R ordering + in F's declaration is 'b' then 'a'. + +In both cases we make the choice by looking at F's declaration alone, +so it gets the kind + F :: forall {k}. forall b a. b a -> Type + +How it works +~~~~~~~~~~~~ +These design choices are implemented by two completely different code +paths for + + * Declarations with a compulete user-specified kind signature (CUSK) + Handed by the CUSK case of kcLHsQTyVars. + + * Declarations without a CUSK are handled by kcTyClDecl; see + Note [Inferring kinds for type declarations]. + +Note that neither code path worries about point (4) above, as this is nicely handled by not mangling the res_kind. (Mangling res_kinds is done -*after* all this stuff, in tcDataDefn's call to tcDataKindSig.) We can -easily tell Inferred apart from Specified by looking at the scoped tyvars; -Specified are always included there. - -One other small open question here: how to classify variables from an -enclosing class? Here is an example: - - class C (a :: k) where - type F a - -In the kind of F, should k be Inferred or Specified? Currently, we mark -it as Specified, as we can commit to an ordering, based on the ordering -of class variables in the enclosing class declaration. If k were not mentioned -in the class head, then it would be Inferred. The alternative to this -approach is to make the Inferred/Specified distinction locally, by just -looking at the declaration for F. This lowers the availability of type -application, but makes the reasoning more local. However, this alternative -also disagrees with the treatment for methods, where all class variables -are Specified, regardless of whether or not the variable is mentioned in the -method type. - -A few points of motivation for the ordering above: - -* We put the class variables before the local variables in a nod to the - treatment for class methods, where class variables (and the class constraint) - come first. While this is an unforced design decision, it never rejects - more declarations, as class variables can never depend on local variables. +*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) + +We can tell Inferred apart from Specified by looking at the scoped +tyvars; Specified are always included there. + +Design alternatives +~~~~~~~~~~~~~~~~~~~ + +* For associated types we considered putting the class variables + before the local variables, in a nod to the treatment for class + methods. But it got too compilicated; see Trac #15592, comment:21ff. * We rigidly require the ordering above, even though we could be much more permissive. Relevant musings are at @@ -736,11 +757,94 @@ A few points of motivation for the ordering above: we can be sure that inference wouldn't change between versions. However, would users be able to predict it? That I cannot answer. -Test cases (and tickets) relevant to these design decisions: +Test cases (and tickets) relevant to these design decisions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T15591* T15592* T15743* +Note [Inferring kinds for type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note deals with /inference/ for type declarations +that do not have a CUSK. Consider + data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) + data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) + +We do kind inference as follows: + +* Step 1: Assign initial monomorophic kinds to S, T + S :: kk1 -> * -> kk2 -> * + T :: kk3 -> * -> kk4 -> * + Here kk1 etc are TyVarTvs: that is, unification variables that + are allowed to unify only with other type variables. See + Note [Signature skolems] in TcType + +* Step 2: Extend the environment with a TcTyCon for S and T, with + these monomophic kinds. Now kind-check the declarations, and solve + the resulting equalities. The goal here is to discover constraints + on all these unification variables. + + Here we find that kk1 := kk3, and kk2 := kk4. + + This is why we can't use skolems for kk1 etc; they have to + unify with each other. + +* Step 3. Generalise each TyCon in turn (generaliseTcTyCon). + We find the free variables of the kind, skolemise them, + sort them out into Inferred/Required/Specified (see the above + Note [Required, Specified, and Inferred for types]), + and perform some validity checks. + + This makes the utterly-final TyConBinders for the TyCon + + All this is very similar at the level of terms: see TcBinds + Note [Quantified variables in partial type signatures] + +* Step 4. Extend the type environment with a TcTyCon for S and T, now + with their utterly-final polymorphic kinds (needed for recursive + occurrences of S, T). Now typecheck the declarations, and build the + final AlgTyCOn for S and T resp. + +The first three steps are in kcTyClGroup; +the fourth is in tcTyClDecls. + +There are some wrinkles + +* Do not default TyVarTvs. We always want to kind-generalise over + TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is + not allowed to unify with a type; it must stand for a type + variable. Hence the check in TcSimplify.defaultTyVarTcS, and + TcMType.defaultTyVar. Here's another example (Trac #14555): + data Exp :: [TYPE rep] -> TYPE rep -> Type where + Lam :: Exp (a:xs) b -> Exp xs (a -> b) + We want to kind-generalise over the 'rep' variable. + Trac #14563 is another example. + +* Duplicate type variables. Consider Trac #11203 + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + Here we will unify k1 with k2, but this time doing so is an error, + because k1 and k2 are bound in the same declaration. + + We spot this during validity checking (findDupTyVarTvs), + in generaliseTcTyCon. + +* Required arguments. Even the Required arguments should be made + into TyVarTvs, not skolems. Consider + data T k (a :: k) + Here, k is a Required, dependent variable. For uniformity, it is helpful + to have k be a TyVarTv, in parallel with other dependent variables. + +* Duplicate skolemisation is expected. When generalising in Step 3, + we may find that one of the variables we want to quantify has + already been skolemised. For example, suppose we have already + generalise S. When we come to T we'll find that kk1 (now the same as + kk3) has already been skolemised. + + That's fine -- but it means that + a) when collecting quantification candidates, in + candidateQTyVarsOfKind, we must collect skolems + b) quantifyTyVars should be a no-op on such a skolem -} -------------- @@ -779,13 +883,17 @@ mk_prom_err_env decl -- Works for family declarations too -------------- -getInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] +getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind -getInitialKinds decls = concatMapM (addLocM getInitialKind) decls +getInitialKinds cusk decls + = do { traceTc "getInitialKinds {" empty + ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls + ; traceTc "getInitialKinds done }" empty + ; return tcs } -getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon] +getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon] -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return a TcTyCon with kind k -- where k is the kind of tc, derived from the LHS @@ -800,11 +908,11 @@ getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon] -- -- No family instances are passed to getInitialKinds -getInitialKind decl@(ClassDecl { tcdLName = (dL->L _ name) - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { let cusk = hsDeclHasCusk decl - ; tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $ +getInitialKind cusk + (ClassDecl { tcdLName = dL->L _ name + , tcdTyVars = ktvs + , tcdATs = ats }) + = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $ return constraintKind ; let parent_tv_prs = tcTyConScopedTyVars tycon -- See Note [Don't process associated types in kcLHsQTyVars] @@ -812,30 +920,29 @@ getInitialKind decl@(ClassDecl { tcdLName = (dL->L _ name) getFamDeclInitialKinds (Just tycon) ats ; return (tycon : inner_tcs) } -getInitialKind decl@(DataDecl { tcdLName = (dL->L _ name) - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { tycon <- - kcLHsQTyVars name (newOrDataToFlavour new_or_data) - (hsDeclHasCusk decl) ktvs $ - case m_sig of - Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig - Nothing -> return liftedTypeKind - ; return [tycon] } - -getInitialKind (FamDecl { tcdFam = decl }) +getInitialKind cusk + (DataDecl { tcdLName = dL->L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig + , dd_ND = new_or_data } }) + = do { let flav = newOrDataToFlavour new_or_data + ; tc <- kcLHsQTyVars name flav cusk ktvs $ + case m_sig of + Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig + Nothing -> return liftedTypeKind + ; return [tc] } + +getInitialKind _ (FamDecl { tcdFam = decl }) = do { tc <- getFamDeclInitialKind Nothing decl ; return [tc] } -getInitialKind decl@(SynDecl { tcdLName = (dL->L _ name) +getInitialKind cusk (SynDecl { tcdLName = dL->L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) - = do { tycon <- kcLHsQTyVars name TypeSynonymFlavour (hsDeclHasCusk decl) - ktvs $ - case kind_annotation rhs of - Nothing -> newMetaKindVar - Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig + = do { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $ + case kind_annotation rhs of + Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig + Nothing -> newMetaKindVar ; return [tycon] } where -- Keep this synchronized with 'hsDeclHasCusk'. @@ -844,8 +951,8 @@ getInitialKind decl@(SynDecl { tcdLName = (dL->L _ name) HsKindSig _ _ k -> Just k _ -> Nothing -getInitialKind (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind" -getInitialKind (XTyClDecl _) = panic "getInitialKind" +getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind" +getInitialKind _ (XTyClDecl _) = panic "getInitialKind" --------------------------------- getFamDeclInitialKinds @@ -888,10 +995,6 @@ getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind" kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] kcLTyClDecl (dL->L loc decl) - | hsDeclHasCusk decl -- See Note [Skip decls with CUSKs in kcLTyClDecl] - = traceTc "kcTyClDecl skipped due to cusk:" (ppr tc_name) - - | otherwise = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "kcTyClDecl {" (ppr tc_name) @@ -919,27 +1022,24 @@ kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn - = kcTyClTyVars name $ + = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM_ kcConDecl) cons } -kcTyClDecl (SynDecl { tcdLName = (dL->L _ name) - , tcdRhs = lrhs }) - = kcTyClTyVars name $ - do { syn_tc <- kcLookupTcTyCon name +kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs }) + = bindTyClTyVars name $ \ _ res_kind -> + discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in getInitialKinds. - ; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) } kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) , tcdCtxt = ctxt, tcdSigs = sigs }) - = kcTyClTyVars name $ + = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } + ; mapM_ (wrapLocM_ kc_sig) sigs } where - kc_sig (ClassOpSig _ _ nms op_ty) - = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty - kc_sig _ = return () + kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty + kc_sig _ = return () kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) , fdInfo = fd_info })) @@ -959,10 +1059,13 @@ kcConDecl :: ConDecl GhcRn -> TcM () kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = ex_ctxt, con_args = args }) = addErrCtxt (dataConCtxtName [name]) $ - -- See Note [Use TyVarTvs in kind-checking pass] - kcExplicitTKBndrs ex_tvs $ + discardResult $ + bindExplicitTKBndrs_Skol ex_tvs $ do { _ <- tcHsMbContext ex_ctxt - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) } + ; traceTc "kcConDecl {" (ppr name $$ ppr args) + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) + ; traceTc "kcConDecl }" (ppr name) + } -- We don't need to check the telescope here, because that's -- done in tcConDecl @@ -980,8 +1083,9 @@ kcConDecl (ConDeclGADT { con_names = names -- for the type constructor T addErrCtxt (dataConCtxtName names) $ discardResult $ - kcImplicitTKBndrs implicit_tkv_nms $ - kcExplicitTKBndrs explicit_tkv_nms $ + bindImplicitTKBndrs_Tv implicit_tkv_nms $ + bindExplicitTKBndrs_Tv explicit_tkv_nms $ + -- Why "_Tv"? See Note [Kind-checking for GADTs] do { _ <- tcHsMbContext cxt ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) ; _ <- tcHsOpenType res_ty @@ -1006,8 +1110,8 @@ mappings: APromotionErr is only used for DataCons, and only used during type checking in tcTyClGroup. -Note [Use TyVarTvs in kind-checking pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Kind-checking for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data Proxy a where @@ -1159,7 +1263,7 @@ tcTyClDecl1 _parent roles_info (SynDecl { tcdLName = (dL->L _ tc_name) , tcdRhs = rhs }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ binders res_kind -> + bindTyClTyVars tc_name $ \ binders res_kind -> tcTySynRhs roles_info tc_name binders res_kind rhs -- "data/newtype" declaration @@ -1167,7 +1271,7 @@ tcTyClDecl1 _parent roles_info (DataDecl { tcdLName = (dL->L _ tc_name) , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ tycon_binders res_kind -> + bindTyClTyVars tc_name $ \ tycon_binders res_kind -> tcDataDefn roles_info tc_name tycon_binders res_kind defn tcTyClDecl1 _parent roles_info @@ -1199,7 +1303,7 @@ tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs - tcTyClTyVars class_name $ \ binders res_kind -> + bindTyClTyVars class_name $ \ binders res_kind -> do { MASSERT2( tcIsConstraintKind res_kind , ppr class_name $$ ppr res_kind ) ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) @@ -1207,7 +1311,8 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs roles = roles_info tycon_name -- for TyCon and Class ; (ctxt, fds, sig_stuff, at_stuff) - <- solveEqualities $ + <- pushTcLevelM_ $ + solveEqualities $ do { ctxt <- tcHsContext hs_ctxt ; fds <- mapM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths @@ -1302,9 +1407,9 @@ tcDefaultAssocDecl _ (d1:_:_) = failWithTc (text "More than one default declaration for" <+> ppr (feqn_tycon (unLoc d1))) -tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = (dL->L _ tc_name) +tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name , feqn_pats = hs_tvs - , feqn_rhs = rhs })] + , feqn_rhs = hs_rhs_ty })] | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars} , hsq_explicit = exp_vars } <- hs_tvs = -- See Note [Type-checking default assoc decls] @@ -1323,32 +1428,23 @@ tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = (dL->L _ tc_name) (wrongNumberOfParmsErr fam_arity) -- Typecheck RHS - ; let all_vars = imp_vars ++ map hsLTyVarName exp_vars - pats = map hsLTyVarBndrToType exp_vars + ; let hs_pats = map hsLTyVarBndrToType exp_vars - -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get + -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get -- the LHsQTyVars used for declaring a tycon, but the names here -- are different. - -- You might think we should pass in some ClsInstInfo, as we're looking + -- You might think we should pass in some AssocInstInfo, as we're looking -- at an associated type. But this would be wrong, because an associated -- type default LHS can mention *different* type variables than the -- enclosing class. So it's treated more as a freestanding beast. - ; (pats', rhs_ty) - <- tcFamTyPats fam_tc Nothing all_vars Nothing pats - (kcTyFamEqnRhs Nothing rhs) $ - \tvs pats rhs_kind -> - do { rhs_ty <- solveEqualities $ - tcCheckLHsType rhs rhs_kind - - -- Zonk the patterns etc into the Type world - ; (ze, _) <- zonkTyBndrs tvs - ; pats' <- zonkTcTypesToTypesX ze pats - ; rhs_ty' <- zonkTcTypeToTypeX ze rhs_ty - ; return (pats', rhs_ty') } + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated + imp_vars exp_vars + hs_pats hs_rhs_ty -- See Note [Type-checking default assoc decls] - ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of + ; traceTc "tcDefault" (vcat [ppr (tyConTyVars fam_tc), ppr qtvs, ppr pats]) + ; case tcMatchTys pats (mkTyVarTys (tyConTyVars fam_tc)) of Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) ) Nothing -> failWithTc (defaultAssocKindErr fam_tc) -- We check for well-formedness and validity later, @@ -1403,28 +1499,33 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info , fdTyVars = user_tyvars , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = tcTyClTyVars tc_name $ \ binders res_kind -> do + = bindTyClTyVars tc_name $ \ binders res_kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name - -- Check the kind signature, if any. - -- Data families might have a variable return kind. - -- See See Note [Arity of data families] in FamInstEnv. - ; (extra_binders, final_res_kind) <- tcDataKindSig binders res_kind + -- Check that the result kind is OK + -- We allow things like + -- data family T (a :: Type) :: forall k. k -> Type + -- We treat T as having arity 1, but result kind forall k. k -> Type + -- But we want to check that the result kind finishes in + -- Type or a kind-variable + -- For the latter, consider + -- data family D a :: forall k. Type -> k + ; let (_, final_res_kind) = splitPiTys res_kind ; checkTc (tcIsLiftedTypeKind final_res_kind || isJust (tcGetCastedTyVar_maybe final_res_kind)) (badKindSig False res_kind) ; tc_rep_name <- newTyConRepName tc_name - ; let tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders) - final_res_kind + ; let tycon = mkFamilyTyCon tc_name binders + res_kind (resultVariableName sig) (DataFamilyTyCon tc_rep_name) parent NotInjective ; return tycon } | OpenTypeFamily <- fam_info - = tcTyClTyVars tc_name $ \ binders res_kind -> do + = bindTyClTyVars tc_name $ \ binders res_kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name ; inj' <- tcInjectivity binders inj @@ -1440,8 +1541,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info -- the variables in the header scope only over the injectivity -- declaration but this is not involved here ; (inj', binders, res_kind) - <- tcTyClTyVars tc_name - $ \ binders res_kind -> + <- bindTyClTyVars tc_name $ \ binders res_kind -> do { inj' <- tcInjectivity binders inj ; return (inj', binders, res_kind) } @@ -1462,7 +1562,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info [] False {- this doesn't matter here -} ClosedTypeFamilyFlavour - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc Nothing) eqns + ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns -- Do not attempt to drop equations dominated by earlier -- ones here; in the case of mutual recursion with a data -- type, we get a knot-tying failure. Instead we check @@ -1539,7 +1639,9 @@ tcTySynRhs :: RolesInfo tcTySynRhs roles_info tc_name binders res_kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind + ; rhs_ty <- pushTcLevelM_ $ + solveEqualities $ + tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType rhs_ty ; let roles = roles_info tc_name tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty @@ -1551,19 +1653,21 @@ tcDataDefn :: RolesInfo -> Name -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn roles_info tc_name tycon_binders res_kind - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt, dd_kindSig = mb_ksig - , dd_cons = cons }) - = do { tcg_env <- getGblEnv + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt + , dd_kindSig = mb_ksig -- Already in tc's kind + -- via getInitialKinds + , dd_cons = cons }) + = do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons + + ; tcg_env <- getGblEnv + ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind + ; let hsc_src = tcg_src tcg_env - ; (extra_bndrs, final_res_kind) <- tcDataKindSig tycon_binders res_kind ; unless (mk_permissive_kind hsc_src cons) $ checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind) - ; let final_bndrs = tycon_binders `chkAppend` extra_bndrs - roles = roles_info tc_name - - ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt + ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta ; kind_signatures <- xoptM LangExt.KindSignatures @@ -1571,10 +1675,11 @@ tcDataDefn roles_info ; when (isJust mb_ksig) $ checkTc (kind_signatures) (badSigTyDecl tc_name) - ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons - ; tycon <- fixM $ \ tycon -> do - { let res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) + { let final_bndrs = tycon_binders `chkAppend` extra_bndrs + res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) + roles = roles_info tc_name + ; data_cons <- tcConDecls tycon final_bndrs res_ty cons ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name @@ -1613,158 +1718,78 @@ tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn" ------------------------- 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 - (dL->L loc - (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = (dL->L _ eqn_tc_name) - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = pats - , feqn_rhs = hs_ty }})) + (dL->L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name + , feqn_bndrs = mb_expl_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 "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_pats =" <+> ppr pats ]) + , text "feqn_pats =" <+> ppr hs_pats ]) ; checkTc (fam_name == eqn_tc_name) (wrongTyFamName fam_name eqn_tc_name) -- this check reports an arity error instead of a kind error; easier for user - ; checkTc (pats `lengthIs` vis_arity) $ + ; checkTc (hs_pats `lengthIs` vis_arity) $ wrongNumberOfParmsErr vis_arity - ; kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs pats $ \ rhs_kind -> - discardResult $ kcTyFamEqnRhs Nothing hs_ty rhs_kind } + ; discardResult $ + bindImplicitTKBndrs_Q_Tv imp_vars $ + bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ + do { (_, res_kind) <- tcFamTyPats tc_fam_tc NotAssociated hs_pats + ; tcCheckLHsType hs_rhs_ty res_kind } + -- Why "_Tv" here? Consider (Trac #14066 + -- type family Bar x y where + -- Bar (x :: a) (y :: b) = Int + -- Bar (x :: c) (y :: d) = Bool + -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately + } where - fam_name = tyConName tc_fam_tc + fam_name = tyConName tc_fam_tc vis_arity = length (tyConVisibleTyVars tc_fam_tc) + kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn" kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn" kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 --- Infer the kind of the type on the RHS of a type family eqn. Then use --- this kind to check the kind of the LHS of the equation. This is useful --- as the callback to tcFamTyPats. -kcTyFamEqnRhs :: Maybe ClsInstInfo - -> LHsType GhcRn -- ^ Eqn RHS - -> TcKind -- ^ Inferred kind of left-hand side - -> TcM ([TcTyVar], [TcType], TcKind) - -- ^ New pattern skolems, New pats, inst'ed kind of left-hand side -kcTyFamEqnRhs mb_clsinfo rhs_hs_ty lhs_ki - = do { -- It's still possible the lhs_ki has some foralls. Instantiate these away. - (new_pats, insted_lhs_ki) - <- instantiateTyUntilN mb_kind_env 0 lhs_ki - - ; traceTc "kcTyFamEqnRhs" (vcat - [ text "rhs_hs_ty =" <+> ppr rhs_hs_ty - , text "lhs_ki =" <+> ppr lhs_ki - , text "insted_lhs_ki =" <+> ppr insted_lhs_ki - , text "new_pats =" <+> ppr new_pats - ]) - - ; _ <- tcCheckLHsType rhs_hs_ty insted_lhs_ki - - ; return ([], new_pats, insted_lhs_ki) } - -- we never introduce new skolems here - where - mb_kind_env = thdOf3 <$> mb_clsinfo -tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn +-------------------------- +tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn -> TcM (KnotTied CoAxBranch) -- Needs to be here, not in TcInstDcls, because closed families -- (typechecked here) have TyFamInstEqns + tcTyFamInstEqn fam_tc mb_clsinfo (dL->L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = (dL->L _ eqn_tc_name) - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = pats - , feqn_rhs = hs_ty }})) + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) = ASSERT( getName fam_tc == eqn_tc_name ) setSrcSpan loc $ - tcFamTyPats fam_tc mb_clsinfo imp_vars mb_expl_bndrs pats - (kcTyFamEqnRhs mb_clsinfo hs_ty) $ - \tvs pats res_kind -> - do { traceTc "tcTyFamInstEqn {" (ppr eqn_tc_name <+> ppr pats) - ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind - ; traceTc "tcTyFamInstEqn 1" (ppr eqn_tc_name <+> ppr pats) - ; (ze, tvs') <- zonkTyBndrs tvs - ; traceTc "tcTyFamInstEqn 2" (ppr eqn_tc_name <+> ppr pats) - ; pats' <- zonkTcTypesToTypesX ze pats - ; traceTc "tcTyFamInstEqn 3" (ppr eqn_tc_name <+> ppr pats $$ ppr rhs_ty) - ; rhs_ty' <- zonkTcTypeToTypeX ze rhs_ty - ; traceTc "tcTyFamInstEqn 4 }" (ppr fam_tc <+> pprTyVars tvs') - ; return (mkCoAxBranch tvs' [] pats' rhs_ty' - (map (const Nominal) tvs') - loc) } -tcTyFamInstEqn _ _ (dL->L _ (XHsImplicitBndrs _)) = panic "tcTyFamInstEqn" -tcTyFamInstEqn _ _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "tcTyFamInstEqn" -tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn: Impossible Match" -- due to #15884 - -kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars - -- (associated types only) - -> DataFamInstDecl GhcRn - -> TcKind -- ^ the kind of the tycon applied to pats - -> TcM ([TcTyVar], [TcType], TcKind) - -- ^ the kind signature might force instantiation - -- of the tycon; this returns any extra skolems, args and the inst'ed kind - -- See Note [Instantiating a family tycon] --- Used for 'data instance' only --- Ordinary 'data' is handled by kcTyClDecl -kcDataDefn mb_kind_env - (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = fam_name - , feqn_bndrs = mb_bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ctxt = ctxt - , dd_cons = cons - , dd_kindSig = mb_kind } }}}) - res_k - = do { _ <- tcHsContext ctxt - ; checkNoErrs $ mapM_ (wrapLocM_ kcConDecl) cons - -- See Note [Failing early in kcDataDefn] - ; exp_res_kind <- case mb_kind of - Nothing -> return liftedTypeKind - Just k -> tcLHsKindSig (DataKindCtxt (unLoc fam_name)) k - - -- The expected type might have a forall at the type. Normally, we - -- can't skolemise in kinds because we don't have type-level lambda. - -- But here, we're at the top-level of an instance declaration, so - -- we actually have a place to put the regeneralised variables. - -- Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise - -- Examples in indexed-types/should_compile/T12369 - ; let (tvs_to_skolemise, inner_res_kind) = tcSplitForAllTys exp_res_kind - - ; (skol_subst, tvs') <- tcInstSkolTyVars tvs_to_skolemise - - ; let inner_res_kind' = substTyAddInScope skol_subst inner_res_kind - tv_prs = zip (map tyVarName tvs_to_skolemise) tvs' - skol_info = SigSkol (InstDeclCtxt False) exp_res_kind tv_prs - - ; (ev_binds, (_, new_args, co)) - <- solveEqualities $ - checkConstraints skol_info tvs' [] $ - checkExpectedKindX mb_kind_env pp_fam_app - bogus_ty res_k inner_res_kind' - - ; let Pair lhs_ki rhs_ki = tcCoercionKind co + do { + -- First, check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars fam_tc) + ; checkTc (hs_pats `lengthIs` vis_arity) $ + wrongNumberOfParmsErr vis_arity - ; when debugIsOn $ - do { (_, ev_binds) <- initZonkEnv zonkTcEvBinds ev_binds - ; MASSERT( isEmptyTcEvBinds ev_binds ) - ; lhs_ki <- zonkTcType lhs_ki - ; rhs_ki <- zonkTcType rhs_ki - ; MASSERT( lhs_ki `tcEqType` rhs_ki ) } + ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo + imp_vars (mb_expl_bndrs `orElse` []) + hs_pats hs_rhs_ty - ; return (tvs', new_args, lhs_ki) } - where - bogus_ty = pprPanic "kcDataDefn" (ppr fam_name <+> ppr pats) - pp_fam_app = pprFamInstLHS fam_name mb_bndrs pats fixity (unLoc ctxt) mb_kind -kcDataDefn _ (DataFamInstDecl (XHsImplicitBndrs _)) _ - = panic "kcDataDefn" -kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ _ (XHsDataDefn _)))) _ - = panic "kcDataDefn" -kcDataDefn _ (DataFamInstDecl (HsIB _ (XFamEqn _))) _ - = panic "kcDataDefn" + ; traceTc "tcTyFamInstEqn" (ppr fam_tc $$ ppr qtvs $$ ppr pats $$ ppr rhs_ty) + ; return (mkCoAxBranch qtvs [] [] pats rhs_ty + (map (const Nominal) qtvs) + loc) } + +tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn" {- Kind check type patterns and kind annotate the embedded type variables. @@ -1792,213 +1817,184 @@ indexed-types/should_compile/T12369 for an example. So, the kind-checker must return the new skolems and args (that is, Type or (Type -> Type) for the equations above) and the instantiated kind. -Note [Failing early in kcDataDefn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl -calls tcConDecl, which checks that the return type of a GADT-like constructor -is actually an instance of the type head. Without the checkNoErrs, potentially -two bad things could happen: - - 1) Duplicate error messages, because tcConDecl will be called again during - *type* checking (as opposed to kind checking) - 2) If we just keep blindly forging forward after both kind checking and type - checking, we can get a panic in rejigConRes. See Trac #8368. +Note [Generalising in tcFamTyPatsAndThen] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like + type instance forall (a::k) b. F t1 t2 = rhs + +Then imp_vars = [k], exp_bndrs = [a::k, b] + +We want to quantify over + * k, a, and b (all user-specified) + * and any inferred free kind vars from + - the kinds of k, a, b + - the types t1, t2 + +However, 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. + +So, the simple thing is + - gather candiates from [k, a, b] and pats + - quantify over them + +Hence the sligtly mysterious call: + candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) + +Simple, neat, but a little non-obvious! -} ------------------ -kcFamTyPats :: TcTyCon - -> [Name] - -> Maybe [LHsTyVarBndr GhcRn] - -> HsTyPats GhcRn - -> (TcKind -> TcM ()) - -> TcM () -kcFamTyPats tc_fam_tc imp_vars mb_expl_bndrs arg_pats kind_checker - = discardResult $ - kcImplicitTKBndrs imp_vars $ - kcExplicitTKBndrs (fromMaybe [] mb_expl_bndrs) $ - do { let name = tyConName tc_fam_tc - loc = nameSrcSpan name - lhs_fun = cL loc (HsTyVar noExt NotPromoted (cL loc name)) - -- lhs_fun is for error messages only - no_fun = pprPanic "kcFamTyPats" (ppr name) - fun_kind = tyConKind tc_fam_tc - - ; (_, _, res_kind_out) <- tcInferApps typeLevelMode Nothing lhs_fun no_fun - fun_kind arg_pats - ; traceTc "kcFamTyPats" (vcat [ ppr tc_fam_tc, ppr arg_pats, ppr res_kind_out ]) - ; kind_checker res_kind_out } - -tcFamTyPats :: TyCon - -> Maybe ClsInstInfo - -> [Name] -- Implicitly bound kind/type variable names - -> Maybe [LHsTyVarBndr GhcRn] - -> HsTyPats GhcRn -- Type patterns - -> (TcKind -> TcM ([TcTyVar], [TcType], TcKind)) - -- kind-checker for RHS - -- See Note [Instantiating a family tycon] - -> ( [TcTyVar] -- Kind and type variables - -> [TcType] -- Kind and type arguments - -> TcKind - -> TcM a) -- NB: You can use solveEqualities here. - -> TcM a --- Check the type patterns of a type or data family instance --- type instance F <pat1> <pat2> = <type> --- The 'tyvars' are the free type variables of pats --- --- NB: The family instance declaration may be an associated one, --- nested inside an instance decl, thus --- instance C [a] where --- type F [a] = ... --- In that case, the type variable 'a' will *already be in scope* --- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc mb_clsinfo - imp_vars mb_expl_bndrs arg_pats kind_checker thing_inside - = do { -- First, check the arity. - -- If we wait until validity checking, we'll get kind - -- errors below when an arity error will be much easier to - -- understand. - let should_check_arity - | DataFamilyFlavour _ <- flav = False - -- why not check data families? See [Arity of data families] in FamInstEnv - | otherwise = True - - ; when should_check_arity $ - checkTc (arg_pats `lengthIs` vis_arity) $ - wrongNumberOfParmsErr vis_arity - -- report only explicit arguments - - ; (imp_tvs, (exp_tvs, (typats, (more_tyvars, more_typats, res_kind)))) - <- solveEqualities $ -- See Note [Constraints in patterns] - tcImplicitQTKBndrs FamInstSkol imp_vars $ - tcExplicitTKBndrs FamInstSkol (fromMaybe [] mb_expl_bndrs) $ - do { let loc = nameSrcSpan fam_name - lhs_fun = cL loc (HsTyVar noExt NotPromoted - (cL loc fam_name)) - fun_ty = mkTyConApp fam_tc [] - fun_kind = tyConKind fam_tc - mb_kind_env = thdOf3 <$> mb_clsinfo - - ; (_, args, res_kind_out) - <- tcInferApps typeLevelMode mb_kind_env - lhs_fun fun_ty fun_kind arg_pats - - ; traceTc "tcFamTyPats 1" (vcat [ ppr fam_tc - , ppr arg_pats - , ppr res_kind_out ]) - - ; stuff <- kind_checker res_kind_out - ; return (args, stuff) } - - {- TODO (RAE): This should be cleverer. Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - - This should probably be accepted. Yet the solveEqualities - will fail, unable to solve (F a ~ Bool) - We want to quantify over that proof. - But see Note [Constraints in patterns] - below, which is missing this piece. -} - - - -- Find free variables (after zonking) and turn - -- them into skolems, so that we don't subsequently - -- replace a meta kind var with (Any *) - -- Very like kindGeneralize - ; let all_pats = typats `chkAppend` more_typats - fam_app = mkTyConApp fam_tc all_pats - - user_tvs = exp_tvs ++ imp_tvs `chkAppend` more_tyvars - - -- the user_tvs might have quantified kind variables from - -- an enclosing class/instance; make sure to bring these into scope - extra_tvs = case mb_clsinfo of - Nothing -> [] - Just (_, inst_tvs, _) -> - filter (`elemVarSet` tyCoVarsOfType (mkSpecForAllTys user_tvs fam_app)) - inst_tvs - - all_tvs = extra_tvs ++ user_tvs - - -- the user_tvs are already bound in the pats; don't quantify over these again. - ; vars <- candidateQTyVarsOfType emptyVarSet $ - mkSpecForAllTys all_tvs fam_app - ; qtkvs <- quantifyTyVars emptyVarSet vars - ; let all_qtkvs = qtkvs ++ all_tvs - - ; when debugIsOn $ - do { all_pats <- mapM zonkTcType all_pats - ; MASSERT2( isEmptyVarSet $ coVarsOfTypes all_pats, ppr all_pats ) } - -- This should be the case, because otherwise the solveEqualities - -- above would fail. TODO (RAE): Update once the solveEqualities - -- bit is cleverer. - - ; traceTc "tcFamTyPats" (ppr (getName fam_tc) - $$ ppr mb_expl_bndrs - $$ ppr all_pats $$ ppr qtkvs) - - -- See Note [Free-floating kind vars] in TcHsType - ; lhs_tvs <- zonkTcTypeAndFV fam_app - ; let unmentioned_tvs = filterOut (`elemDVarSet` lhs_tvs) imp_tvs - -- If there are tyvars left over, we can - -- assume they're free-floating, since they - -- aren't bound by a type pattern - -- Recall that user are those lexically - -- used in the equation. As skolems, they - -- don't need zonking. - ; checkNoErrs $ reportFloatingKvs fam_name flav - (dVarSetElemsWellScoped lhs_tvs) unmentioned_tvs - - -- Error if exp_tvs contains anything that is still unused. - -- See Note [Unused explicitly bound variables in a family pattern] - ; let unmentioned_exp_tvs = filterOut (`elemDVarSet` lhs_tvs) exp_tvs - ; checkNoErrs $ mapM_ (unusedExplicitForAllErr . Var.varName) unmentioned_exp_tvs - - ; scopeTyVars FamInstSkol all_qtkvs $ - -- Extend envt with TcTyVars not TyVars, because the - -- kind checking etc done by thing_inside does not expect - -- to encounter TyVars; it expects TcTyVars - thing_inside all_qtkvs all_pats res_kind } +-------------------------- +tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo + -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder + -> 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 + = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ]) + + -- By now, for type families (but not data families) we should + -- have checked that the number of patterns matches tyConArity + + -- This code is closely related to the code + -- in TcHsType.kcLHsQTyVars_Cusk + ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) + <- pushTcLevelM_ $ + solveEqualities $ + bindImplicitTKBndrs_Q_Skol imp_vars $ + bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ + do { (lhs_ty, rhs_kind) <- tc_lhs + ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind + ; return (lhs_ty, rhs_ty) } + + -- See Note [Generalising in tcFamTyPatsAndThen] + ; let scoped_tvs = imp_tvs ++ exp_tvs + ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) + ; qtvs <- quantifyTyVars emptyVarSet dvs + + ; (ze, qtvs) <- zonkTyBndrs qtvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + + ; let pats = unravelFamInstPats lhs_ty + ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) + ; return (qtvs, pats, rhs_ty) } where - fam_name = tyConName fam_tc - flav = tyConFlavour fam_tc - vis_arity = length (tyConVisibleTyVars fam_tc) + tc_lhs | null hs_pats -- See Note [Apparently-nullary families] + = do { (args, rhs_kind) <- tcInstTyBinders $ + splitPiTysInvisibleN (tyConArity fam_tc) + (tyConKind fam_tc) + ; return (mkTyConApp fam_tc args, rhs_kind) } + | otherwise + = tcFamTyPats fam_tc mb_clsinfo hs_pats + +{- Note [Apparently-nullary families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: k -> * -unusedExplicitForAllErr :: Name -> RnM () -unusedExplicitForAllErr n = addErrAt (nameSrcSpan n) $ - text "Explicitly quantified but not used in LHS pattern: type variable" - <+> quotes (ppr n) +This really means + type family F @k :: k -> * -{- +That is, the family has arity 1, and can match on the kind. So it's +not really a nullary family. NB that + type famly F2 :: forall k. k -> * +is quite different and really does have arity 0. -Note [Unused explicitly bound variables in a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Returning to F we might have + type instannce F = Maybe +which instantaite 'k' to '*' and really means + type instannce F @* = Maybe -Why is 'unusedExplicitForAllErr' not just a warning? +Conclusion: in this odd case where there are no LHS patterns, we +should instantiate any invisible foralls in F's kind, to saturate +its arity (but no more). This is what happens in tc_lhs in +tcTyFamInstEqnGuts. -Consider the following examples: +If there are any visible patterns, then the first will force +instantiation of any Inferred quantifiers for F -- remember, +Inferred quantifiers always come first. +-} - type instance F a = Maybe b - type instance forall b. F a = Bool - type instance forall b. F a = Maybe b -In every case, b is a type variable not determined by the LHS pattern. The -first is caught by the renamer, but we catch the last two here. Perhaps one -could argue that the second should be accepted, albeit with a warning, but -consider the fact that in a type family instance, there is no way to interact -with such a varable. At least with @x :: forall a. Int@ we can use visibile -type application, like @x \@Bool 1@. (Of course it does nothing, but it is -permissible.) In the type family case, the only sensible explanation is that -the user has made a mistake -- thus we throw an error. +----------------- +tcFamTyPats :: TyCon -> AssocInstInfo + -> HsTyPats GhcRn -- Patterns + -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) +-- Used for both type and data families +tcFamTyPats fam_tc mb_clsinfo hs_pats + = do { traceTc "tcFamTyPats {" $ + vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind + , text "arity:" <+> ppr fam_arity + , text "kind:" <+> ppr fam_kind ] + ; let fun_ty = mkTyConApp fam_tc [] -Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ; (fam_app, res_kind) <- tcInferApps typeLevelMode lhs_fun fun_ty + fam_kind hs_pats + + ; traceTc "End tcFamTyPats }" $ + vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind + , text "res_kind:" <+> ppr res_kind ] + + -- Ensure that the instance is consistent its parent class + ; addConsistencyConstraints mb_clsinfo fam_app + + ; return (fam_app, res_kind) } + where + fam_name = tyConName fam_tc + fam_arity = tyConArity fam_tc + fam_kind = tyConKind fam_tc + lhs_fun = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name)) + +unravelFamInstPats :: TcType -> [TcType] +-- Decompose fam_app to get the argument patterns +-- +-- We expect fam_app to look like (F t1 .. tn) +-- tcInferApps is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern +unravelFamInstPats fam_app + = case splitTyConApp_maybe fam_app of + Just (_, pats) -> pats + Nothing -> WARN( True, bad_lhs fam_app ) [] + where + bad_lhs fam_app + = hang (text "Ill-typed LHS of family instance") + 2 (debugPprType fam_app) + +addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () +-- In the corresponding positions of the class and type-family, +-- ensure the the family argument is the same as the class argument +-- E.g class C a b c d where +-- F c x y a :: Type +-- Here the first arg of F should be the same as the third of C +-- and the fourth arg of F should be the same as the first of C +-- +-- We emit /Derived/ constraints (a bit like fundeps) to encourage +-- unification to happen, but without actually reporting errors. +-- If, despite the efforts, corresponding positions do not match, +-- checkConsistentFamInst will complain +addConsistencyConstraints mb_clsinfo fam_app + | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo + , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app + = do { let eqs = [ (cls_ty, pat) + | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats + , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] + ; traceTc "addConsistencyConstraints" (ppr eqs) + ; emitDerivedEqs AssocFamPatOrigin eqs } + -- Improve inference + -- Any mis-match is reports by checkConsistentFamInst + | otherwise + = return () + +{- Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: This isn't the whole story. See comment in tcFamTyPats. At first glance, it seems there is a complicated story to tell in tcFamTyPats @@ -2093,8 +2089,10 @@ that 'a' must have that kind, and to bring 'k' into scope. ************************************************************************ -} -dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl GhcRn] -> TcM Bool -dataDeclChecks tc_name new_or_data stupid_theta cons +dataDeclChecks :: Name -> NewOrData + -> LHsContext GhcRn -> [LConDecl GhcRn] + -> TcM Bool +dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons = do { -- Check that we don't use GADT syntax in H98 world gadtSyntax_ok <- xoptM LangExt.GADTSyntax ; let gadt_syntax = consUseGadtSyntax cons @@ -2109,7 +2107,7 @@ dataDeclChecks tc_name new_or_data stupid_theta cons ; checkTc (new_or_data == DataType || isSingleton cons) (newtypeConError tc_name (length cons)) - -- Check that there's at least one condecl, + -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; empty_data_decls <- xoptM LangExt.EmptyDataDecls ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? @@ -2149,7 +2147,9 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl , con_mb_cxt = hs_ctxt , con_args = hs_args }) = addErrCtxt (dataConCtxtName [name]) $ - do { -- Get hold of the existential type variables + do { -- NB: the tyvars from the declaration header are in scope + + -- Get hold of the existential type variables -- e.g. data T a = forall k (b::k) f. MkT a (f b) -- Here tmpl_bndrs = {a} -- hs_qvars = HsQTvs { hsq_implicit = {k} @@ -2158,8 +2158,9 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) - <- solveEqualities $ - tcExplicitTKBndrs skol_info explicit_tkv_nms $ + <- pushTcLevelM_ $ + solveEqualities $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext hs_ctxt ; btys <- tcConArgs hs_args ; field_lbls <- lookupConstructorFields (unLoc name) @@ -2171,17 +2172,17 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- quantifyConDecl (mkVarSet (binderVars tmpl_bndrs)) - (mkSpecForAllTys exp_tvs $ - mkFunTys ctxt $ - mkFunTys arg_tys $ - unitTy) + ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $ + mkSpecForAllTys exp_tvs $ + mkFunTys ctxt $ + mkFunTys arg_tys $ + unitTy) -- That type is a lie, of course. (It shouldn't end in ()!) -- And we could construct a proper result type from the info -- at hand. But the result would mention only the tmpl_tvs, -- and so it just creates more work to do it right. Really, - -- we're doing this to get the right behavior around removing - -- any vars bound in exp_binders. + -- we're only doing this to find the right kind variables to + -- quantify over, and this type is fine for that purpose. -- Zonk to Types ; (ze, qkvs) <- zonkTyBndrs kvs @@ -2219,39 +2220,38 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl ; traceTc "tcConDecl 2" (ppr name) ; mapM buildOneDataCon [name] } - where - skol_info = SigTypeSkol (ConArgCtxt (unLoc name)) tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl (ConDeclGADT { con_names = names , con_qvars = qtvs , con_mb_cxt = cxt, con_args = hs_args - , con_res_ty = res_ty }) + , con_res_ty = hs_res_ty }) | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms } , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1" (ppr names) + do { traceTc "tcConDecl 1 gadt" (ppr names) ; let ((dL->L _ name) : _) = names - skol_info = DataConSkol name ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) - <- failIfEmitsConstraints $ -- we won't get another crack, and we don't - -- want an error cascade - tcImplicitTKBndrs skol_info implicit_tkv_nms $ - tcExplicitTKBndrs skol_info explicit_tkv_nms $ + <- pushTcLevelM_ $ -- We are going to generalise + solveEqualities $ -- We won't get another crack, and we don't + -- want an error cascade + bindImplicitTKBndrs_Skol implicit_tkv_nms $ + bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext cxt ; btys <- tcConArgs hs_args - ; res_ty' <- tcHsLiftedType res_ty + ; res_ty <- tcHsLiftedType hs_res_ty ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, res_ty', field_lbls, stricts) + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } + ; imp_tvs <- zonkAndScopedSort imp_tvs ; let user_tvs = imp_tvs ++ exp_tvs - ; tkvs <- quantifyConDecl emptyVarSet (mkSpecForAllTys user_tvs $ - mkFunTys ctxt $ - mkFunTys arg_tys $ - res_ty) + ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $ + mkFunTys ctxt $ + mkFunTys arg_tys $ + res_ty) -- Zonk to Types ; (ze, tkvs) <- zonkTyBndrs tkvs @@ -2303,15 +2303,6 @@ tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "tcConDecl" tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl" --- | Produce the telescope of kind variables that this datacon is --- implicitly quantified over. Incoming type need not be zonked. -quantifyConDecl :: TcTyCoVarSet -- outer tvs, not to be quantified over; zonked - -> TcType -> TcM [TcTyVar] -quantifyConDecl gbl_tvs ty - = do { ty <- zonkTcType ty - ; fvs <- candidateQTyVarsOfType gbl_tvs ty - ; quantifyTyVars gbl_tvs fvs } - tcConIsInfixH98 :: Name -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) -> TcM Bool @@ -3016,12 +3007,12 @@ checkValidDataCon dflags existential_ok tc con user_tvbs_invariant = Set.fromList (filterEqSpec eq_spec univs ++ exs) == Set.fromList user_tvs - ; MASSERT2( user_tvbs_invariant + ; WARN( not user_tvbs_invariant , vcat ([ ppr con , ppr univs , ppr exs , ppr eq_spec - , ppr user_tvs ])) } + , ppr user_tvs ])) return () } ; traceTc "Done validity of data con" $ vcat [ ppr con @@ -3146,8 +3137,6 @@ checkValidClass cls cls_arity = length (tyConVisibleTyVars (classTyCon cls)) -- Ignore invisible variables cls_tv_set = mkVarSet tyvars - mini_env = zipVarEnv tyvars (mkTyVarTys tyvars) - mb_cls = Just (cls, tyvars, mini_env) check_op constrained_class_methods (sel_id, dm) = setSrcSpan (getSrcSpan sel_id) $ @@ -3198,11 +3187,11 @@ checkValidClass cls -- Check that any default declarations for associated types are valid ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> - checkValidTyFamEqn mb_cls fam_tc - fam_tvs [] (mkTyVarTys fam_tvs) rhs pp_lhs loc } + setSrcSpan loc $ + tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ + checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs } where fam_tvs = tyConTyVars fam_tc - pp_lhs = ppr (mkTyConApp fam_tc (mkTyVarTys fam_tvs)) check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () -- Check validity of the /top-level/ generic-default type diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 05a30fdf35..fd661c9b0e 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -14,7 +14,7 @@ module TcUnify ( tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC_O, tcSubTypeET, checkConstraints, checkTvConstraints, - buildImplicationFor, + buildImplicationFor, emitResidualTvConstraint, -- Various unifications unifyType, unifyKind, @@ -1167,20 +1167,27 @@ checkTvConstraints skol_info m_telescope thing_inside = do { (tclvl, wanted, (skol_tvs, result)) <- pushLevelAndCaptureConstraints thing_inside - ; if isEmptyWC wanted - then return () - else do { ev_binds <- newNoTcEvBinds - ; implic <- newImplication - ; emitImplication $ - implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_telescope = m_telescope - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } } + ; emitResidualTvConstraint skol_info m_telescope + skol_tvs tclvl wanted + ; return (skol_tvs, result) } +emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted + | isEmptyWC wanted + = return () + | otherwise + = do { ev_binds <- newNoTcEvBinds + ; implic <- newImplication + ; emitImplication $ + implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_telescope = m_telescope + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } } implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication] diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 1c0ce678e5..560b83db12 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -7,13 +7,12 @@ module TcValidity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - ContextKind(..), expectedKindInCtxt, checkValidTheta, checkValidFamPats, checkValidInstance, checkValidInstHead, validDerivPred, checkTySynRhs, - ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch, - checkValidTyFamEqn, - arityErr, badATErr, + checkValidCoAxiom, checkValidCoAxBranch, + checkValidTyFamEqn, checkConsistentFamInst, + badATErr, arityErr, checkValidTelescope, allDistinctTyVars ) where @@ -27,18 +26,21 @@ import Maybes -- friends: import TcUnify ( tcSubType_NC ) import TcSimplify ( simplifyAmbiguityCheck ) -import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..) ) +import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) import TyCoRep import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) import PrelNames import Type +import Unify ( tcMatchTyX_BM, BindFlag(..) ) import Coercion import CoAxiom import Class import TyCon -- others: +import IfaceType( pprIfaceType ) +import ToIface( toIfaceType ) import HsSyn -- HsType import TcRnMonad -- TcType, amongst others import TcEnv ( tcInitTidyEnv, tcInitOpenTidyEnv ) @@ -49,16 +51,17 @@ import FamInst ( makeInjectivityErrors ) import Name import VarEnv import VarSet -import Id ( idType, idName ) import Var ( VarBndr(..), mkTyVar ) +import Id ( idType, idName ) +import FV import ErrUtils import DynFlags import Util import ListSetOps import SrcLoc import Outputable -import Bag ( emptyBag ) import Unique ( mkAlphaTyVarUnique ) +import Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -366,10 +369,13 @@ checkValidType ctxt ty ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - -- Check the internal validity of the type itself - ; check_type env ctxt rank ty - - ; checkUserTypeError ty + -- Check the internal validity of the type itself + -- Fail if bad things happen, else we misleading + -- (and more complicated) errors in checkAmbiguity + ; checkNoErrs $ + do { check_type env ctxt rank ty + ; checkUserTypeError ty + ; traceTc "done ct" (ppr ty) } -- Check for ambiguous types. See Note [When to call checkAmbiguity] -- NB: this will happen even for monotypes, but that should be cheap; @@ -399,26 +405,6 @@ checkTySynRhs ctxt ty where actual_kind = typeKind ty --- | The kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnythingKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt :: UserTypeCtxt -> ContextKind -expectedKindInCtxt (TySynCtxt _) = AnythingKind -expectedKindInCtxt ThBrackCtxt = AnythingKind -expectedKindInCtxt GhciCtxt = AnythingKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = AnythingKind -expectedKindInCtxt TypeAppCtxt = AnythingKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - {- Note [Higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -456,6 +442,14 @@ forAllAllowed ArbitraryRank = True forAllAllowed (LimitedRank forall_ok _) = forall_ok forAllAllowed _ = False +constraintsAllowed :: UserTypeCtxt -> Bool +-- We don't allow constraints in kinds +constraintsAllowed (TyVarBndrKindCtxt {}) = False +constraintsAllowed (DataKindCtxt {}) = False +constraintsAllowed (TySynKindCtxt {}) = False +constraintsAllowed (TyFamResKindCtxt {}) = False +constraintsAllowed _ = True + ---------------------------------------- check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM () -- The args say what the *type context* requires, independent @@ -471,6 +465,11 @@ check_type env ctxt rank ty -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message + ; checkTcM (null theta || constraintsAllowed ctxt) + (constraintTyErr env ty) + -- Reject forall (a :: Eq b => b). blah + -- In a kind signature we don't allow constraints + ; check_valid_theta env' SigmaCtxt theta -- Allow type T = ?x::Int => Int -> Int -- but not type T = ?x::Int @@ -630,6 +629,10 @@ ubxArgTyErr env ty , ppr_tidy env ty ] , text "Perhaps you intended to use UnboxedTuples" ] ) +constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintTyErr env ty + = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) + {- Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1461,8 +1464,7 @@ and we /really/ don't want that. So we carefully do /not/ expand synonyms, by matching on TyConApp directly. -} -checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type - -> TcM ([TyVar], ThetaType, Class, [Type]) +checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty | not is_tc_app = failWithTc (hang (text "Instance head is not headed by a class:") @@ -1507,9 +1509,9 @@ checkValidInstance ctxt hs_type ty ; traceTc "End checkValidInstance }" empty - ; return (tvs, theta, clas, inst_tys) } + ; return () } where - (tvs, theta, tau) = tcSplitSigmaTy ty + (_tvs, theta, tau) = tcSplitSigmaTy ty is_tc_app = case tau of { TyConApp {} -> True; _ -> False } TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] mb_cls = tyConClass_maybe tc @@ -1619,118 +1621,6 @@ arbitrarily large type, depending on how 'a' is instantiated. So we require UndecidableInstances if we have a type family in the instance head. Trac #15172. -Note [Associated type instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow this: - class C a where - type T x a - instance C Int where - type T (S y) Int = y - type T Z Int = Char - -Note that - a) The variable 'x' is not bound by the class decl - b) 'x' is instantiated to a non-type-variable in the instance - c) There are several type instance decls for T in the instance - -All this is fine. Of course, you can't give any *more* instances -for (T ty Int) elsewhere, because it's an *associated* type. - -Note [Checking consistent instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #11450 for background discussion on this check. - - class C a b where - type T a x b - -With this class decl, if we have an instance decl - instance C ty1 ty2 where ... -then the type instance must look like - type T ty1 v ty2 = ... -with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. -For example: - - instance C [p] Int - type T [p] y Int = (p,y,y) - -Note that - -* We used to allow completely different bound variables in the - associated type instance; e.g. - instance C [p] Int - type T [q] y Int = ... - But from GHC 8.2 onwards, we don't. It's much simpler this way. - See Trac #11450. - -* When the class variable isn't used on the RHS of the type instance, - it's tempting to allow wildcards, thus - instance C [p] Int - type T [_] y Int = (y,y) - But it's awkward to do the test, and it doesn't work if the - variable is repeated: - instance C (p,p) Int - type T (_,_) y Int = (y,y) - Even though 'p' is not used on the RHS, we still need to use 'p' - on the LHS to establish the repeated pattern. So to keep it simple - we just require equality. - -* For variables in associated type families that are not bound by the class - itself, we do _not_ check if they are over-specific. In other words, - it's perfectly acceptable to have an instance like this: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - - While the first and third arguments to T are required to be exactly [p] and - Int, respectively, since they are bound by C, the second argument is allowed - to be more specific than just a type variable. Furthermore, it is permissible - to define multiple equations for T that differ only in the non-class-bound - argument: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - type T [p] (Either x y) Int = x -> y - - We once considered requiring that non-class-bound variables in associated - type family instances be instantiated with distinct type variables. However, - that requirement proved too restrictive in practice, as there were examples - of extremely simple associated type family instances that this check would - reject, and fixing them required tiresome boilerplate in the form of - auxiliary type families. For instance, you would have to define the above - example as: - - instance C [p] Int where - type T [p] x Int = CAux x - - type family CAux x where - CAux (Maybe x) = x - CAux (Either x y) = x -> y - - We decided that this restriction wasn't buying us much, so we opted not - to pursue that design (see also GHC Trac #13398). - -Implementation - * Form the mini-envt from the class type variables a,b - to the instance decl types [p],Int: [a->[p], b->Int] - - * Look at the tyvars a,x,b of the type family constructor T - (it shares tyvars with the class C) - - * Apply the mini-evnt to them, and check that the result is - consistent with the instance types [p] y Int. (where y can be any type, as - it is not scoped over the class type variables. - -We make all the instance type variables scope over the -type instances, of course, which picks up non-obvious kinds. Eg - class Foo (a :: k) where - type F a - instance Foo (b :: k -> k) where - type F b = Int -Here the instance is kind-indexed and really looks like - type F (k->k) (b::k->k) = Int -But if the 'b' didn't scope, we would make F's instance too -poly-kinded. - Note [Invisible arguments and termination] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When checking the Paterson conditions for termination an instance @@ -1746,102 +1636,6 @@ described in Trac #15177, which contains a number of examples. The suspicious bits are the calls to filterOutInvisibleTypes. -} --- | Extra information about the parent instance declaration, needed --- when type-checking associated types. The 'Class' is the enclosing --- class, the [TyVar] are the type variable of the instance decl, --- and and the @VarEnv Type@ maps class variables to their instance --- types. -type ClsInstInfo = (Class, [TyVar], VarEnv Type) - -type AssocInstArgShape = (Maybe Type, Type) - -- AssocInstArgShape is used only for associated family instances - -- (mb_exp, actual) - -- mb_exp = Just ty => this arg corresponds to a class variable - -- = Nothing => it doesn't correspond to a class variable - -- e.g. class C b where - -- type F a b c - -- instance C [x] where - -- type F p [x] q - -- We get [AssocInstArgShape] = [ (Nothing, p) - -- , (Just [x], [x]) - -- , (Nothing, q)] - -checkConsistentFamInst - :: Maybe ClsInstInfo - -> TyCon -- ^ Family tycon - -> [Type] -- ^ Type patterns from instance - -> SDoc -- ^ pretty-printed user-written instance head - -> TcM () --- See Note [Checking consistent instantiation] - -checkConsistentFamInst Nothing _ _ _ = return () -checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc at_tys pp_hs_pats - = do { -- Check that the associated type indeed comes from this class - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - - checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) - (badATErr (className clas) (tyConName fam_tc)) - - -- Check type args first (more comprehensible) - ; checkTc (all check_arg type_shapes) pp_wrong_at_arg - - -- And now kind args - ; checkTcM (all check_arg kind_shapes) - (tidy_env2, pprWithExplicitKindsWhen True pp_wrong_at_arg) - - ; traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs - , ppr arg_shapes - , ppr mini_env ]) } - where - arg_shapes :: [AssocInstArgShape] - arg_shapes = [ (lookupVarEnv mini_env fam_tc_tv, at_ty) - | (fam_tc_tv, at_ty) <- tyConTyVars fam_tc `zip` at_tys ] - - kind_shapes, type_shapes :: [AssocInstArgShape] - (kind_shapes, type_shapes) = partitionInvisibles $ - arg_shapes `zip` tyConArgFlags fam_tc at_tys - - check_arg :: AssocInstArgShape -> Bool - check_arg (Just exp_ty, at_ty) = exp_ty `tcEqType` at_ty - check_arg (Nothing, _ ) = True -- Arg position does not correspond - -- to a class variable - - pp_wrong_at_arg - = vcat [ text "Type indexes must match class instance head" - , pp_exp_act ] - - pp_exp_act - = vcat [ text "Expected:" <+> ppr (mkTyConApp fam_tc expected_args) - , text " Actual:" <+> pp_hs_pats - , sdocWithDynFlags $ \dflags -> - ppWhen (has_poly_args dflags) $ - vcat [ text "where the `<tv>' arguments are type variables," - , text "distinct from each other and from the instance variables" ] ] - - -- We need to tidy, since it's possible that expected_args will contain - -- inferred kind variables with names identical to those in at_tys. If we - -- don't, we'll end up with horrible messages like this one (#13972): - -- - -- Expected: T (a -> Either a b) - -- Actual: T (a -> Either a b) - (tidy_env1, _) = tidyOpenTypes emptyTidyEnv at_tys - (tidy_env2, expected_args) - = tidyOpenTypes tidy_env1 [ exp_ty `orElse` mk_tv at_ty - | (exp_ty, at_ty) <- arg_shapes ] - mk_tv at_ty = mkTyVarTy (mkTyVar tv_name (typeKind at_ty)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "<tv>") noSrcSpan - - has_poly_args dflags = any (isNothing . fst) shapes - where - shapes | gopt Opt_PrintExplicitKinds dflags = arg_shapes - | otherwise = type_shapes - -badATErr :: Name -> Name -> SDoc -badATErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have an associated type", quotes (ppr op)] - {- ************************************************************************ @@ -1853,7 +1647,7 @@ badATErr clas op checkValidCoAxiom :: CoAxiom Branched -> TcM () checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) - = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list + = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list ; foldlM_ check_branch_compat [] branch_list } where branch_list = fromBranches branches @@ -1868,7 +1662,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch ax cur_branch + inaccessibleCoAxBranch fam_tc cur_branch ; return prev_branches } | otherwise = do { check_injectivity prev_branches cur_branch @@ -1906,31 +1700,24 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). -- -checkValidCoAxBranch :: Maybe ClsInstInfo - -> TyCon -> CoAxBranch -> TcM () -checkValidCoAxBranch mb_clsinfo fam_tc +checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () +checkValidCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) - = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc - where - pp_lhs = ppr (mkTyConApp fam_tc typats) + = setSrcSpan loc $ + checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs -- | Do validity checks on a type family equation, including consistency -- with any enclosing class instance head, termination, and lack of -- polytypes. -checkValidTyFamEqn :: Maybe ClsInstInfo - -> TyCon -- ^ of the type family - -> [TyVar] -- ^ bound tyvars in the equation - -> [CoVar] -- ^ bound covars in the equation - -> [Type] -- ^ type patterns - -> Type -- ^ rhs - -> SDoc -- ^ user-written LHS - -> SrcSpan +checkValidTyFamEqn :: TyCon -- ^ of the type family + -> [Var] -- ^ Bound variables in the equation + -> [Type] -- ^ Type patterns + -> Type -- ^ Rhs -> TcM () -checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc - = setSrcSpan loc $ - do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats [] pp_lhs +checkValidTyFamEqn fam_tc qvs typats rhs + = do { checkValidFamPats fam_tc qvs typats rhs -- The argument patterns, and RHS, are all boxed tau types -- E.g Reject type family F (a :: k1) :: k2 @@ -1943,9 +1730,9 @@ checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc -- We have a decidable instance unless otherwise permitted ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; traceTc "checkVTFE" (pp_lhs $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) + ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) ; unless undecidable_ok $ - mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } + mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } -- Make sure that each type family application is -- (1) strictly smaller than the lhs, @@ -1975,28 +1762,83 @@ checkFamInstRhs lhs_tc lhs_tys famInsts -- [a,b,a,a] \\ [a,a] = [b,a] -- So we are counting repetitions -checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar] - -> [Type] -- ^ patterns the user wrote - -> [Type] -- ^ "extra" patterns from a data instance kind sig - -> SDoc -- ^ pretty-printed user-written instance head +checkValidFamPats :: TyCon -> [Var] + -> [Type] -- ^ patterns + -> Type -- ^ RHS -> TcM () -- Patterns in a 'type instance' or 'data instance' decl should --- a) contain no type family applications +-- a) Shoule contain no type family applications -- (vanilla synonyms are fine, though) --- b) properly bind all their free type variables --- e.g. we disallow (Trac #7536) --- type T a = Int --- type instance F (T a) = a --- c) For associated types, are consistently instantiated -checkValidFamPats mb_clsinfo fam_tc tvs cvs user_ty_pats extra_ty_pats pp_hs_pats - = do { checkValidTypePats fam_tc user_ty_pats +-- b) For associated types, are consistently instantiated +checkValidFamPats fam_tc qvs pats rhs + = do { checkValidTypePats fam_tc pats - ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes user_ty_pats) - (tvs ++ cvs) - ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs user_ty_pats) + -- Check for things used on the right but not bound on the left + ; checkFamPatBinders fam_tc qvs pats rhs + + ; traceTc "checkValidFamPats" (ppr fam_tc <+> ppr pats) + } + +----------------- +checkFamPatBinders :: TyCon + -> [TcTyVar] -- Bound on LHS of family instance + -> [TcType] -- LHS patterns + -> Type -- RHS + -> TcM () +-- We do these binder checks now, in tcFamTyPatsAndGen, rather +-- than later, in checkValidFamEqn, for two reasons: +-- - We have the implicitly and explicitly +-- bound type variables conveniently to hand +-- - If implicit variables are out of scope it may +-- cause a crash; notably in tcConDecl in tcDataFamInstDecl +checkFamPatBinders fam_tc qtvs pats rhs + = do { traceTc "checkFamPatBinders" $ + vcat [ debugPprType (mkTyConApp fam_tc pats) + , ppr (mkTyConApp fam_tc pats) + , text "qtvs:" <+> ppr qtvs + , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) + , text "pat_tvs:" <+> ppr pat_tvs + , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ] + + -- Check for implicitly-bound tyvars, mentioned on the + -- RHS but not bound on the LHS + -- data T = MkT (forall (a::k). blah) + -- data family D Int = MkD (forall (a::k). blah) + -- In both cases, 'k' is not bound on the LHS, but is used on the RHS + -- We catch the former in kcLHsQTyVars, and the latter right here + ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") + (text "bound on the LHS of") + + -- Check for explicitly forall'd variable that is not bound on LHS + -- data instance forall a. T Int = MkT Int + -- See Note [Unused explicitly bound variables in a family pattern] + ; check_tvs bad_qtvs (text "bound by a forall") + (text "used in") } + where + pat_tvs = tyCoVarsOfTypes pats + exact_pat_tvs = exactTyCoVarsOfTypes pats + rhs_fvs = tyCoFVsOfType rhs + used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs + bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs + -- Bound but not used at all + bad_rhs_tvs = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs) + -- Used on RHS but not bound on LHS + dodgy_tvs = pat_tvs `minusVarSet` exact_pat_tvs + + check_tvs tvs what what2 + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ + hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs + <+> isOrAre tvs <+> what <> comma) + 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" + , mk_extra tvs ]) + + -- mk_extra: Trac #7536: give a decent error message for + -- type T a = Int + -- type instance F (T a) = a + mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ + hang (text "The real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - -- Check that type patterns match the class instance head - ; checkConsistentFamInst mb_clsinfo fam_tc (user_ty_pats `chkAppend` extra_ty_pats) pp_hs_pats } -- | Checks for occurrences of type families in class instances and type/data -- family instances. @@ -2025,25 +1867,252 @@ checkValidTypePats tc pat_ty_args = do -- Error messages -inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fi_ax cur_branch +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch fam_tc cur_branch = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranch fi_ax cur_branch) + nest 2 (pprCoAxBranchUser fam_tc cur_branch) nestedMsg :: SDoc -> SDoc nestedMsg what = sep [ text "Illegal nested" <+> what , parens undecidableMsg ] -famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc -famPatErr fam_tc tvs pats - = hang (text "Family instance purports to bind type variable" <> plural tvs - <+> pprQuotedList tvs) - 2 (hang (text "but the real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> - text "= ...")) +badATErr :: Name -> Name -> SDoc +badATErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have an associated type", quotes (ppr op)] + + +------------------------- +checkConsistentFamInst :: AssocInstInfo + -> TyCon -- ^ Family tycon + -> CoAxBranch + -> TcM () +-- See Note [Checking consistent instantiation] + +checkConsistentFamInst NotAssociated _ _ + = return () + +checkConsistentFamInst (InClsInst { ai_class = clas + , ai_tyvars = inst_tvs + , ai_inst_env = mini_env }) + fam_tc branch + = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs + , ppr arg_triples + , ppr mini_env ]) + -- Check that the associated type indeed comes from this class + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) + (badATErr (className clas) (tyConName fam_tc)) + + ; check_match arg_triples + } + where + CoAxBranch { cab_eta_tvs = eta_tvs, cab_lhs = pats } = branch + at_arg_tys = pats ++ mkTyVarTys eta_tvs + + arg_triples :: [(Type,Type, ArgFlag)] + arg_triples = [ (cls_arg_ty, at_arg_ty, vis) + | (fam_tc_tv, vis, at_arg_ty) + <- zip3 (tyConTyVars fam_tc) + (tyConArgFlags fam_tc at_arg_tys) + at_arg_tys + , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] + + pp_wrong_at_arg vis + = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ + vcat [ text "Type indexes must match class instance head" + , text "Expected:" <+> pp_expected_ty + , text " Actual:" <+> pp_actual_ty ] + + -- Fiddling around to arrange that wildcards unconditionally print as "_" + -- We only need to print the LHS, not the RHS at all + expected_args = [ lookupVarEnv mini_env at_tv `orElse` mk_wildcard at_tv + | at_tv <- tyConTyVars fam_tc ] + mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) + tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan + pp_expected_ty = pprIfaceType (toIfaceType (mkTyConApp fam_tc expected_args)) + -- Do /not/ tidy, because that will rename all those "_" + -- variables we have put in. And (I think) the intance type + -- is already tidy + +-- actual_ty = mkTyConApp fam_tc at_arg_tys +-- (tidy_env, bndrs) = tidyCoAxBndrs (tyCoVarsOfTypesList [expected_ty, actual_ty]) +-- pp_actual_ty pprPrecTypeX tidy_env topPrec actual_ty + pp_actual_ty = pprCoAxBranchLHS fam_tc branch + + -- For check_match, bind_me, see + -- Note [Matching in the consistent-instantation check] + check_match :: [(Type,Type,ArgFlag)] -> TcM () + check_match triples = go emptyTCvSubst emptyTCvSubst triples + + go _ _ [] = return () + go lr_subst rl_subst ((ty1,ty2,vis):triples) + | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 + , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 + = go lr_subst1 rl_subst1 triples + | otherwise + = addErrTc (pp_wrong_at_arg vis) + + -- The scoped type variables from the class-instance header + -- should not be alpha-raenamed. + no_bind_set = mkVarSet inst_tvs + bind_me tv | tv `elemVarSet` no_bind_set = Skolem + | otherwise = BindMe + + +{- Note [Matching in the consistent-instantation check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Matching the class-instance header to family-instance tyvars is +tricker than it sounds. Consider (Trac #13972) + class C (a :: k) where + type T k :: Type + instance C Left where + type T (a -> Either a b) = Int + +Here there are no lexically-scoped variables from (C Left). +Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) +while the type-family instance is T (a -> Either @a @b) +So we allow alpha-renaming of variables that don't come +from the class-instance header. + +We track the lexically-scoped type variables from the +class-instance header in ai_tyvars. + +Here's another example (Trac #14045a) + class C (a :: k) where + data S (a :: k) + instance C (z :: Bool) where + data S :: Bool -> Type where + +Again, there is no lexical connection, but we will get + class-instance header: C @Bool (z::Bool) + family instance S @Bool (a::Bool) + +When looking for mis-matches, we check left-to-right, +kinds first. If we look at types first, we'll fail to +suggest -fprint-explicit-kinds for a mis-match with + T @k vs T @Type +somewhere deep inside the type + +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #11450 for background discussion on this check. + + class C a b where + type T a x b + +With this class decl, if we have an instance decl + instance C ty1 ty2 where ... +then the type instance must look like + type T ty1 v ty2 = ... +with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. +For example: + + instance C [p] Int + type T [p] y Int = (p,y,y) + +Note that + +* We used to allow completely different bound variables in the + associated type instance; e.g. + instance C [p] Int + type T [q] y Int = ... + But from GHC 8.2 onwards, we don't. It's much simpler this way. + See Trac #11450. + +* When the class variable isn't used on the RHS of the type instance, + it's tempting to allow wildcards, thus + instance C [p] Int + type T [_] y Int = (y,y) + But it's awkward to do the test, and it doesn't work if the + variable is repeated: + instance C (p,p) Int + type T (_,_) y Int = (y,y) + Even though 'p' is not used on the RHS, we still need to use 'p' + on the LHS to establish the repeated pattern. So to keep it simple + we just require equality. + +* For variables in associated type families that are not bound by the class + itself, we do _not_ check if they are over-specific. In other words, + it's perfectly acceptable to have an instance like this: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + + While the first and third arguments to T are required to be exactly [p] and + Int, respectively, since they are bound by C, the second argument is allowed + to be more specific than just a type variable. Furthermore, it is permissible + to define multiple equations for T that differ only in the non-class-bound + argument: + + instance C [p] Int where + type T [p] (Maybe x) Int = x + type T [p] (Either x y) Int = x -> y + + We once considered requiring that non-class-bound variables in associated + type family instances be instantiated with distinct type variables. However, + that requirement proved too restrictive in practice, as there were examples + of extremely simple associated type family instances that this check would + reject, and fixing them required tiresome boilerplate in the form of + auxiliary type families. For instance, you would have to define the above + example as: + + instance C [p] Int where + type T [p] x Int = CAux x + + type family CAux x where + CAux (Maybe x) = x + CAux (Either x y) = x -> y + + We decided that this restriction wasn't buying us much, so we opted not + to pursue that design (see also GHC Trac #13398). + +Implementation + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int. (where y can be any type, as + it is not scoped over the class type variables. + +We make all the instance type variables scope over the +type instances, of course, which picks up non-obvious kinds. Eg + class Foo (a :: k) where + type F a + instance Foo (b :: k -> k) where + type F b = Int +Here the instance is kind-indexed and really looks like + type F (k->k) (b::k->k) = Int +But if the 'b' didn't scope, we would make F's instance too +poly-kinded. + + +Note [Unused explicitly bound variables in a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Why is 'unusedExplicitForAllErr' not just a warning? + +Consider the following examples: + + type instance F a = Maybe b + type instance forall b. F a = Bool + type instance forall b. F a = Maybe b + +In every case, b is a type variable not determined by the LHS pattern. The +first is caught by the renamer, but we catch the last two here. Perhaps one +could argue that the second should be accepted, albeit with a warning, but +consider the fact that in a type family instance, there is no way to interact +with such a varable. At least with @x :: forall a. Int@ we can use visibile +type application, like @x \@Bool 1@. (Of course it does nothing, but it is +permissible.) In the type family case, the only sensible explanation is that +the user has made a mistake -- thus we throw an error. + -{- ************************************************************************ * * Telescope checking @@ -2092,39 +2161,53 @@ check works for `forall x y z.` written in a type. -- data type declarations -- and Note [Keeping scoped variables in order: Explicit] in TcHsType -- for foralls -checkValidTelescope :: [TyConBinder] -- explicit vars (zonked) - -> SDoc -- original, user-written telescope - -> TcM () -checkValidTelescope tvbs user_tyvars - = unless (null bad_tvbs) $ addErr $ - vcat [ hang (text "These kind and type variables:" <+> user_tyvars $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tidied_tvs) - , extra ] +checkValidTelescope :: TyCon -> TcM () +checkValidTelescope tc + = unless (null bad_tcbs) $ addErr $ + vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") + 2 (text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)) + , extra + , hang (text "Perhaps try this order instead:") + 2 (pprTyVars sorted_tidied_tvs) ] where - tvs = binderVars tvbs + ppr_untidy ty = pprIfaceType (toIfaceType ty) + tcbs = tyConBinders tc + tvs = binderVars tcbs (_, sorted_tidied_tvs) = tidyVarBndrs emptyTidyEnv (scopedSort tvs) - (_, bad_tvbs) = foldl add_one (mkVarSet tvs, []) tvbs + (_, bad_tcbs) = foldl add_one (mkVarSet tvs, []) tcbs add_one :: (TyVarSet, [TyConBinder]) - -> TyConBinder - -> (TyVarSet, [TyConBinder]) + -> TyConBinder -> (TyVarSet, [TyConBinder]) add_one (bad_bndrs, acc) tvb - | fkvs `intersectsVarSet` bad_bndrs - = (bad', tvb : acc) - | otherwise - = (bad', acc) + | fkvs `intersectsVarSet` bad_bndrs = (bad', tvb : acc) + | otherwise = (bad', acc) where tv = binderVar tvb fkvs = tyCoVarsOfType (tyVarKind tv) bad' = bad_bndrs `delVarSet` tv + inferred_tvs = [ binderVar tcb + | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] + specified_tvs = [ binderVar tcb + | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] + + pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) + pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) + extra - | any isInvisibleTyConBinder tvbs - = text "NB: Implicitly declared variables come before others." - | otherwise + | null inferred_tvs && null specified_tvs = empty + | null inferred_tvs + = hang (text "NB: Specified variables") + 2 (sep [pp_spec, text "always come first"]) + | null specified_tvs + = hang (text "NB: Inferred variables") + 2 (sep [pp_inf, text "always come first"]) + | otherwise + = hang (text "NB: Inferred variables") + 2 (vcat [ sep [ pp_inf, text "always come first"] + , sep [text "then Specified variables", pp_spec]]) {- ************************************************************************ diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs index 7f578ec696..5c4237c593 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -221,8 +221,9 @@ data CoAxBranch { cab_loc :: SrcSpan -- Location of the defining equation -- See Note [CoAxiom locations] , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars -- See Note [CoAxBranch type variables] - -- May be eta-reduded; see FamInstEnv + -- cab_tvs and cab_lhsmay be eta-reduded; see FamInstEnv -- Note [Eta reduction for data families] , cab_cvs :: [CoVar] -- Bound coercion variables -- Always empty, for now. @@ -382,6 +383,66 @@ See also Note [Implicit TyThings] in HscTypes That is, it does not have its own IfaceAxiom declaration in an interface file; instead the CoAxiom is generated by type-checking the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab__tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-expanded away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +(See also Note [Newtype eta] in TyCon. This is notionally separate +and deals with the axiom connecting a newtype with its representation +type; but it too is eta-reduced.) -} instance Eq (CoAxiom br) where diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 529f90a964..a55deeb1d3 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -98,7 +98,8 @@ module Coercion ( -- * Pretty-printing pprCo, pprParendCo, - pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, pprCoAxBranchUser, + etaExpandCoAxBranch, -- * Tidying tidyCo, tidyCos, @@ -136,6 +137,7 @@ import UniqFM import Control.Monad (foldM, zipWithM) import Data.Function ( on ) +import Data.Char( isDigit ) {- %************************************************************************ @@ -170,60 +172,102 @@ Defined here to avoid module loops. CoAxiom is loaded very early on. -} +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in CoAxiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + pprCoAxiom :: CoAxiom br -> SDoc -pprCoAxiom ax@(CoAxiom { co_ax_branches = branches }) +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = hang (text "axiom" <+> ppr ax <+> dcolon) - 2 (vcat (map (ppr_co_ax_branch (\env _ ty -> - equals <+> pprPrecTypeX env topPrec ty) ax) $ - fromBranches branches)) + 2 (vcat (map (pprCoAxBranch tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.makeInjectivityErrors) +-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (Trac #14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty -pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc -pprCoAxBranch = ppr_co_ax_branch pprRhs +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs where - pprRhs _ fam_tc rhs - | isDataFamilyTyCon fam_tc - = empty -- Don't bother printing anything for the RHS of a data family - -- instance... + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs - | otherwise - = equals <+> ppr rhs - -- ...but for a type family instance, do print out the RHS, since - -- it might be needed to disambiguate between duplicate instances - -- (#14179) - -pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc -pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index) - -ppr_co_ax_branch :: (TidyEnv -> TyCon -> Type -> SDoc) - -> CoAxiom br -> CoAxBranch -> SDoc -ppr_co_ax_branch ppr_rhs - (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) - (CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs - , cab_loc = loc }) +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyCoVarBinders Inferred (ee_tvs' ++ cvs)) - , pp_lhs <+> ppr_rhs env fam_tc ee_rhs - , text "-- Defined" <+> pprLoc loc ] + [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + -- See Note [Printing foralls in type family instances] in IfaceType + , pp_lhs <+> ppr_rhs tidy_env ee_rhs + , text "-- Defined" <+> pp_loc ] where - pprLoc loc - | isGoodSrcSpan loc - = text "at" <+> ppr (srcSpanStart loc) - - | otherwise - = text "in" <+> - quotes (ppr (nameModule name)) + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in FamInstEnv. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrs ee_tvs + +tidyCoAxBndrs :: [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +tidyCoAxBndrs tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (empty_env, []) tcvs + empty_env = mkEmptyTidyEnv (initTidyOccEnv [mkTyVarOcc "_"]) - -- Eta-expand LHS and RHS types, because sometimes data family - -- instances are eta-reduced. - -- See Note [Eta reduction for data families] in FamInstEnv. - (ee_tvs, ee_lhs, ee_rhs) = etaExpandFamInst tvs lhs rhs + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOcc "_") + -- Tidy the binder to "_" - (env, ee_tvs') = tidyVarBndrs emptyTidyEnv ee_tvs - pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) - (tidyToIfaceTcArgs env fam_tc ee_lhs) + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False {- %************************************************************************ @@ -935,8 +979,8 @@ mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) mkTransCo co1 co2 = TransCo co1 co2 mkNthCo :: HasDebugCallStack - => Role -- the role of the coercion you're creating - -> Int + => Role -- The role of the coercion you're creating + -> Int -- Zero-indexed -> Coercion -> Coercion mkNthCo r n co diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index d727250c00..149ff3f115 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -7,7 +7,6 @@ module FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - etaExpandFamInst, pprFamInst, pprFamInsts, mkImportedFamInst, @@ -168,60 +167,6 @@ Why can we allow such flexibility for data families but not for type families? Because data families can be decomposed -- that is, they are generative and injective. A Type family is neither and so always must be applied to all its arguments. - -Note [Eta reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family T a b :: * - newtype instance T Int a = MkT (IO a) deriving( Monad ) -We'd like this to work. - -From the 'newtype instance' you might think we'd get: - newtype TInt a = MkT (IO a) - axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part - axiom ax2 a :: TInt a ~ IO a -- The newtype part - -But now what can we do? We have this problem - Given: d :: Monad IO - Wanted: d' :: Monad (T Int) = d |> ???? -What coercion can we use for the ??? - -Solution: eta-reduce both axioms, thus: - axiom ax1 :: T Int ~ TInt - axiom ax2 :: TInt ~ IO -Now - d' = d |> Monad (sym (ax2 ; ax1)) - ------ Bottom line ------ - -For a FamInst with fi_flavour = DataFamilyInst rep_tc, - - - fi_tvs (and cab_tvs of its CoAxiom) may be shorter - than tyConTyVars of rep_tc. - - - fi_tys may be shorter than tyConArity of the family tycon - i.e. LHS is unsaturated - - - fi_rhs will be (rep_tc fi_tvs) - i.e. RHS is un-saturated - - - This eta reduction happens for data instances as well - as newtype instances. Here we want to eta-reduce the data family axiom. - - - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. - -But when fi_flavour = SynFamilyInst, - - fi_tys has the exact arity of the family tycon - -There are certain situations (e.g., pretty-printing) where it is necessary to -deal with eta-expanded data family instances. For these situations, the -etaExpandFamInstLHS function exists as a convenient way to perform this eta -expansion. (See #9692, #14179, and #15845 for examples of what can go wrong if -etaExpandFamInstLHS isn't used). - -(See also Note [Newtype eta] in TyCon. This is notionally separate -and deals with the axiom connecting a newtype with its representation -type; but it too is eta-reduced.) -} -- Obtain the axiom of a family instance @@ -272,56 +217,29 @@ instance NamedThing FamInst where instance Outputable FamInst where ppr = pprFamInst --- Prints the FamInst as a family instance declaration --- NB: FamInstEnv.pprFamInst is used only for internal, debug printing --- See pprTyThing.pprFamInst for printing for the user pprFamInst :: FamInst -> SDoc -pprFamInst famInst - = hang (pprFamInstHdr famInst) 2 (whenPprDebug debug_stuff) - where - ax = fi_axiom famInst - debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax - , text "Tvs:" <+> ppr (fi_tvs famInst) - , text "LHS:" <+> ppr (fi_tys famInst) - , text "RHS:" <+> ppr (fi_rhs famInst) ] - -pprFamInstHdr :: FamInst -> SDoc -pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) - = pprTyConSort <+> pp_instance <+> pp_head +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See PprTyThing.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranch (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) where - -- For *associated* types, say "type T Int = blah" - -- For *top level* type instances, say "type instance T Int = blah" - pp_instance - | isTyConAssoc fam_tc = empty - | otherwise = text "instance" - - (fam_tc, etad_lhs_tys) = famInstSplitLHS fi - vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys - - pp_head | DataFamilyInst rep_tc <- flavor - , isAlgTyCon rep_tc - , let extra_tvs = dropList etad_lhs_tys (tyConTyVars rep_tc) - , not (null extra_tvs) - = getPprStyle $ \ sty -> - if debugStyle sty - then vanilla_pp_head -- With -dppr-debug just show it as-is - else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs) - -- Without -dppr-debug, eta-expand - -- See Trac #8674 - -- (This is probably over the top now that we use this - -- only for internal debug printing; PprTyThing.pprFamInst - -- is used for user-level printing.) - | otherwise - = vanilla_pp_head - - pprTyConSort = case flavor of - SynFamilyInst -> text "type" + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" DataFamilyInst tycon | isDataTyCon tycon -> text "data" | isNewTyCon tycon -> text "newtype" | isAbstractTyCon tycon -> text "data" | otherwise -> text "WEIRD" <+> ppr tycon + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) @@ -668,31 +586,77 @@ computeAxiomIncomps branches Note [Tidy axioms when we build them] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We print out axioms and don't want to print stuff like +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like F k k a b = ... Instead we must tidy those kind variables. See Trac #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +Its misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, during tidying, we always opt to add a +numeric suffix to types that are simply `_`. That way, you instead end +up with: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in CoAxiom -} -- all axiom roles are Nominal, as this is only used with type families mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars -> [CoVar] -- possibly stale covars -> [Type] -- LHS patterns -> Type -- RHS -> [Role] -> SrcSpan -> CoAxBranch -mkCoAxBranch tvs cvs lhs rhs roles loc - = CoAxBranch { cab_tvs = tvs1 - , cab_cvs = cvs1 +mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc + = CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' , cab_lhs = tidyTypes env lhs , cab_roles = roles - , cab_rhs = tidyType env rhs + , cab_rhs = tidyType env rhs , cab_loc = loc , cab_incomps = placeHolderIncomps } where - (env1, tvs1) = tidyVarBndrs emptyTidyEnv tvs - (env, cvs1) = tidyVarBndrs env1 cvs + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in CoAxiom + + init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] -- all of the following code is here to avoid mutual dependencies with -- Coercion @@ -715,12 +679,13 @@ mkUnbranchedCoAxiom ax_name fam_tc branch , co_ax_branches = unbranched (branch { cab_incomps = [] }) } mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type -> CoAxiom Unbranched -- Make a single-branch CoAxiom, incluidng making the branch itself -- Used for both type family (Nominal) and data family (Representational) -- axioms, hence passing in the Role -mkSingleCoAxiom role ax_name tvs cvs fam_tc lhs_tys rhs_ty +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty = CoAxiom { co_ax_unique = nameUnique ax_name , co_ax_name = ax_name , co_ax_tc = fam_tc @@ -728,7 +693,7 @@ mkSingleCoAxiom role ax_name tvs cvs fam_tc lhs_tys rhs_ty , co_ax_implicit = False , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where - branch = mkCoAxBranch tvs cvs lhs_tys rhs_ty + branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty (map (const Nominal) tvs) (getSrcSpan ax_name) @@ -746,7 +711,7 @@ mkNewTypeCoAxiom name tycon tvs roles rhs_ty , co_ax_tc = tycon , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where - branch = mkCoAxBranch tvs [] (mkTyVarTys tvs) rhs_ty + branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty roles (getSrcSpan name) {- diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 37457e9f22..db82deb470 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -55,7 +55,7 @@ module TyCoRep ( delBinderVar, isInvisibleArgFlag, isVisibleArgFlag, isInvisibleBinder, isVisibleBinder, - isTyBinder, + isTyBinder, isNamedBinder, -- * Functions over coercions pickLR, @@ -77,7 +77,8 @@ module TyCoRep ( -- * Free variables tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, - tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, tyCoFVsOfTypes, tyCoVarsOfTypesList, coVarsOfType, coVarsOfTypes, coVarsOfCo, coVarsOfCos, @@ -133,7 +134,7 @@ module TyCoRep ( tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyCoVarOcc, tidyTopType, @@ -541,6 +542,10 @@ isInvisibleBinder (Anon ty) = isPredTy ty isVisibleBinder :: TyCoBinder -> Bool isVisibleBinder = not . isInvisibleBinder +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + -- | If its a named binder, is the binder a tyvar? -- Returns True for nondependent binder. isTyBinder :: TyCoBinder -> Bool @@ -1857,8 +1862,15 @@ tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars tyCoFVsBndr :: TyCoVarBinder -> FV -> FV -- Free vars of (forall b. <thing with fvs>) -tyCoFVsBndr (Bndr tv _) fvs = (delFV tv fvs) - `unionFV` tyCoFVsOfType (varType tv) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside tyCoFVsOfTypes :: [Type] -> FV -- See Note [Free variables of types] @@ -1894,7 +1906,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc - = (delFV tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc @@ -3127,7 +3139,7 @@ pprPrecType = pprPrecTypeX emptyTidyEnv pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc pprPrecTypeX env prec ty = getPprStyle $ \sty -> - if debugStyle sty -- Use pprDebugType when in + if debugStyle sty -- Use debugPprType when in then debug_ppr_ty prec ty -- when in debug-style else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) @@ -3181,7 +3193,6 @@ tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) where env = tidyFreeTyCoVars emptyTidyEnv free_tcvs free_tcvs = scopedSort $ tyCoVarsOfCoList co - ------------ pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = pprTypeApp (classTyCon clas) tys @@ -3269,9 +3280,10 @@ debug_ppr_ty prec (TyConApp tc tys) | otherwise = maybeParen prec appPrec $ hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) -debug_ppr_ty prec (AppTy t1 t2) - = hang (debug_ppr_ty prec t1) - 2 (debug_ppr_ty appPrec t2) +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy debug_ppr_ty prec (CastTy ty co) = maybeParen prec topPrec $ @@ -3378,15 +3390,8 @@ pprWithExplicitKindsWhen b -- -- It doesn't change the uniques at all, just the print names. tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyVarBndrs (occ_env, subst) tvs - = mapAccumL tidyVarBndr tidy_env' tvs - where - -- Seed the occ_env with clashes among the names, see - -- Node [Tidying multiple names at once] in OccName - -- Se still go through tidyVarBndr so that each kind variable is tidied - -- with the correct tidy_env - occs = map getHelpfulOccName tvs - tidy_env' = (avoidClashesOccEnv occ_env occs, subst) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) tidyVarBndr tidy_env@(occ_env, subst) var @@ -3399,21 +3404,28 @@ tidyVarBndr tidy_env@(occ_env, subst) var name' = tidyNameOcc name occ' name = varName var +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Node [Tidying multiple names at once] in OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + getHelpfulOccName :: TyCoVar -> OccName -getHelpfulOccName var = occ1 +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ where - name = varName var - occ = getOccName name - -- A TcTyVar with a System Name is probably a unification variable; - -- when we tidy them we give them a trailing "0" (or 1 etc) - -- so that they don't take precedence for the un-modified name - -- Plus, indicating a unification variable in this way is a - -- helpful clue for users - occ1 | isSystemName name - , isTcTyVar var - = mkTyVarOcc (occNameString occ ++ "0") - | otherwise - = occ + name = varName tv + occ = getOccName name tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis -> (TidyEnv, VarBndr TyCoVar vis) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index a40a02dd2a..eb0b84d47e 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -564,7 +564,7 @@ They fit together like so: Note that that are three binders here, including the kind variable k. -- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep +* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for what the visibility flag means. * Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and @@ -584,10 +584,15 @@ They fit together like so: tyConKind is the full kind of the TyCon, not just the result kind -* tyConArity is the arguments this TyCon must be applied to, to be - considered saturated. Here we mean "applied to in the actual Type", - not surface syntax; i.e. including implicit kind variables. - So it's just (length tyConBinders) +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by etaExpandAlgTyCon -} instance Outputable tv => Outputable (VarBndr tv TyConBndrVis) where diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 26461ee43a..b4c29ce9fb 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -62,15 +62,15 @@ module Type ( coAxNthLHS, stripCoercionTy, splitCoercionType_maybe, - splitPiTysInvisible, filterOutInvisibleTypes, filterOutInferredTypes, + splitPiTysInvisible, splitPiTysInvisibleN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, tyConArgFlags, appTyArgFlags, synTyConResKind, modifyJoinResTy, setJoinResTy, - etaExpandFamInst, - -- Analyzing types TyCoMapper(..), mapType, mapCoercion, @@ -104,7 +104,8 @@ module Type ( tyCoBinderType, tyCoBinderVar_maybe, tyBinderType, binderRelevantType_maybe, caseBinder, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder, + isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, + isInvisibleBinder, isNamedBinder, tyConBindersTyCoBinders, -- ** Common type constructors @@ -138,7 +139,7 @@ module Type ( liftedTypeKind, -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeDSet, coVarsOfType, @@ -1338,8 +1339,7 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. ~~~~~~~~ -} --- | Make a dependent forall over an Inferred (as opposed to Specified) --- variable +-- | Make a dependent forall over an Inferred variablem mkTyCoInvForAllTy :: TyCoVar -> Type -> Type mkTyCoInvForAllTy tv ty | isCoVar tv @@ -1362,7 +1362,7 @@ mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs mkInvForAllTys :: [TyVar] -> Type -> Type mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs --- | Like mkForAllTys, but assumes all variables are dependent and specified, +-- | Like mkForAllTys, but assumes all variables are dependent and Specified, -- a common case mkSpecForAllTys :: [TyVar] -> Type -> Type mkSpecForAllTys tvs = ASSERT( all isTyVar tvs ) @@ -1401,12 +1401,12 @@ mkLamTypes vs ty = foldr mkLamType ty vs -- We want (k:*) Named, (b:k) Anon, (c:k) Anon -- -- All non-coercion binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_ty = ASSERT( all isTyVar vars) - fst (go vars) +mkTyConBindersPreferAnon :: [TyVar] -> TyCoVarSet -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) + fst (go vars) where go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], tyCoVarsOfType inner_ty) + go [] = ([], inner_tkvs) go (v:vs) | v `elemVarSet` fvs = ( Bndr v (NamedTCB Required) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) @@ -1437,15 +1437,6 @@ splitTyVarForAllTys ty = split ty ty [] split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) split orig_ty _ tvs = (reverse tvs, orig_ty) --- | Like 'splitPiTys' but split off only /named/ binders. -splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) -splitForAllVarBndrs ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllVarBndrs #-} - -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' @@ -1529,26 +1520,59 @@ splitPiTy ty -- | Split off all TyCoBinders to a type, splitting both proper foralls -- and functions splitPiTys :: Type -> ([TyCoBinder], Type) -splitPiTys ty = split ty ty +splitPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy arg res) bs = split res res (Anon arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders +-- and returns TyCoVarBinders rather than TyCoBinders +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] where - split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' - split _ (ForAllTy b res) = let (bs, ty) = split res res - in (Named b : bs, ty) - split _ (FunTy arg res) = let (bs, ty) = split res res - in (Anon arg : bs, ty) - split orig_ty _ = ([], orig_ty) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllVarBndrs #-} + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) -- Like splitPiTys, but returns only *invisible* binders, including constraints -- Stops at the first visible binder splitPiTysInvisible :: Type -> ([TyCoBinder], Type) splitPiTysInvisible ty = split ty ty [] where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b@(Bndr _ vis) res) bs - | isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy arg res) bs - | isPredTy arg = split res res (Anon arg : bs) - split orig_ty _ bs = (reverse bs, orig_ty) + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleArgFlag vis = split res res (Named b : bs) + split _ (FunTy arg res) bs + | isPredTy arg = split res res (Anon arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) +-- Same as splitPiTysInvisible, but stop when +-- - you have found 'n' TyCoBinders, +-- - or you run out of invisible binders +splitPiTysInvisibleN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) + | FunTy arg res <- ty + , isPredTy arg = split (n-1) res res (Anon arg : bs) + | otherwise = (reverse bs, orig_ty) -- | Given a 'TyCon' and a list of argument types, filter out any invisible -- (i.e., 'Inferred' or 'Specified') arguments. @@ -3053,40 +3077,6 @@ setJoinResTy :: Int -- Number of binders to skip setJoinResTy ar new_res_ty ty = modifyJoinResTy ar (const new_res_ty) ty --- | Given a data or type family instance's type variables, left-hand side --- types, and right-hand side type, either: --- --- * Return the eta-expanded type variables, left-hand types, and right-hand --- type (if dealing with a data family instance). This function obtains the --- eta-reduced variables from the instance's representation 'TyCon' (which --- heads the right-hand type). --- --- * Just return the type variables, left-hand types, and right-hand type --- (if dealing with a type family instance). --- --- For an explanation of why data family instances need to be eta expanded, see --- @Note [Eta reduction for data families]@ in "FamInstEnv". - --- NB: In an ideal world, this would live in FamInstEnv, but this function --- is used in Coercion (which FamInstEnv imports), so doing so would lead to --- an import cycle. -etaExpandFamInst - :: [TyVar] -- ^ The type variables - -> [Type] -- ^ The left-hand side types - -> Type -- ^ The right-hand side type - -> ([TyVar], [Type], Type) -etaExpandFamInst tvs lhs rhs - | Just (tycon, tc_args) <- splitTyConApp_maybe rhs - , isFamInstTyCon tycon - = let tc_tvs = tyConTyVars tycon - etad_tvs = dropList tc_args tc_tvs - etad_tys = mkTyVarTys etad_tvs - eta_expanded_tvs = tvs `chkAppend` etad_tvs - eta_expanded_lhs = lhs `chkAppend` etad_tys - eta_expanded_rhs = mkAppTys rhs etad_tys - in (eta_expanded_tvs, eta_expanded_lhs, eta_expanded_rhs) - | otherwise - = (tvs, lhs, rhs) {- %************************************************************************ diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index c88f92f6ed..84fbaca6f7 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -11,8 +11,8 @@ import Util isPredTy :: Type -> Bool isCoercionTy :: Type -> Bool -mkAppTy :: Type -> Type -> Type -mkCastTy :: Type -> Coercion -> Type +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type eqType :: Type -> Type -> Bool diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 62d53dc60a..1e5406db2e 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -8,7 +8,7 @@ module Unify ( tcMatchTy, tcMatchTyKi, tcMatchTys, tcMatchTyKis, tcMatchTyX, tcMatchTysX, tcMatchTyKisX, - ruleMatchTyKiX, + tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching roughMatchTcs, instanceCantMatch, @@ -115,11 +115,17 @@ How do you choose between them? tcMatchTy :: Type -> Type -> Maybe TCvSubst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] +tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst + -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM bind_me subst ty1 ty2 + = tc_match_tys_x bind_me False subst [ty1] [ty2] + -- | Like 'tcMatchTy', but allows the kinds of the types to differ, -- and thus matches them as well. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKi :: Type -> Type -> Maybe TCvSubst -tcMatchTyKi ty1 ty2 = tcMatchTyKis [ty1] [ty2] +tcMatchTyKi ty1 ty2 + = tc_match_tys (const BindMe) True [ty1] [ty2] -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -127,7 +133,8 @@ tcMatchTyX :: TCvSubst -- ^ Substitution to extend -> Type -- ^ Template -> Type -- ^ Target -> Maybe TCvSubst -tcMatchTyX subst ty1 ty2 = tcMatchTysX subst [ty1] [ty2] +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] -- | Like 'tcMatchTy' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -136,9 +143,7 @@ tcMatchTys :: [Type] -- ^ Template -> Maybe TCvSubst -- ^ One-shot; in principle the template -- variables could be free in the target tcMatchTys tys1 tys2 - = tcMatchTysX (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + = tc_match_tys (const BindMe) False tys1 tys2 -- | Like 'tcMatchTyKi' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -146,9 +151,7 @@ tcMatchTyKis :: [Type] -- ^ Template -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTyKis tys1 tys2 - = tcMatchTyKisX (mkEmptyTCvSubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + = tc_match_tys (const BindMe) True tys1 tys2 -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -157,7 +160,7 @@ tcMatchTysX :: TCvSubst -- ^ Substitution to extend -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2 - = tc_match_tys_x False subst tys1 tys2 + = tc_match_tys_x (const BindMe) False subst tys1 tys2 -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] @@ -166,16 +169,28 @@ tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x True subst tys1 tys2 + = tc_match_tys_x (const BindMe) True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' -tc_match_tys_x :: Bool -- ^ match kinds? +tc_match_tys_x :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? -> TCvSubst -> [Type] -> [Type] -> Maybe TCvSubst -tc_match_tys_x match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 - = case tc_unify_tys (const BindMe) +tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + = case tc_unify_tys bind_me False -- Matching, not unifying False -- Not an injectivity check match_kis diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs index f9fbeb0e6e..588486bf46 100644 --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -71,6 +71,7 @@ module FastString concatFS, consFS, nilFS, + isUnderscoreFS, -- ** Outputing hPutFS, @@ -603,6 +604,9 @@ uniqueOfFS (FastString u _ _ _) = u nilFS :: FastString nilFS = mkFastString "" +isUnderscoreFS :: FastString -> Bool +isUnderscoreFS fs = fs == fsLit "_" + -- ----------------------------------------------------------------------------- -- Stats diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 84799aed0b..0c7bb4a189 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -30,7 +30,7 @@ module Util ( dropWhileEndLE, spanEnd, last2, - foldl1', foldl2, count, all2, + foldl1', foldl2, count, countWhile, all2, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -705,6 +705,12 @@ count p = go 0 go !n (x:xs) | p x = go (n+1) xs | otherwise = go n xs +countWhile :: (a -> Bool) -> [a] -> Int +-- Length of an /initial prefix/ of the list satsifying p +countWhile p = go 0 + where go !n (x:xs) | p x = go (n+1) xs + go !n _ = n + {- @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: diff --git a/testsuite/tests/dependent/should_compile/T15743.stderr b/testsuite/tests/dependent/should_compile/T15743.stderr index 7162a877a2..f44c430d8d 100644 --- a/testsuite/tests/dependent/should_compile/T15743.stderr +++ b/testsuite/tests/dependent/should_compile/T15743.stderr @@ -1,6 +1,6 @@ TYPE CONSTRUCTORS type role T nominal nominal nominal phantom phantom phantom - T :: forall {k1} k2 (k3 :: k2). Proxy k3 -> k1 -> k2 -> * + T{6} :: forall {k1} k2 (k3 :: k2). Proxy k3 -> k1 -> k2 -> * Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/dependent/should_compile/T15743e.stderr b/testsuite/tests/dependent/should_compile/T15743e.stderr index c77bf3849c..f96da68a7f 100644 --- a/testsuite/tests/dependent/should_compile/T15743e.stderr +++ b/testsuite/tests/dependent/should_compile/T15743e.stderr @@ -1,7 +1,7 @@ TYPE CONSTRUCTORS type role T nominal nominal nominal nominal nominal nominal phantom phantom representational nominal nominal phantom nominal phantom - T :: + T{14} :: forall {k1} {k2} {k3} (k4 :: k2) k5. forall k6 -> k6 -> Proxy k4 @@ -10,13 +10,13 @@ TYPE CONSTRUCTORS -> forall (k7 :: k1). Proxy k7 -> forall (k8 :: k5). Proxy k8 -> * type role T2 nominal nominal nominal nominal nominal phantom phantom representational nominal nominal phantom nominal nominal phantom - T2 :: - forall {k1} {k2} (k3 :: k1) k7. forall k4 -> + T2{14} :: + forall {k1} {k2} (k3 :: k2) k7. forall k4 -> k4 -> Proxy k3 -> (k7 -> *) -> k7 - -> forall (k5 :: k2). + -> forall (k5 :: k1). Proxy k5 -> forall k6 (k8 :: k6). Proxy k8 -> * DATA CONSTRUCTORS MkT2 :: forall {k7} {k1} {k2 :: k1} {k3} {k4 :: k3} {k5} {k6 :: k5} diff --git a/testsuite/tests/dependent/should_fail/BadTelescope.stderr b/testsuite/tests/dependent/should_fail/BadTelescope.stderr index 5fa8efd502..078d7377da 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope.stderr @@ -1,6 +1,7 @@ BadTelescope.hs:9:1: error: - • These kind and type variables: a k (b :: k) (c :: SameKind a b) - are out of dependency order. Perhaps try this ordering: - k (a :: k) (b :: k) (c :: SameKind a b) + • The kind of ‘X’ is ill-scoped + Inferred kind: X :: forall (a :: k) k (b :: k) -> SameKind a b -> * + Perhaps try this order instead: + k (a :: k) (b :: k) (c :: SameKind a b) • In the data type declaration for ‘X’ diff --git a/testsuite/tests/dependent/should_fail/BadTelescope3.stderr b/testsuite/tests/dependent/should_fail/BadTelescope3.stderr index 1137f28c4d..c36ad07c42 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope3.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope3.stderr @@ -1,6 +1,6 @@ BadTelescope3.hs:9:1: error: - • These kind and type variables: a k (b :: k) - are out of dependency order. Perhaps try this ordering: - k (a :: k) (b :: k) + • The kind of ‘S’ is ill-scoped + Inferred kind: S :: k -> forall k -> k -> * + Perhaps try this order instead: k (a :: k) (b :: k) • In the type synonym declaration for ‘S’ diff --git a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr index f7c281e983..039389bed0 100644 --- a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr +++ b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr @@ -1,15 +1,16 @@ BadTelescope4.hs:9:1: error: - • These kind and type variables: a - (c :: Proxy b) - (d :: Proxy a) - (x :: SameKind b d) - are out of dependency order. Perhaps try this ordering: + • The kind of ‘Bad’ is ill-scoped + Inferred kind: Bad :: forall k (b :: Proxy a). forall (a :: k) -> + Proxy b -> forall (d :: Proxy a) -> SameKind b d -> * + NB: Inferred variables + (namely: k) always come first + then Specified variables (namely: (b :: Proxy a)) + Perhaps try this order instead: k (a :: k) (b :: Proxy a) (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - NB: Implicitly declared variables come before others. • In the data type declaration for ‘Bad’ diff --git a/testsuite/tests/dependent/should_fail/T13895.stderr b/testsuite/tests/dependent/should_fail/T13895.stderr index 3ced11a79d..adfebdd113 100644 --- a/testsuite/tests/dependent/should_fail/T13895.stderr +++ b/testsuite/tests/dependent/should_fail/T13895.stderr @@ -1,38 +1,7 @@ -T13895.hs:8:14: error: - • Could not deduce (Typeable (t dict)) - from the context: (Data a, Typeable (t dict)) - bound by the type signature for: - dataCast1 :: forall k1 a (c :: * -> *) (t :: forall k2. - Typeable k2 => - k2 -> *). - (Data a, Typeable (t dict)) => - (forall d. Data d => c (t dict1 d)) -> Maybe (c a) - at T13895.hs:(8,14)-(14,24) - The type variable ‘k0’ is ambiguous - • In the ambiguity check for ‘dataCast1’ - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature: - dataCast1 :: forall (a :: Type). - Data a => - forall (c :: Type -> Type) - (t :: forall (k :: Type). Typeable k => k -> Type). - Typeable t => (forall d. Data d => c (t d)) -> Maybe (c a) - -T13895.hs:12:23: error: - • Illegal constraint in a kind: Typeable k0 - • In the first argument of ‘Typeable’, namely ‘t’ - In the type signature: - dataCast1 :: forall (a :: Type). - Data a => - forall (c :: Type -> Type) - (t :: forall (k :: Type). Typeable k => k -> Type). - Typeable t => (forall d. Data d => c (t d)) -> Maybe (c a) - -T13895.hs:13:38: error: - • Illegal constraint in a kind: Typeable k0 - • In the first argument of ‘c’, namely ‘(t d)’ - In the type signature: +T13895.hs:10:14: error: + • Illegal constraint in a kind: forall k. Typeable k => k -> * + • In the type signature: dataCast1 :: forall (a :: Type). Data a => forall (c :: Type -> Type) diff --git a/testsuite/tests/dependent/should_fail/T14066f.stderr b/testsuite/tests/dependent/should_fail/T14066f.stderr index 44c4ed293c..10aa1b9da4 100644 --- a/testsuite/tests/dependent/should_fail/T14066f.stderr +++ b/testsuite/tests/dependent/should_fail/T14066f.stderr @@ -1,6 +1,6 @@ T14066f.hs:8:1: error: - • These kind and type variables: a k - are out of dependency order. Perhaps try this ordering: - k (a :: k) + • The kind of ‘P’ is ill-scoped + Inferred kind: P :: k -> forall k -> * + Perhaps try this order instead: k (a :: k) • In the type synonym declaration for ‘P’ diff --git a/testsuite/tests/dependent/should_fail/T14066g.stderr b/testsuite/tests/dependent/should_fail/T14066g.stderr index 22ca786343..23f0a4c9d0 100644 --- a/testsuite/tests/dependent/should_fail/T14066g.stderr +++ b/testsuite/tests/dependent/should_fail/T14066g.stderr @@ -1,7 +1,9 @@ T14066g.hs:9:1: error: - • These kind and type variables: a (b :: a) (d :: SameKind c b) - are out of dependency order. Perhaps try this ordering: + • The kind of ‘Q’ is ill-scoped + Inferred kind: Q :: forall (c :: a). forall a (b :: a) -> + SameKind c b -> * + NB: Specified variables (namely: (c :: a)) always come first + Perhaps try this order instead: a (c :: a) (b :: a) (d :: SameKind c b) - NB: Implicitly declared variables come before others. • In the data type declaration for ‘Q’ diff --git a/testsuite/tests/dependent/should_fail/T15591b.stderr b/testsuite/tests/dependent/should_fail/T15591b.stderr index 838ee51c8f..91d9a948f4 100644 --- a/testsuite/tests/dependent/should_fail/T15591b.stderr +++ b/testsuite/tests/dependent/should_fail/T15591b.stderr @@ -1,7 +1,8 @@ T15591b.hs:9:3: error: - • These kind and type variables: a c - are out of dependency order. Perhaps try this ordering: - a (b :: Proxy a) (c :: Proxy b) - NB: Implicitly declared variables come before others. + • The kind of ‘T4’ is ill-scoped + Inferred kind: T4 :: forall (b :: Proxy a). forall a -> + Proxy b -> * + NB: Inferred variables (namely: (b :: Proxy a)) always come first + Perhaps try this order instead: a (b :: Proxy a) (c :: Proxy b) • In the associated type family declaration for ‘T4’ diff --git a/testsuite/tests/dependent/should_fail/T15591c.stderr b/testsuite/tests/dependent/should_fail/T15591c.stderr index 2f2b47fc8d..ecaa66048c 100644 --- a/testsuite/tests/dependent/should_fail/T15591c.stderr +++ b/testsuite/tests/dependent/should_fail/T15591c.stderr @@ -1,7 +1,8 @@ T15591c.hs:9:3: error: - • These kind and type variables: c a - are out of dependency order. Perhaps try this ordering: - a (b :: Proxy a) (c :: Proxy b) - NB: Implicitly declared variables come before others. + • The kind of ‘T5’ is ill-scoped + Inferred kind: T5 :: forall (b :: Proxy a). + Proxy b -> forall a -> * + NB: Inferred variables (namely: (b :: Proxy a)) always come first + Perhaps try this order instead: a (b :: Proxy a) (c :: Proxy b) • In the associated type family declaration for ‘T5’ diff --git a/testsuite/tests/dependent/should_fail/T15743c.stderr b/testsuite/tests/dependent/should_fail/T15743c.stderr index 9d28b68998..8e3ad5077f 100644 --- a/testsuite/tests/dependent/should_fail/T15743c.stderr +++ b/testsuite/tests/dependent/should_fail/T15743c.stderr @@ -1,16 +1,15 @@ T15743c.hs:10:1: error: - • These kind and type variables: k - (c :: k) - (a :: Proxy c) - b - (x :: SimilarKind a b) - are out of dependency order. Perhaps try this ordering: + • The kind of ‘T’ is ill-scoped + Inferred kind: T :: forall (d :: k). + forall k (c :: k) (a :: Proxy c) (b :: Proxy d) -> + SimilarKind a b -> * + NB: Inferred variables (namely: (d :: k)) always come first + Perhaps try this order instead: k (d :: k) (c :: k) (a :: Proxy c) (b :: Proxy d) (x :: SimilarKind a b) - NB: Implicitly declared variables come before others. • In the data type declaration for ‘T’ diff --git a/testsuite/tests/dependent/should_fail/T15743d.stderr b/testsuite/tests/dependent/should_fail/T15743d.stderr index d982d16980..51d1fad66f 100644 --- a/testsuite/tests/dependent/should_fail/T15743d.stderr +++ b/testsuite/tests/dependent/should_fail/T15743d.stderr @@ -1,16 +1,15 @@ T15743d.hs:10:1: error: - • These kind and type variables: k - (c :: k) - (a :: Proxy c) - (b :: Proxy d) - (x :: SimilarKind a b) - are out of dependency order. Perhaps try this ordering: + • The kind of ‘T2’ is ill-scoped + Inferred kind: T2 :: forall (d :: k). + forall k (c :: k) (a :: Proxy c) (b :: Proxy d) -> + SimilarKind a b -> * + NB: Specified variables (namely: (d :: k)) always come first + Perhaps try this order instead: k (d :: k) (c :: k) (a :: Proxy c) (b :: Proxy d) (x :: SimilarKind a b) - NB: Implicitly declared variables come before others. • In the data type declaration for ‘T2’ diff --git a/testsuite/tests/ghci/scripts/T10059.stdout b/testsuite/tests/ghci/scripts/T10059.stdout index 92fbb45ef7..955c95a966 100644 --- a/testsuite/tests/ghci/scripts/T10059.stdout +++ b/testsuite/tests/ghci/scripts/T10059.stdout @@ -1,4 +1,4 @@ -class (a ~ b) => (~) (a :: k0) (b :: k0) -- Defined in ‘GHC.Types’ -(~) :: k0 -> k0 -> Constraint -class (a GHC.Prim.~# b) => (~) (a :: k0) (b :: k0) +class (a ~ b) => (~) (a :: k) (b :: k) -- Defined in ‘GHC.Types’ +(~) :: k -> k -> Constraint +class (a GHC.Prim.~# b) => (~) (a :: k) (b :: k) -- Defined in ‘GHC.Types’ diff --git a/testsuite/tests/ghci/scripts/T15591.hs b/testsuite/tests/ghci/scripts/T15591.hs index f333fe0194..a27f8f0269 100644 --- a/testsuite/tests/ghci/scripts/T15591.hs +++ b/testsuite/tests/ghci/scripts/T15591.hs @@ -13,11 +13,15 @@ class C (a :: Type) where type T2 (x :: f a) class C2 (a :: Type) (b :: Proxy a) (c :: Proxy b) where - type T3 (x :: Proxy '(a, c)) + type T3 (x :: Proxy '(a, (c :: Proxy b))) + -- NB: we have to put (c :: Proxy b) so that 'b' is Specified + -- in the kind of T3; else 'b' is Inferred and comes + -- first, which is ill-scoped -- no CUSK class C3 (a :: Type) (b :: Proxy a) (c :: Proxy b) d where - type T4 (x :: Proxy '(a, c)) + type T4 (x :: Proxy '(a, (c :: Proxy b))) + -- Ditto to T3 class C4 (a :: Type) b where type T5 (x :: f a) diff --git a/testsuite/tests/ghci/scripts/T15591.stdout b/testsuite/tests/ghci/scripts/T15591.stdout index b4673d5174..b0d4f8b34d 100644 --- a/testsuite/tests/ghci/scripts/T15591.stdout +++ b/testsuite/tests/ghci/scripts/T15591.stdout @@ -1,6 +1,6 @@ T1 :: forall (f :: * -> *) a. f a -> * -T2 :: forall a (f :: * -> *). f a -> * +T2 :: forall (f :: * -> *) a. f a -> * T3 :: forall a (b :: Proxy a) (c :: Proxy b). Proxy '(a, c) -> * T4 :: forall a (b :: Proxy a) (c :: Proxy b). Proxy '(a, c) -> * -T5 :: forall a (f :: * -> *). f a -> * -T6 :: forall {k} (a :: k) (f :: k -> *). f a -> * +T5 :: forall (f :: * -> *) a. f a -> * +T6 :: forall {k} (f :: k -> *) (a :: k). f a -> * diff --git a/testsuite/tests/ghci/scripts/T15743b.stdout b/testsuite/tests/ghci/scripts/T15743b.stdout index 03e593e5bd..2850a685fc 100644 --- a/testsuite/tests/ghci/scripts/T15743b.stdout +++ b/testsuite/tests/ghci/scripts/T15743b.stdout @@ -1 +1 @@ -F :: forall k k2. k -> k2 -> * +F :: forall {k} k2. k -> k2 -> * diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr index 15e19cf105..c6698d2944 100644 --- a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr +++ b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr @@ -39,9 +39,9 @@ <interactive>:55:41: error: Type family equation violates injectivity annotation. - Kind variable ‘k2’ cannot be inferred from the right-hand side. + Kind variable ‘k1’ cannot be inferred from the right-hand side. In the type family equation: - PolyKindVarsF @{[k2]} @[k1] ('[] @k2) = '[] @k1 + PolyKindVarsF @{[k1]} @[k2] ('[] @k1) = '[] @k2 -- Defined at <interactive>:55:41 <interactive>:60:15: error: diff --git a/testsuite/tests/ghci/scripts/T7873.stderr b/testsuite/tests/ghci/scripts/T7873.stderr index 731a216a1a..b4759714c2 100644 --- a/testsuite/tests/ghci/scripts/T7873.stderr +++ b/testsuite/tests/ghci/scripts/T7873.stderr @@ -5,4 +5,4 @@ of its type variables. Perhaps you meant to bind it explicitly somewhere? Type variables with inferred kinds: (k :: *) - • In the data declaration for ‘D1’ + • In the data type declaration for ‘D1’ diff --git a/testsuite/tests/ghci/scripts/ghci059.stdout b/testsuite/tests/ghci/scripts/ghci059.stdout index 9e9adb9ff1..7e734f1ccc 100644 --- a/testsuite/tests/ghci/scripts/ghci059.stdout +++ b/testsuite/tests/ghci/scripts/ghci059.stdout @@ -4,6 +4,6 @@ It is not a class. Please see section 9.14.4 of the user's guide for details. -} type role Coercible representational representational -class Coercible a b => Coercible (a :: k0) (b :: k0) +class Coercible a b => Coercible (a :: k) (b :: k) -- Defined in ‘GHC.Types’ coerce :: Coercible a b => a -> b -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/indexed-types/should_compile/T15711.stderr b/testsuite/tests/indexed-types/should_compile/T15711.stderr index 1d23612cfc..2a012489e7 100644 --- a/testsuite/tests/indexed-types/should_compile/T15711.stderr +++ b/testsuite/tests/indexed-types/should_compile/T15711.stderr @@ -1,7 +1,7 @@ TYPE CONSTRUCTORS - C :: * -> Constraint + C{1} :: * -> Constraint type role F nominal nominal - F :: forall a. Maybe a -> * + F{2} :: forall a. Maybe a -> * Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/indexed-types/should_compile/T15740a.hs b/testsuite/tests/indexed-types/should_compile/T15740a.hs new file mode 100644 index 0000000000..2d79a99878 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T15740a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeInType, RankNTypes, TypeFamilies #-} + +module T15740a where + +import Data.Kind +import Data.Proxy + +type family F2 :: forall k. k -> Type + +-- This should succeed +type instance F2 = Proxy + diff --git a/testsuite/tests/indexed-types/should_compile/T15764a.hs b/testsuite/tests/indexed-types/should_compile/T15764a.hs new file mode 100644 index 0000000000..91d348bd96 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T15764a.hs @@ -0,0 +1,14 @@ +{-# Language PolyKinds #-} +{-# Language TypeFamilies #-} +{-# Language KindSignatures #-} +{-# Language DataKinds #-} +{-# Language MultiParamTypeClasses #-} + +module T15764a where + +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +class C6 (k :: Type) (a :: k) (b :: Proxy (a :: k)) where + type T6 (proxy :: Proxy '(k, (b :: Proxy a))) diff --git a/testsuite/tests/indexed-types/should_compile/T15852.stderr b/testsuite/tests/indexed-types/should_compile/T15852.stderr index bc5fd2a72e..6908d000ab 100644 --- a/testsuite/tests/indexed-types/should_compile/T15852.stderr +++ b/testsuite/tests/indexed-types/should_compile/T15852.stderr @@ -1,13 +1,14 @@ TYPE CONSTRUCTORS type role DF nominal nominal nominal - DF :: forall k. * -> k -> * + DF{3} :: forall k. * -> k -> * COERCION AXIOMS axiom T15852.D:R:DFProxyProxy0 :: - forall k1 k2 (c :: k1) (j :: k2) (a :: Proxy j). - DF (Proxy c) a = T15852.R:DFProxyProxy k1 k2 c j a - -- Defined at T15852.hs:10:15 + forall k1 k2 (j :: k1) (c :: k2). + DF (Proxy c) = T15852.R:DFProxyProxy k1 k2 j c FAMILY INSTANCES - data instance DF (Proxy c) c j a + data instance forall k1 k2 (j :: k1) (c :: k2). + DF (Proxy c) = T15852.R:DFProxyProxy k1 k2 j c + -- Defined at T15852.hs:10:15 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 3b4361a2a5..9cf31965a4 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -5,19 +5,18 @@ TYPE SIGNATURES test2 :: forall c a b. (Coll c, Num a, Num b, Elem c ~ (a, b)) => c -> c TYPE CONSTRUCTORS - Coll :: * -> Constraint + Coll{1} :: * -> Constraint type role Elem nominal - Elem :: * -> * - ListColl :: * -> * + Elem{1} :: * -> * + ListColl{1} :: * -> * COERCION AXIOMS - axiom Foo.D:R:ElemListColl :: - Elem (ListColl a) = a -- Defined at T3017.hs:13:9 + axiom Foo.D:R:ElemListColl :: Elem (ListColl a) = a DATA CONSTRUCTORS L :: forall a. [a] -> ListColl a CLASS INSTANCES instance Coll (ListColl a) -- Defined at T3017.hs:12:11 FAMILY INSTANCES - type Elem (ListColl a) + type instance Elem (ListColl a) = a -- Defined at T3017.hs:13:9 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 409e1efce1..484d843672 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -298,3 +298,5 @@ test('T15943', normal, compile, ['']) test('T15704', normal, compile, ['']) test('T15711', normal, compile, ['-ddump-types']) test('T15852', normal, compile, ['-ddump-types']) +test('T15764a', normal, compile, ['']) +test('T15740a', normal, compile, ['']) diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr index ecbd7d9e79..776ee19592 100644 --- a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr +++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr @@ -1,8 +1,12 @@ ExplicitForAllFams4a.hs:7:12: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ - • In the type family declaration for ‘H’ + • Type variable ‘b’ is bound by a forall, + but not used in the family instance + • In the equations for closed type family ‘H’ + In the type family declaration for ‘H’ ExplicitForAllFams4a.hs:8:10: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ - • In the type family declaration for ‘H’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance + • In the equations for closed type family ‘H’ + In the type family declaration for ‘H’ diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs index cb5665401b..c488f45a65 100644 --- a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs +++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs @@ -22,5 +22,6 @@ class C a where instance C Int where type forall a b. CT [a] (a,a) = Float type forall b. CT _ _ = Maybe b + data forall a b. CD [a] (a,a) = CD5 Float data forall b. CD _ _ = CD6 (Maybe b) diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr index 0861a8a756..8e268d6301 100644 --- a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr +++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr @@ -1,44 +1,107 @@ ExplicitForAllFams4b.hs:7:24: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is bound by a forall, + but not used in the family instance • In the type instance declaration for ‘J’ +ExplicitForAllFams4b.hs:7:27: error: + Conflicting family instance declarations: + J [a] = Float -- Defined at ExplicitForAllFams4b.hs:7:27 + J _ = Maybe b -- Defined at ExplicitForAllFams4b.hs:8:27 + ExplicitForAllFams4b.hs:8:22: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the type instance declaration for ‘J’ ExplicitForAllFams4b.hs:11:24: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the data instance declaration for ‘K’ +ExplicitForAllFams4b.hs:11:27: error: + Conflicting family instance declarations: + K (a, Bool) -- Defined at ExplicitForAllFams4b.hs:11:27 + K _ -- Defined at ExplicitForAllFams4b.hs:12:27 + ExplicitForAllFams4b.hs:12:22: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the data instance declaration for ‘K’ ExplicitForAllFams4b.hs:15:27: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the newtype instance declaration for ‘L’ +ExplicitForAllFams4b.hs:15:30: error: + Conflicting family instance declarations: + L (a, Bool) -- Defined at ExplicitForAllFams4b.hs:15:30 + L _ -- Defined at ExplicitForAllFams4b.hs:16:30 + ExplicitForAllFams4b.hs:16:25: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the newtype instance declaration for ‘L’ +ExplicitForAllFams4b.hs:23:3: error: + • Type indexes must match class instance head + Expected: CT Int _ + Actual: CT [a] (a, a) -- Defined at ExplicitForAllFams4b.hs:23:20 + • In the type instance declaration for ‘CT’ + In the instance declaration for ‘C Int’ + ExplicitForAllFams4b.hs:23:17: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is bound by a forall, + but not used in the family instance + • In the type instance declaration for ‘CT’ + In the instance declaration for ‘C Int’ + +ExplicitForAllFams4b.hs:23:20: error: + Conflicting family instance declarations: + CT [a] (a, a) = Float -- Defined at ExplicitForAllFams4b.hs:23:20 + CT _ _ = Maybe b -- Defined at ExplicitForAllFams4b.hs:24:20 + +ExplicitForAllFams4b.hs:24:3: error: + • Type indexes must match class instance head + Expected: CT Int _ + Actual: CT _ _ -- Defined at ExplicitForAllFams4b.hs:24:20 • In the type instance declaration for ‘CT’ In the instance declaration for ‘C Int’ ExplicitForAllFams4b.hs:24:15: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the type instance declaration for ‘CT’ In the instance declaration for ‘C Int’ -ExplicitForAllFams4b.hs:25:17: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ +ExplicitForAllFams4b.hs:26:3: error: + • Type indexes must match class instance head + Expected: CD Int _ + Actual: CD [a] (a, a) -- Defined at ExplicitForAllFams4b.hs:26:20 + • In the data instance declaration for ‘CD’ + In the instance declaration for ‘C Int’ + +ExplicitForAllFams4b.hs:26:17: error: + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance + • In the data instance declaration for ‘CD’ + In the instance declaration for ‘C Int’ + +ExplicitForAllFams4b.hs:26:20: error: + Conflicting family instance declarations: + CD [a] (a, a) -- Defined at ExplicitForAllFams4b.hs:26:20 + CD _ _ -- Defined at ExplicitForAllFams4b.hs:27:20 + +ExplicitForAllFams4b.hs:27:3: error: + • Type indexes must match class instance head + Expected: CD Int _ + Actual: CD _ _ -- Defined at ExplicitForAllFams4b.hs:27:20 • In the data instance declaration for ‘CD’ In the instance declaration for ‘C Int’ -ExplicitForAllFams4b.hs:26:15: error: - • Explicitly quantified but not used in LHS pattern: type variable ‘b’ +ExplicitForAllFams4b.hs:27:15: error: + • Type variable ‘b’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the data instance declaration for ‘CD’ In the instance declaration for ‘C Int’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail13.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail13.stderr index cfbab576b9..eb54cf2e11 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail13.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail13.stderr @@ -1,5 +1,5 @@ -SimpleFail13.hs:9:1: error: +SimpleFail13.hs:9:15: error: • Illegal type synonym family application ‘C a’ in instance: D [C a] • In the data instance declaration for ‘D’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail2a.hs b/testsuite/tests/indexed-types/should_fail/SimpleFail2a.hs index fc773af0ff..7d78a15baa 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail2a.hs +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail2a.hs @@ -8,7 +8,7 @@ class C a where type St a :: * instance C Int where - data Sd a :: * -- Looks like a nullary data instance decl + data Sd a = MkSd -- :: * -- Looks like a nullary data instance decl data Sd Int = SdC Char newtype Sn Int = SnC Char type St Int = Char diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail2a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail2a.stderr index 9bd571e2b9..b21375ceb2 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail2a.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail2a.stderr @@ -2,6 +2,11 @@ SimpleFail2a.hs:11:3: error: • Type indexes must match class instance head Expected: Sd Int - Actual: Sd a :: * + Actual: Sd a -- Defined at SimpleFail2a.hs:11:11 • In the data instance declaration for ‘Sd’ In the instance declaration for ‘C Int’ + +SimpleFail2a.hs:11:11: error: + Conflicting family instance declarations: + Sd a -- Defined at SimpleFail2a.hs:11:11 + Sd Int -- Defined at SimpleFail2a.hs:12:11 diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs b/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs index 9c1c4a82d2..0f20f78e95 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail9.hs @@ -2,8 +2,10 @@ module ShouldFail where +import Data.Kind + class C7 a b where - data S7 b :: * + data S7 b :: Type instance C7 Char (a, Bool) where data S7 (a, Bool) = S7_1 diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail9.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail9.stderr index b0c421fce8..b3dd8ef839 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail9.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail9.stderr @@ -1,7 +1,7 @@ -SimpleFail9.hs:14:3: error: +SimpleFail9.hs:16:3: error: • Type indexes must match class instance head Expected: S7 (a, Int) - Actual: S7 (b, Int) + Actual: S7 (b, Int) -- Defined at SimpleFail9.hs:16:8 • In the data instance declaration for ‘S7’ In the instance declaration for ‘C7 Char (a, Int)’ diff --git a/testsuite/tests/indexed-types/should_fail/T10817.stderr b/testsuite/tests/indexed-types/should_fail/T10817.stderr index 715febdc25..af8acae33a 100644 --- a/testsuite/tests/indexed-types/should_fail/T10817.stderr +++ b/testsuite/tests/indexed-types/should_fail/T10817.stderr @@ -1,6 +1,7 @@ T10817.hs:9:3: error: - The type family application ‘F a’ - is no smaller than the instance head ‘F a’ - (Use UndecidableInstances to permit this) - In the class declaration for ‘C’ + • The type family application ‘F a’ + is no smaller than the instance head ‘F a’ + (Use UndecidableInstances to permit this) + • In the default type instance declaration for ‘F’ + In the class declaration for ‘C’ diff --git a/testsuite/tests/indexed-types/should_fail/T10899.stderr b/testsuite/tests/indexed-types/should_fail/T10899.stderr index 925e4348fe..0dd92ef9bf 100644 --- a/testsuite/tests/indexed-types/should_fail/T10899.stderr +++ b/testsuite/tests/indexed-types/should_fail/T10899.stderr @@ -1,4 +1,5 @@ T10899.hs:7:3: error: • Illegal polymorphic type: forall (m :: * -> *). m a - • In the class declaration for ‘C’ + • In the default type instance declaration for ‘F’ + In the class declaration for ‘C’ diff --git a/testsuite/tests/indexed-types/should_fail/T11450.stderr b/testsuite/tests/indexed-types/should_fail/T11450.stderr index a6fe961fcf..f5be9d48c3 100644 --- a/testsuite/tests/indexed-types/should_fail/T11450.stderr +++ b/testsuite/tests/indexed-types/should_fail/T11450.stderr @@ -1,7 +1,7 @@ -T11450.hs:9:8: error: +T11450.hs:9:3: error: • Type indexes must match class instance head Expected: T (Either a b) - Actual: T (Either b a) + Actual: T (Either b a) -- Defined at T11450.hs:9:8 • In the type instance declaration for ‘T’ In the instance declaration for ‘C (Either a b)’ diff --git a/testsuite/tests/indexed-types/should_fail/T12041.stderr b/testsuite/tests/indexed-types/should_fail/T12041.stderr index 006ca37bae..d16a9cc49c 100644 --- a/testsuite/tests/indexed-types/should_fail/T12041.stderr +++ b/testsuite/tests/indexed-types/should_fail/T12041.stderr @@ -1,7 +1,7 @@ -T12041.hs:12:15: error: - • Expected kind ‘i -> Constraint’, - but ‘(~) Int’ has kind ‘* -> Constraint’ - • In the type ‘(~) Int’ - In the type instance declaration for ‘Ob’ +T12041.hs:12:3: error: + • Type indexes must match class instance head + Expected: Ob @i (I @{i} @{i}) + Actual: Ob @* (I @{*} @{*}) -- Defined at T12041.hs:12:8 + • In the type instance declaration for ‘Ob’ In the instance declaration for ‘Category I’ diff --git a/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr b/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr index 9df66e7cd1..c13bde5ad8 100644 --- a/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr +++ b/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr @@ -2,4 +2,4 @@ Main.hs:10:15: error: Conflicting family instance declarations: A (a, Y) = Bool -- Defined at Main.hs:10:15 - A (B.X, b) = () -- Defined in ‘B’ + A (B.X, b) = () -- Defined in module B diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr index 6676684ec1..ab714e3ecc 100644 --- a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr @@ -2,4 +2,4 @@ T13092c_4.hs:7:15: error: Conflicting family instance declarations: F (a, Char) = String -- Defined at T13092c_4.hs:7:15 - F (T13092c_2.X, b) = Bool -- Defined in ‘T13092c_2’ + F (T13092c_2.X, b) = Bool -- Defined in module T13092c_2 diff --git a/testsuite/tests/indexed-types/should_fail/T13972.hs b/testsuite/tests/indexed-types/should_fail/T13972.hs index a0a203d30a..9a5af411e2 100644 --- a/testsuite/tests/indexed-types/should_fail/T13972.hs +++ b/testsuite/tests/indexed-types/should_fail/T13972.hs @@ -8,5 +8,11 @@ import Data.Kind class C (a :: k) where type T k :: Type +-- This used to fail, with a mysterious error messate +-- Type indexes must match class instance head +-- Expected: T (a1 -> Either a1 b1) +-- Actual: T (a -> Either a b) +-- but now it succeeds fine + instance C Left where type T (a -> Either a b) = Int diff --git a/testsuite/tests/indexed-types/should_fail/T13972.stderr b/testsuite/tests/indexed-types/should_fail/T13972.stderr deleted file mode 100644 index b1f05b3105..0000000000 --- a/testsuite/tests/indexed-types/should_fail/T13972.stderr +++ /dev/null @@ -1,7 +0,0 @@ - -T13972.hs:12:8: error: - • Type indexes must match class instance head - Expected: T (a1 -> Either a1 b1) - Actual: T (a -> Either a b) - • In the type instance declaration for ‘T’ - In the instance declaration for ‘C Left’ diff --git a/testsuite/tests/indexed-types/should_fail/T14045a.hs b/testsuite/tests/indexed-types/should_fail/T14045a.hs index fc545a8d41..985220c472 100644 --- a/testsuite/tests/indexed-types/should_fail/T14045a.hs +++ b/testsuite/tests/indexed-types/should_fail/T14045a.hs @@ -7,6 +7,11 @@ import Data.Kind class C (a :: k) where data S (a :: k) +-- This used to fail with the mysterious error +-- Type indexes must match class instance head +-- Expected: S z +-- Actual: S a +-- But now it is fine instance C (z :: Bool) where data S :: Bool -> Type where SF :: S False diff --git a/testsuite/tests/indexed-types/should_fail/T14045a.stderr b/testsuite/tests/indexed-types/should_fail/T14045a.stderr deleted file mode 100644 index 0306bd2a07..0000000000 --- a/testsuite/tests/indexed-types/should_fail/T14045a.stderr +++ /dev/null @@ -1,7 +0,0 @@ - -T14045a.hs:11:3: error: - • Type indexes must match class instance head - Expected: S z - Actual: S :: Bool -> Type - • In the data instance declaration for ‘S’ - In the instance declaration for ‘C (z :: Bool)’ diff --git a/testsuite/tests/indexed-types/should_fail/T14179.stderr b/testsuite/tests/indexed-types/should_fail/T14179.stderr index 38d77f1cca..bb956c7b51 100644 --- a/testsuite/tests/indexed-types/should_fail/T14179.stderr +++ b/testsuite/tests/indexed-types/should_fail/T14179.stderr @@ -6,8 +6,8 @@ T14179.hs:7:15: error: T14179.hs:11:15: error: Conflicting family instance declarations: - Foo2 a -- Defined at T14179.hs:11:15 - Foo2 a -- Defined at T14179.hs:12:15 + Foo2 -- Defined at T14179.hs:11:15 + Foo2 -- Defined at T14179.hs:12:15 T14179.hs:15:15: error: Conflicting family instance declarations: diff --git a/testsuite/tests/indexed-types/should_fail/T14887.hs b/testsuite/tests/indexed-types/should_fail/T14887.hs new file mode 100644 index 0000000000..63fbbd3943 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T14887.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} +module T14887 where + +import Data.Kind +import Data.Type.Equality + +type family Foo1 (e :: (a :: k) :~: (a :: k)) :: Type where + Foo1 (e :: a :~: a) = a :~: a + +type family Foo2 (k :: Type) (e :: (a :: k) :~: (a :: k)) :: Type where + Foo2 k (e :: a :~: a) = a :~: a diff --git a/testsuite/tests/indexed-types/should_fail/T14887.stderr b/testsuite/tests/indexed-types/should_fail/T14887.stderr new file mode 100644 index 0000000000..56875a7628 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T14887.stderr @@ -0,0 +1,12 @@ + +T14887.hs:13:1: error: + • The kind of ‘Foo2’ is ill-scoped + Inferred kind: Foo2 :: forall (a :: k). forall k -> (a :~: a) -> * + NB: Specified variables (namely: (a :: k)) always come first + Perhaps try this order instead: k (a :: k) (e :: a :~: a) + • In the type family declaration for ‘Foo2’ + +T14887.hs:14:11: error: + • Expected kind ‘a0 :~: a0’, but ‘e :: a :~: a’ has kind ‘a :~: a’ + • In the second argument of ‘Foo2’, namely ‘(e :: a :~: a)’ + In the type family declaration for ‘Foo2’ diff --git a/testsuite/tests/indexed-types/should_fail/T15740.hs b/testsuite/tests/indexed-types/should_fail/T15740.hs new file mode 100644 index 0000000000..e564a87509 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15740.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeInType, TypeFamilies, KindSignatures, RankNTypes #-} + +module T15740 where + +import Data.Kind + +type family F2 :: forall k. k -> Type +data SBool :: Bool -> Type +data Nat +data SNat :: Nat -> Type +type instance F2 = SBool +type instance F2 = SNat diff --git a/testsuite/tests/indexed-types/should_fail/T15740.stderr b/testsuite/tests/indexed-types/should_fail/T15740.stderr new file mode 100644 index 0000000000..9d7cdcfee7 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15740.stderr @@ -0,0 +1,11 @@ + +T15740.hs:11:20: error: + • Expected kind ‘forall k. k -> *’, + but ‘SBool’ has kind ‘Bool -> *’ + • In the type ‘SBool’ + In the type instance declaration for ‘F2’ + +T15740.hs:12:20: error: + • Expected kind ‘forall k. k -> *’, but ‘SNat’ has kind ‘Nat -> *’ + • In the type ‘SNat’ + In the type instance declaration for ‘F2’ diff --git a/testsuite/tests/indexed-types/should_fail/T15764.hs b/testsuite/tests/indexed-types/should_fail/T15764.hs new file mode 100644 index 0000000000..f4c164cd05 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15764.hs @@ -0,0 +1,14 @@ +{-# Language PolyKinds #-} +{-# Language TypeFamilies #-} +{-# Language KindSignatures #-} +{-# Language DataKinds #-} +{-# Language MultiParamTypeClasses #-} + +module T15764 where + +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +class C6 (k :: Type) (a :: k) (b :: Proxy (a :: k)) where + type T6 (proxy :: Proxy '(k, b)) diff --git a/testsuite/tests/indexed-types/should_fail/T15764.stderr b/testsuite/tests/indexed-types/should_fail/T15764.stderr new file mode 100644 index 0000000000..5c04427841 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15764.stderr @@ -0,0 +1,11 @@ + +T15764.hs:14:2: error: + • The kind of ‘T6’ is ill-scoped + Inferred kind: T6 :: forall (a :: k) k (b :: Proxy a). + Proxy '(k, b) -> * + NB: Inferred variables + (namely: (a :: k)) always come first + then Specified variables (namely: k (b :: Proxy a)) + Perhaps try this order instead: + k (a :: k) (b :: Proxy a) (proxy :: Proxy '(k, b)) + • In the associated type family declaration for ‘T6’ diff --git a/testsuite/tests/indexed-types/should_fail/T15870.hs b/testsuite/tests/indexed-types/should_fail/T15870.hs new file mode 100644 index 0000000000..0a07c3e5e5 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15870.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module T15870 where + +data Optic a where + --Index :: Nat -> Optic a + --Name :: Symbol -> Optic a + (:.:) :: Optic a -> Optic b -> Optic a -- composition + +class Gettable a (optic :: Optic a) where + type Get a (optic :: Optic a) + +{- +some basic instances, e.g. +instance Gettable (a,b) (Index 0) where + type Get (a,b) (Index 0) = a +... +-} + +instance forall a b (g1 :: Optic a) (g2 :: Optic b). + ( Gettable a g1 + , b ~ Get a g1 + , Gettable b g2 + ) => Gettable a (g1 :.: g2) where + type Get a (g1 :.: g2) = Get a g2 diff --git a/testsuite/tests/indexed-types/should_fail/T15870.stderr b/testsuite/tests/indexed-types/should_fail/T15870.stderr new file mode 100644 index 0000000000..4acacbab50 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T15870.stderr @@ -0,0 +1,6 @@ + +T15870.hs:32:34: error: + • Expected kind ‘Optic a’, but ‘g2’ has kind ‘Optic b’ + • In the second argument of ‘Get’, namely ‘g2’ + In the type ‘Get a g2’ + In the type instance declaration for ‘Get’ diff --git a/testsuite/tests/indexed-types/should_fail/T7536.stderr b/testsuite/tests/indexed-types/should_fail/T7536.stderr index 9e7ed3010e..22c565be62 100644 --- a/testsuite/tests/indexed-types/should_fail/T7536.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7536.stderr @@ -1,5 +1,6 @@ -T7536.hs:8:15: - Family instance purports to bind type variable ‘a’ - but the real LHS (expanding synonyms) is: TF Int = ... - In the type instance declaration for ‘TF’ +T7536.hs:8:21: error: + • Type variable ‘a’ is mentioned in the RHS, + but not bound on the LHS of the family instance + The real LHS (expanding synonyms) is: TF Int + • In the type instance declaration for ‘TF’ diff --git a/testsuite/tests/indexed-types/should_fail/T7938.hs b/testsuite/tests/indexed-types/should_fail/T7938.hs index 405a7e54d0..246015ddf7 100644 --- a/testsuite/tests/indexed-types/should_fail/T7938.hs +++ b/testsuite/tests/indexed-types/should_fail/T7938.hs @@ -9,4 +9,4 @@ class Foo (a :: k1) (b :: k2) where type Bar a instance Foo (a :: k1) (b :: k2) where - type Bar a = (KP :: KProxy k2)
\ No newline at end of file + type Bar a = (KP :: KProxy k2) diff --git a/testsuite/tests/indexed-types/should_fail/T7938.stderr b/testsuite/tests/indexed-types/should_fail/T7938.stderr index 890be7b7b8..5751c4e992 100644 --- a/testsuite/tests/indexed-types/should_fail/T7938.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7938.stderr @@ -1,6 +1,6 @@ T7938.hs:12:17: error: - • Expected a type, but ‘KP :: KProxy k2’ has kind ‘KProxy k4’ + • Expected a type, but ‘KP :: KProxy k2’ has kind ‘KProxy k2’ • In the type ‘(KP :: KProxy k2)’ In the type instance declaration for ‘Bar’ In the instance declaration for ‘Foo (a :: k1) (b :: k2)’ diff --git a/testsuite/tests/indexed-types/should_fail/T9160.stderr b/testsuite/tests/indexed-types/should_fail/T9160.stderr index 4ed166cfdb..36a1cb6767 100644 --- a/testsuite/tests/indexed-types/should_fail/T9160.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9160.stderr @@ -1,7 +1,7 @@ -T9160.hs:19:12: error: - Expecting one more argument to ‘Maybe’ - Expected a type, but ‘Maybe’ has kind ‘* -> *’ - In the type ‘Maybe’ - In the type instance declaration for ‘F’ - In the instance declaration for ‘C (a :: *)’ +T9160.hs:19:3: error: + • Type indexes must match class instance head + Expected: F @* + Actual: F @(* -> *) -- Defined at T9160.hs:19:8 + • In the type instance declaration for ‘F’ + In the instance declaration for ‘C (a :: *)’ diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T index 12fa999a9f..6273f595b0 100644 --- a/testsuite/tests/indexed-types/should_fail/all.T +++ b/testsuite/tests/indexed-types/should_fail/all.T @@ -139,12 +139,16 @@ test('T13271', normal, compile_fail, ['']) test('T13674', normal, compile_fail, ['']) test('T13784', normal, compile_fail, ['']) test('T13877', normal, compile_fail, ['']) -test('T13972', normal, compile_fail, ['']) +test('T13972', normal, compile, ['']) test('T14033', normal, compile_fail, ['']) -test('T14045a', normal, compile_fail, ['']) +test('T14045a', normal, compile, ['']) test('T14175', normal, compile_fail, ['']) test('T14179', normal, compile_fail, ['']) test('T14246', normal, compile_fail, ['']) test('T14369', normal, compile_fail, ['']) test('T15172', normal, compile_fail, ['']) test('T14904', normal, compile_fail, ['']) +test('T15740', normal, compile_fail, ['']) +test('T15764', normal, compile_fail, ['']) +test('T15870', normal, compile_fail, ['']) +test('T14887', normal, compile_fail, ['']) diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr index 0569722f24..385a44b737 100644 --- a/testsuite/tests/partial-sigs/should_compile/ADT.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr @@ -1,7 +1,7 @@ TYPE SIGNATURES bar :: Int -> Foo Bool () Int TYPE CONSTRUCTORS - Foo :: * -> * -> * -> * + Foo{3} :: * -> * -> * -> * DATA CONSTRUCTORS Foo :: forall x y z. x -> y -> z -> Foo x y z Dependent modules: [] diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr index 12982a740c..6f68f3cd66 100644 --- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr @@ -1,20 +1,20 @@ TYPE SIGNATURES foo :: Sing 'A TYPE CONSTRUCTORS - MyKind :: * + MyKind{0} :: * type role Sing nominal nominal - Sing :: forall k. k -> * + Sing{2} :: forall k. k -> * COERCION AXIOMS axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: - Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 - -- Defined at DataFamilyInstanceLHS.hs:8:15 + Sing = DataFamilyInstanceLHS.R:SingMyKind_ DATA CONSTRUCTORS A :: MyKind B :: MyKind SingA :: Sing 'A SingB :: Sing 'B FAMILY INSTANCES - data instance Sing + data instance Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + -- Defined at DataFamilyInstanceLHS.hs:8:15 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr index 750a951222..a40ecfeee0 100644 --- a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr @@ -5,7 +5,7 @@ TYPE SIGNATURES NukeMonad param1 param2 () -> NukeMonad param1 param2 () TYPE CONSTRUCTORS type role NukeMonad phantom phantom phantom - NukeMonad :: * -> * -> * -> * + NukeMonad{3} :: * -> * -> * -> * CLASS INSTANCES instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10 instance Applicative (NukeMonad a b) diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr index 1cd0417e54..94245d6aa2 100644 --- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr @@ -1,11 +1,10 @@ TYPE CONSTRUCTORS - MyKind :: * + MyKind{0} :: * type role Sing nominal nominal - Sing :: forall k. k -> * + Sing{2} :: forall k. k -> * COERCION AXIOMS axiom NamedWildcardInDataFamilyInstanceLHS.D:R:SingMyKind_a0 :: - Sing _a = NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a _a - -- Defined at NamedWildcardInDataFamilyInstanceLHS.hs:8:15 + Sing = NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a DATA CONSTRUCTORS A :: MyKind B :: MyKind @@ -13,6 +12,8 @@ DATA CONSTRUCTORS SingB :: Sing 'B FAMILY INSTANCES data instance Sing + _a = NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a _a + -- Defined at NamedWildcardInDataFamilyInstanceLHS.hs:8:15 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr index 0554f0a6e7..5a709fff9d 100644 --- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr @@ -1,10 +1,8 @@ TYPE CONSTRUCTORS type role F nominal - F :: * -> * + F{1} :: * -> * COERCION AXIOMS - axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F :: - F _t = Int - -- Defined at NamedWildcardInTypeFamilyInstanceLHS.hs:5:3 + axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F :: F _t = Int Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr index a821a6970a..0ee0a34564 100644 --- a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr @@ -4,7 +4,7 @@ TYPE SIGNATURES skipMany' :: forall tok st a. GenParser tok st a -> GenParser tok st () TYPE CONSTRUCTORS - GenParser :: * -> * -> * -> * + GenParser{3} :: * -> * -> * -> * DATA CONSTRUCTORS GenParser :: forall tok st a. tok -> st -> a -> GenParser tok st a Dependent modules: [] diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr index ae82437e1d..8f24ba1384 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr @@ -2,15 +2,15 @@ TYPE SIGNATURES foo :: F Int Char -> Int TYPE CONSTRUCTORS type role F nominal nominal - F :: * -> * -> * + F{2} :: * -> * -> * COERCION AXIOMS - axiom TypeFamilyInstanceLHS.D:R:FBool_1 :: - F Bool _1 = Bool -- Defined at TypeFamilyInstanceLHS.hs:8:15 - axiom TypeFamilyInstanceLHS.D:R:FInt_1 :: - F Int _1 = Int -- Defined at TypeFamilyInstanceLHS.hs:7:15 + axiom TypeFamilyInstanceLHS.D:R:FBool_1 :: F Bool _1 = Bool + axiom TypeFamilyInstanceLHS.D:R:FInt_1 :: F Int _1 = Int FAMILY INSTANCES - type instance F Int _1 - type instance F Bool _1 + type instance F Int _ = Int + -- Defined at TypeFamilyInstanceLHS.hs:7:15 + type instance F Bool _ = Bool + -- Defined at TypeFamilyInstanceLHS.hs:8:15 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr index 20a0fa51ca..67fae7b31e 100644 --- a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr @@ -1,10 +1,10 @@ T14040a.hs:34:8: error: - • Cannot apply expression of type ‘Sing wl - -> (forall y. p w0 'WeirdNil) + • Cannot apply expression of type ‘Sing wl0 + -> (forall y. p0 w0 'WeirdNil) -> (forall z1 (x :: z1) (xs :: WeirdList (WeirdList z1)). - Sing x -> Sing xs -> p w1 xs -> p w2 ('WeirdCons x xs)) - -> p w3 wl’ + Sing x -> Sing xs -> p0 w1 xs -> p0 w2 ('WeirdCons x xs)) + -> p0 w3 wl0’ to a visible type argument ‘(WeirdList z)’ • In the sixth argument of ‘pWeirdCons’, namely ‘(elimWeirdList @(WeirdList z) @xs @p xs pWeirdNil pWeirdCons)’ diff --git a/testsuite/tests/polykinds/T11203.stderr b/testsuite/tests/polykinds/T11203.stderr index 5d62e00304..f5c72133ae 100644 --- a/testsuite/tests/polykinds/T11203.stderr +++ b/testsuite/tests/polykinds/T11203.stderr @@ -1,4 +1,4 @@ T11203.hs:7:24: error: • Couldn't match ‘k1’ with ‘k2’ - • In the data declaration for ‘Q’ + • In the data type declaration for ‘Q’ diff --git a/testsuite/tests/polykinds/T11821a.stderr b/testsuite/tests/polykinds/T11821a.stderr index 2e443e637b..f55c703524 100644 --- a/testsuite/tests/polykinds/T11821a.stderr +++ b/testsuite/tests/polykinds/T11821a.stderr @@ -1,4 +1,4 @@ T11821a.hs:4:31: error: • Couldn't match ‘k1’ with ‘k2’ - • In the type declaration for ‘SameKind’ + • In the type synonym declaration for ‘SameKind’ diff --git a/testsuite/tests/polykinds/T12593.stderr b/testsuite/tests/polykinds/T12593.stderr index 27123a8bc8..e150299ea1 100644 --- a/testsuite/tests/polykinds/T12593.stderr +++ b/testsuite/tests/polykinds/T12593.stderr @@ -92,8 +92,8 @@ T12593.hs:14:6: error: • In the pattern: Free cat In an equation for ‘run’: run (Free cat) = cat • Relevant bindings include - run :: Free k6 k7 k8 p a b - -> (forall (c :: k6) (d :: k7). p c d -> q c d) -> q a b + run :: Free k k4 k8 p a b + -> (forall (c :: k) (d :: k4). p c d -> q c d) -> q a b (bound at T12593.hs:14:1) T12593.hs:14:18: error: @@ -111,6 +111,6 @@ T12593.hs:14:18: error: k2 q => (forall (c :: k0) (d :: k1). p0 c d -> q c d) -> q a b (bound at T12593.hs:14:11) - run :: Free k6 k7 k8 p a b - -> (forall (c :: k6) (d :: k7). p c d -> q c d) -> q a b + run :: Free k k4 k8 p a b + -> (forall (c :: k) (d :: k4). p c d -> q c d) -> q a b (bound at T12593.hs:14:1) diff --git a/testsuite/tests/polykinds/T13985.hs b/testsuite/tests/polykinds/T13985.hs index c0555d8f69..6a844b366e 100644 --- a/testsuite/tests/polykinds/T13985.hs +++ b/testsuite/tests/polykinds/T13985.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} diff --git a/testsuite/tests/polykinds/T13985.stderr b/testsuite/tests/polykinds/T13985.stderr index f60314a443..2df92c34da 100644 --- a/testsuite/tests/polykinds/T13985.stderr +++ b/testsuite/tests/polykinds/T13985.stderr @@ -1,39 +1,28 @@ -T13985.hs:12:1: error: - • Kind variable ‘k’ is implicitly bound in data family - ‘Fam’, but does not appear as the kind of any - of its type variables. Perhaps you meant - to bind it explicitly somewhere? +T13985.hs:13:41: error: + • Type variable ‘k’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the data instance declaration for ‘Fam’ -T13985.hs:15:15: error: - • Kind variable ‘a’ is implicitly bound in type family - ‘T’, but does not appear as the kind of any - of its type variables. Perhaps you meant - to bind it explicitly somewhere? +T13985.hs:16:43: error: + • Type variable ‘a’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the type instance declaration for ‘T’ -T13985.hs:22:3: error: - • Kind variable ‘k’ is implicitly bound in associated data family - ‘CD’, but does not appear as the kind of any - of its type variables. Perhaps you meant - to bind it explicitly somewhere? +T13985.hs:23:26: error: + • Type variable ‘k’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the data instance declaration for ‘CD’ In the instance declaration for ‘C Type’ -T13985.hs:23:8: error: - • Kind variable ‘a’ is implicitly bound in associated type family - ‘CT’, but does not appear as the kind of any - of its type variables. Perhaps you meant - to bind it explicitly somewhere? +T13985.hs:24:37: error: + • Type variable ‘a’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the type instance declaration for ‘CT’ In the instance declaration for ‘C Type’ -T13985.hs:27:3: error: - • Kind variable ‘x’ is implicitly bound in associated type family - ‘ZT’, but does not appear as the kind of any - of its type variables. Perhaps you meant - to bind it explicitly somewhere? - Type variables with inferred kinds: (k :: *) (a :: k) +T13985.hs:28:39: error: + • Type variable ‘x’ is mentioned in the RHS, + but not bound on the LHS of the family instance • In the default type instance declaration for ‘ZT’ In the class declaration for ‘Z’ diff --git a/testsuite/tests/polykinds/T14450.stderr b/testsuite/tests/polykinds/T14450.stderr index 8a987b7a56..107f4aa2ce 100644 --- a/testsuite/tests/polykinds/T14450.stderr +++ b/testsuite/tests/polykinds/T14450.stderr @@ -1,8 +1,7 @@ -T14450.hs:33:13: error: - • Expected kind ‘k ~> k’, - but ‘IddSym0 :: Type ~> Type’ has kind ‘* ~> *’ - • In the first argument of ‘Dom’, namely - ‘(IddSym0 :: Type ~> Type)’ - In the type instance declaration for ‘Dom’ +T14450.hs:33:3: error: + • Type indexes must match class instance head + Expected: Dom @k @k (IddSym0 @k) + Actual: Dom @* @* (IddSym0 @*) -- Defined at T14450.hs:33:8 + • In the type instance declaration for ‘Dom’ In the instance declaration for ‘Varpi (IddSym0 :: k ~> k)’ diff --git a/testsuite/tests/polykinds/T14846.stderr b/testsuite/tests/polykinds/T14846.stderr index 062dc49e1f..43d81c5e1e 100644 --- a/testsuite/tests/polykinds/T14846.stderr +++ b/testsuite/tests/polykinds/T14846.stderr @@ -3,12 +3,8 @@ T14846.hs:38:8: error: • Couldn't match type ‘ríki’ with ‘Hom riki’ ‘ríki’ is a rigid type variable bound by the type signature for: - i :: forall k5 k6 (cls2 :: k6 - -> Constraint) (xx :: k5) (a :: Struct cls2) (ríki :: Struct - cls2 - -> Struct - cls2 - -> *). + i :: forall k5 k6 (cls2 :: k6 -> Constraint) (xx :: k5) + (a :: Struct cls2) (ríki :: Struct cls2 -> Struct cls2 -> *). StructI xx a => ríki a a at T14846.hs:38:8-48 @@ -16,21 +12,31 @@ T14846.hs:38:8: error: Actual type: Hom riki a a • When checking that instance signature for ‘i’ is more general than its signature in the class - Instance sig: forall k1 k2 (cls :: k2 - -> Constraint) (xx :: k1) (a :: Struct cls). + Instance sig: forall k1 k2 (cls :: k2 -> Constraint) (xx :: k1) + (a :: Struct cls). StructI xx a => Hom riki a a - Class sig: forall k1 k2 (cls :: k2 - -> Constraint) (xx :: k1) (a :: Struct - cls) (ríki :: Struct - cls - -> Struct - cls - -> *). + Class sig: forall k1 k2 (cls :: k2 -> Constraint) (xx :: k1) + (a :: Struct cls) (ríki :: Struct cls -> Struct cls -> *). StructI xx a => ríki a a In the instance declaration for ‘Category (Hom riki)’ +T14846.hs:39:12: error: + • Couldn't match kind ‘k3’ with ‘Struct cls2’ + ‘k3’ is a rigid type variable bound by + the instance declaration + at T14846.hs:37:10-65 + When matching kinds + cls0 :: Struct cls -> Constraint + cls1 :: k3 -> Constraint + • In the expression: struct :: AStruct (Structured a cls) + In the expression: case struct :: AStruct (Structured a cls) of + In an equation for ‘i’: + i = case struct :: AStruct (Structured a cls) of + • Relevant bindings include + i :: Hom riki a a (bound at T14846.hs:39:3) + T14846.hs:39:31: error: • Couldn't match kind ‘k3’ with ‘Struct cls2’ ‘k3’ is a rigid type variable bound by diff --git a/testsuite/tests/polykinds/T14887a.hs b/testsuite/tests/polykinds/T14887a.hs new file mode 100644 index 0000000000..2e5cf02212 --- /dev/null +++ b/testsuite/tests/polykinds/T14887a.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-implicit-kind-vars #-} +module Bug where + +import Data.Proxy + +f1 :: forall (x :: a). Proxy (x :: _) +-- This one has an implicitly-quantified kind var 'a', which +-- we will stop accepting in the future, under the forall-or-nothing +-- rule. Hence -Wno-implicit-kind-vars +f1 = Proxy + +f2 :: forall a (x :: a). Proxy (x :: _) +f2 = Proxy diff --git a/testsuite/tests/polykinds/T14887a.stderr b/testsuite/tests/polykinds/T14887a.stderr new file mode 100644 index 0000000000..0519ecba6e --- /dev/null +++ b/testsuite/tests/polykinds/T14887a.stderr @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/testsuite/tests/polykinds/T15592.stderr b/testsuite/tests/polykinds/T15592.stderr index c1b823e738..4086c12bf6 100644 --- a/testsuite/tests/polykinds/T15592.stderr +++ b/testsuite/tests/polykinds/T15592.stderr @@ -1,6 +1,6 @@ TYPE CONSTRUCTORS type role T nominal nominal representational nominal nominal - T :: forall {k} k1. (k1 -> k -> *) -> k1 -> k -> * + T{5} :: forall {k} k1. (k1 -> k -> *) -> k1 -> k -> * DATA CONSTRUCTORS MkT :: forall {k} k1 (f :: k1 -> k -> *) (a :: k1) (b :: k). f a b -> T f a b -> T f a b diff --git a/testsuite/tests/polykinds/T15592b.stderr b/testsuite/tests/polykinds/T15592b.stderr index c51416f4c5..d07b3a1ac7 100644 --- a/testsuite/tests/polykinds/T15592b.stderr +++ b/testsuite/tests/polykinds/T15592b.stderr @@ -1,7 +1,7 @@ TYPE CONSTRUCTORS - C :: forall {k}. k -> Constraint + C{2} :: forall {k}. k -> Constraint type role T nominal nominal nominal nominal - T :: forall {k} (a :: k) (f :: k -> *). f a -> * + T{4} :: forall k (f :: k -> *) (a :: k). f a -> * Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/polykinds/T15789.hs b/testsuite/tests/polykinds/T15789.hs new file mode 100644 index 0000000000..6465da2a9b --- /dev/null +++ b/testsuite/tests/polykinds/T15789.hs @@ -0,0 +1,10 @@ +{-# Language LiberalTypeSynonyms #-} +{-# Language PolyKinds #-} +{-# Language RankNTypes #-} +{-# Language DataKinds #-} + +import Data.Kind + +type Cat ob = ob -> ob -> Type + +data Zero :: forall (cat :: forall xx. xx -> Type) a. forall b. Cat (forall b. cat b u) diff --git a/testsuite/tests/polykinds/T15789.stderr b/testsuite/tests/polykinds/T15789.stderr new file mode 100644 index 0000000000..c0fd4eab34 --- /dev/null +++ b/testsuite/tests/polykinds/T15789.stderr @@ -0,0 +1,6 @@ + +T15789.hs:10:80: error: + • Expected kind ‘k2 -> *’, but ‘cat b’ has kind ‘*’ + • In the first argument of ‘Cat’, namely ‘(forall b. cat b u)’ + In the kind ‘forall (cat :: forall xx. xx -> Type) a. + forall b. Cat (forall b. cat b u)’ diff --git a/testsuite/tests/polykinds/T15804.hs b/testsuite/tests/polykinds/T15804.hs new file mode 100644 index 0000000000..be5fa165a3 --- /dev/null +++ b/testsuite/tests/polykinds/T15804.hs @@ -0,0 +1,5 @@ +{-# Language PolyKinds #-} + +module T15804 where + +data T :: (a :: k) -> * diff --git a/testsuite/tests/polykinds/T15804.stderr b/testsuite/tests/polykinds/T15804.stderr new file mode 100644 index 0000000000..52262b675f --- /dev/null +++ b/testsuite/tests/polykinds/T15804.stderr @@ -0,0 +1,4 @@ + +T15804.hs:5:12: error: + • Expected a type, but ‘a :: k’ has kind ‘k’ + • In the kind ‘(a :: k) -> *’ diff --git a/testsuite/tests/polykinds/T15817.hs b/testsuite/tests/polykinds/T15817.hs new file mode 100644 index 0000000000..a5f3eb78db --- /dev/null +++ b/testsuite/tests/polykinds/T15817.hs @@ -0,0 +1,10 @@ +{-# Language RankNTypes #-} +{-# Language PolyKinds #-} +{-# Language TypeFamilies #-} + +module T15817 where + +import Data.Kind + +data family X :: forall (a :: Type). Type +data instance X = MkX diff --git a/testsuite/tests/polykinds/T15874.hs b/testsuite/tests/polykinds/T15874.hs new file mode 100644 index 0000000000..fd560db095 --- /dev/null +++ b/testsuite/tests/polykinds/T15874.hs @@ -0,0 +1,18 @@ +{-# Language RankNTypes #-} +{-# Language DataKinds #-} +{-# Language PolyKinds #-} +{-# Language GADTs #-} +{-# Language TypeFamilies #-} + +module T15874 where + +import Data.Kind + +data Var where + Op :: Var + Id :: Var + +type Varianced = (forall (var :: Var). Type) + +data family Parser :: Varianced +data instance Parser = P diff --git a/testsuite/tests/polykinds/T15881.hs b/testsuite/tests/polykinds/T15881.hs new file mode 100644 index 0000000000..a49b7fd436 --- /dev/null +++ b/testsuite/tests/polykinds/T15881.hs @@ -0,0 +1,8 @@ +{-# Language KindSignatures #-} +{-# Language PolyKinds #-} + +module T15881 where + +import Data.Kind + +data A n (a :: n n) :: Type diff --git a/testsuite/tests/polykinds/T15881.stderr b/testsuite/tests/polykinds/T15881.stderr new file mode 100644 index 0000000000..4fde71dab7 --- /dev/null +++ b/testsuite/tests/polykinds/T15881.stderr @@ -0,0 +1,5 @@ + +T15881.hs:8:18: error: + • Occurs check: cannot construct the infinite kind: k0 ~ k0 -> * + • In the first argument of ‘n’, namely ‘n’ + In the kind ‘n n’ diff --git a/testsuite/tests/polykinds/T15881a.hs b/testsuite/tests/polykinds/T15881a.hs new file mode 100644 index 0000000000..a29c63f706 --- /dev/null +++ b/testsuite/tests/polykinds/T15881a.hs @@ -0,0 +1,8 @@ +{-# Language KindSignatures #-} +{-# Language PolyKinds #-} + +module T15881a where + +import Data.Kind + +data A n (a :: n) :: a -> Type diff --git a/testsuite/tests/polykinds/T15881a.stderr b/testsuite/tests/polykinds/T15881a.stderr new file mode 100644 index 0000000000..84014c7abc --- /dev/null +++ b/testsuite/tests/polykinds/T15881a.stderr @@ -0,0 +1,4 @@ + +T15881a.hs:8:22: error: + • Expected a type, but ‘a’ has kind ‘n’ + • In the kind ‘a -> Type’ diff --git a/testsuite/tests/polykinds/T8616.stderr b/testsuite/tests/polykinds/T8616.stderr index 9aa4ab50d9..f9e5132a34 100644 --- a/testsuite/tests/polykinds/T8616.stderr +++ b/testsuite/tests/polykinds/T8616.stderr @@ -13,3 +13,12 @@ T8616.hs:8:16: error: withSomeSing = undefined :: (Any :: k) • Relevant bindings include withSomeSing :: Proxy kproxy (bound at T8616.hs:8:1) + +T8616.hs:8:30: error: + • Expected a type, but ‘Any :: k’ has kind ‘k’ + • In an expression type signature: (Any :: k) + In the expression: undefined :: (Any :: k) + In an equation for ‘withSomeSing’: + withSomeSing = undefined :: (Any :: k) + • Relevant bindings include + withSomeSing :: Proxy kproxy (bound at T8616.hs:8:1) diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index 6ffb3181ce..8be2c59bf0 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -196,3 +196,10 @@ test('T15577', normal, compile_fail, ['-O']) test('T15592', normal, compile, ['']) test('T15592b', normal, compile, ['-ddump-types -fprint-explicit-foralls']) test('T15787', normal, compile_fail, ['']) +test('T15789', normal, compile_fail, ['']) +test('T15804', normal, compile_fail, ['']) +test('T15881', normal, compile_fail, ['']) +test('T15881a', normal, compile_fail, ['']) +test('T15817', normal, compile, ['']) +test('T15874', normal, compile, ['']) +test('T14887a', normal, compile, ['']) diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index 3278701048..c2678b71d7 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -1,16 +1,16 @@ TYPE CONSTRUCTORS type role T1 nominal - T1 :: * -> * - T2 :: * -> * + T1{1} :: * -> * + T2{1} :: * -> * type role T3 nominal phantom - T3 :: forall k. k -> * + T3{2} :: forall k. k -> * type role T4 nominal nominal - T4 :: (* -> *) -> * -> * - T5 :: * -> * + T4{2} :: (* -> *) -> * -> * + T5{1} :: * -> * type role T6 nominal phantom - T6 :: forall {k}. k -> * + T6{2} :: forall {k}. k -> * type role T7 nominal phantom representational - T7 :: forall {k}. k -> * -> * + T7{3} :: forall {k}. k -> * -> * DATA CONSTRUCTORS K7 :: forall {k} (a :: k) b. b -> T7 a b K6 :: forall {k} (a :: k). T6 a diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index 57899142d9..1745332a6b 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -2,9 +2,9 @@ TYPE SIGNATURES meth2 :: forall a. C2 a => a -> a TYPE CONSTRUCTORS type role C2 representational - C2 :: * -> Constraint + C2{1} :: * -> Constraint COERCION AXIOMS - axiom Roles12.N:C2 :: C2 a = a -> a -- Defined at Roles14.hs:6:1 + axiom Roles12.N:C2 :: C2 a = a -> a Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index 4cb55ec063..170315111d 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -1,7 +1,7 @@ TYPE CONSTRUCTORS - T1 :: * -> * + T1{1} :: * -> * type role T2 phantom - T2 :: * -> * + T2{1} :: * -> * DATA CONSTRUCTORS K2 :: forall a. FunPtr a -> T2 a K1 :: forall a. IO a -> T1 a diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index b3507b0564..bf76b72987 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -4,25 +4,22 @@ TYPE SIGNATURES meth3 :: forall a b. C3 a b => a -> F3 b -> F3 b meth4 :: forall a b. C4 a b => a -> F4 b -> F4 b TYPE CONSTRUCTORS - C1 :: * -> Constraint - C2 :: * -> * -> Constraint - C3 :: * -> * -> Constraint - C4 :: * -> * -> Constraint + C1{1} :: * -> Constraint + C2{2} :: * -> * -> Constraint + C3{2} :: * -> * -> Constraint + C4{2} :: * -> * -> Constraint type role F3 nominal - F3 :: * -> * + F3{1} :: * -> * type role F4 nominal - F4 :: * -> * + F4{1} :: * -> * type role Syn1 nominal - Syn1 :: * -> * - Syn2 :: * -> * + Syn1{1} :: * -> * + Syn2{1} :: * -> * COERCION AXIOMS - axiom Roles3.N:C1 :: C1 a = a -> a -- Defined at Roles3.hs:6:1 - axiom Roles3.N:C2 :: - C2 a b = (a ~ b) => a -> b -- Defined at Roles3.hs:9:1 - axiom Roles3.N:C3 :: - C3 a b = a -> F3 b -> F3 b -- Defined at Roles3.hs:12:1 - axiom Roles3.N:C4 :: - C4 a b = a -> F4 b -> F4 b -- Defined at Roles3.hs:18:1 + axiom Roles3.N:C1 :: C1 a = a -> a + axiom Roles3.N:C2 :: C2 a b = (a ~ b) => a -> b + axiom Roles3.N:C3 :: C3 a b = a -> F3 b -> F3 b + axiom Roles3.N:C4 :: C4 a b = a -> F4 b -> F4 b Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 93a86a514c..dbca015edb 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -2,13 +2,12 @@ TYPE SIGNATURES meth1 :: forall a. C1 a => a -> a meth3 :: forall a. C3 a => a -> Syn1 a TYPE CONSTRUCTORS - C1 :: * -> Constraint - C3 :: * -> Constraint - Syn1 :: * -> * + C1{1} :: * -> Constraint + C3{1} :: * -> Constraint + Syn1{1} :: * -> * COERCION AXIOMS - axiom Roles4.N:C1 :: C1 a = a -> a -- Defined at Roles4.hs:6:1 - axiom Roles4.N:C3 :: - C3 a = a -> Syn1 a -- Defined at Roles4.hs:11:1 + axiom Roles4.N:C1 :: C1 a = a -> a + axiom Roles4.N:C3 :: C3 a = a -> Syn1 a Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index eaad63859d..4e2fe00e87 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -3,12 +3,12 @@ T8958.hs:1:31: warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. TYPE CONSTRUCTORS type role Map nominal representational - Map :: * -> * -> * - Nominal :: * -> Constraint + Map{2} :: * -> * -> * + Nominal{1} :: * -> Constraint type role Representational representational - Representational :: * -> Constraint + Representational{1} :: * -> Constraint COERCION AXIOMS - axiom T8958.N:Map :: Map k v = [(k, v)] -- Defined at T8958.hs:13:1 + axiom T8958.N:Map :: Map k v = [(k, v)] DATA CONSTRUCTORS MkMap :: forall k v. [(k, v)] -> Map k v CLASS INSTANCES diff --git a/testsuite/tests/showIface/Orphans.stdout b/testsuite/tests/showIface/Orphans.stdout index 63fcd79a19..38e4066d9e 100644 --- a/testsuite/tests/showIface/Orphans.stdout +++ b/testsuite/tests/showIface/Orphans.stdout @@ -2,5 +2,5 @@ instance [orphan] GHC.Exts.IsList [GHC.Types.Bool] = $fIsListBool instance GHC.Exts.IsList [X] = $fIsListX family instance GHC.Exts.Item [X] = D:R:ItemX family instance [orphan] GHC.Exts.Item [GHC.Types.Bool] -"myrule1" [orphan] forall @ a -"myrule2" forall GHC.Base.id @ (X -> X) f = f +"myrule1" [orphan] forall @ a. +"myrule2" GHC.Base.id @ (X -> X) f = f diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index c988015622..3807609678 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -1,6 +1,6 @@ TYPE CONSTRUCTORS type role T nominal representational - T :: forall k. k -> * + T{2} :: forall k. k -> * Dependent modules: [] Dependent packages: [array-0.5.2.0, base-4.12.0.0, deepseq-1.4.4.0, ghc-boot-th-8.7, ghc-prim-0.5.3, integer-gmp-1.0.2.0, diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr index 6205547873..673f09e2e0 100644 --- a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr +++ b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr @@ -13,4 +13,4 @@ type family TH_reifyExplicitForAllFams.H (a_0 :: *) (b_1 :: *) :: * where (Data.Proxy.Proxy y_3) = Data.Either.Either x_2 y_3 forall (z_4 :: *). TH_reifyExplicitForAllFams.H z_4 - z_4 = GHC.Maybe.Maybe z_4
\ No newline at end of file + z_4 = GHC.Maybe.Maybe z_4 diff --git a/testsuite/tests/typecheck/should_compile/T12763.stderr b/testsuite/tests/typecheck/should_compile/T12763.stderr index ad3460c2da..99a66bd59e 100644 --- a/testsuite/tests/typecheck/should_compile/T12763.stderr +++ b/testsuite/tests/typecheck/should_compile/T12763.stderr @@ -2,9 +2,9 @@ TYPE SIGNATURES f :: Int -> () m :: forall a. C a => a -> () TYPE CONSTRUCTORS - C :: * -> Constraint + C{1} :: * -> Constraint COERCION AXIOMS - axiom T12763.N:C :: C a = a -> () -- Defined at T12763.hs:6:1 + axiom T12763.N:C :: C a = a -> () CLASS INSTANCES instance C Int -- Defined at T12763.hs:9:10 Dependent modules: [] diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index 6c785b4a40..18beabd3a1 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -6,13 +6,11 @@ TYPE SIGNATURES huh :: forall s a b chain. Zork s a b => Q s a chain -> ST s () s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 TYPE CONSTRUCTORS - Q :: * -> * -> * -> * - Z :: * -> * - Zork :: * -> * -> * -> Constraint + Q{3} :: * -> * -> * -> * + Z{1} :: * -> * + Zork{3} :: * -> * -> * -> Constraint COERCION AXIOMS - axiom N:Zork :: - Zork s a b = forall chain. Q s a chain -> ST s () - -- Defined at tc231.hs:25:1 + axiom N:Zork :: Zork s a b = forall chain. Q s a chain -> ST s () DATA CONSTRUCTORS Z :: forall a. a -> Z a Node :: forall s a chain. s -> a -> chain -> Q s a chain diff --git a/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr index 21ae68ab85..afa8330765 100644 --- a/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr +++ b/testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr @@ -3,3 +3,8 @@ LevPolyBounded.hs:10:15: error: • Expected a type, but ‘a’ has kind ‘TYPE r’ • In the type signature: LevPolyBounded.minBound :: a In the class declaration for ‘XBounded’ + +LevPolyBounded.hs:11:15: error: + • Expected a type, but ‘a’ has kind ‘TYPE r’ + • In the type signature: LevPolyBounded.maxBound :: a + In the class declaration for ‘XBounded’ diff --git a/testsuite/tests/typecheck/should_fail/T13983.stderr b/testsuite/tests/typecheck/should_fail/T13983.stderr index 5c7a031654..d1b2fe067b 100644 --- a/testsuite/tests/typecheck/should_fail/T13983.stderr +++ b/testsuite/tests/typecheck/should_fail/T13983.stderr @@ -5,4 +5,4 @@ T13983.hs:7:1: error: of its type variables. Perhaps you meant to bind it explicitly somewhere? Type variables with inferred kinds: (k :: *) - • In the type declaration for ‘Wat’ + • In the type synonym declaration for ‘Wat’ diff --git a/testsuite/tests/typecheck/should_fail/T14607.hs b/testsuite/tests/typecheck/should_fail/T14607.hs index 86c738dc19..af2e1c7677 100644 --- a/testsuite/tests/typecheck/should_fail/T14607.hs +++ b/testsuite/tests/typecheck/should_fail/T14607.hs @@ -31,4 +31,4 @@ instance Mk a where -- So now the kind error can be deferred. -- Consequence of a fast-path for tcImplicitTKBndrsX I think. - +-- Later (Nov 18) we are back to a kind error, which is fine diff --git a/testsuite/tests/typecheck/should_fail/T14607.stderr b/testsuite/tests/typecheck/should_fail/T14607.stderr index 5e0b66a340..b7d60593e1 100644 --- a/testsuite/tests/typecheck/should_fail/T14607.stderr +++ b/testsuite/tests/typecheck/should_fail/T14607.stderr @@ -1,21 +1,12 @@ -T14607.hs:22:9: warning: [-Wdeferred-type-errors (in -Wdefault)] +T14607.hs:22:9: error: • Expecting one more argument to ‘LamCons a '()’ - Expected a type, but ‘LamCons a '()’ has kind ‘() -> *’ - • In the type signature: mk :: LamCons a '() + Expected a type, but ‘LamCons a '()’ has kind ‘() -> *’ + • In the type signature: mk :: LamCons a '() In the instance declaration for ‘Mk a’ -T14607.hs:22:19: warning: [-Wdeferred-type-errors (in -Wdefault)] +T14607.hs:22:19: error: • Expected a type, but ‘'()’ has kind ‘()’ • In the second argument of ‘LamCons’, namely ‘'()’ In the type signature: mk :: LamCons a '() In the instance declaration for ‘Mk a’ - -T14607.hs:23:8: warning: [-Wdeferred-type-errors (in -Wdefault)] - • Couldn't match expected type ‘LamCons a '()’ - with actual type ‘LamCons a0 a0 '()’ - • In the expression: mk - In an equation for ‘mk’: mk = mk - In the instance declaration for ‘Mk a’ - • Relevant bindings include - mk :: LamCons a '() (bound at T14607.hs:23:3) diff --git a/testsuite/tests/typecheck/should_fail/T2688.stderr b/testsuite/tests/typecheck/should_fail/T2688.stderr index 2b2ca0d22a..63379a03b9 100644 --- a/testsuite/tests/typecheck/should_fail/T2688.stderr +++ b/testsuite/tests/typecheck/should_fail/T2688.stderr @@ -2,9 +2,11 @@ T2688.hs:8:14: error: • Couldn't match expected type ‘v’ with actual type ‘s’ ‘s’ is a rigid type variable bound by - the class declaration for ‘VectorSpace’ at T2688.hs:5:21 + the class declaration for ‘VectorSpace’ + at T2688.hs:(5,1)-(8,23) ‘v’ is a rigid type variable bound by - the class declaration for ‘VectorSpace’ at T2688.hs:5:19 + the class declaration for ‘VectorSpace’ + at T2688.hs:(5,1)-(8,23) • In the expression: v *^ (1 / s) In an equation for ‘^/’: v ^/ s = v *^ (1 / s) • Relevant bindings include diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr index 0e230e62c8..84af180b20 100644 --- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -59,9 +59,9 @@ T6018fail.hs:53:15: error: T6018fail.hs:61:10: error: Type family equation violates injectivity annotation. - Kind variable ‘k2’ cannot be inferred from the right-hand side. + Kind variable ‘k1’ cannot be inferred from the right-hand side. In the type family equation: - PolyKindVarsF @{[k2]} @[k1] ('[] @k2) = '[] @k1 + PolyKindVarsF @{[k1]} @[k2] ('[] @k1) = '[] @k2 -- Defined at T6018fail.hs:61:10 T6018fail.hs:64:15: error: diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 3805315398..7dca65b499 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -469,7 +469,7 @@ test('T14350', normal, compile_fail, ['']) test('T14390', normal, compile_fail, ['']) test('MissingExportList03', normal, compile_fail, ['']) test('T14618', normal, compile_fail, ['']) -test('T14607', normal, compile, ['']) +test('T14607', normal, compile_fail, ['']) test('T14605', normal, compile_fail, ['']) test('T14761a', normal, compile_fail, ['']) test('T14761b', normal, compile_fail, ['']) |