Commit c955a514 authored by Richard Eisenberg's avatar Richard Eisenberg

Remove decideKindGeneralisationPlan

TypeInType came with a new function: decideKindGeneralisationPlan.
This type-level counterpart to the term-level decideGeneralisationPlan
chose whether or not a kind should be generalized. The thinking was
that if `let` should not be generalized, then kinds shouldn't either
(under the same circumstances around -XMonoLocalBinds).

However, this is too conservative -- the situation described in the
motivation for "let should be be generalized" does not occur in types.

This commit thus removes decideKindGeneralisationPlan, always
generalizing.

One consequence is that tc_hs_sig_type_and_gen no longer calls
solveEqualities, which reports all unsolved constraints, instead
relying on the solveLocalEqualities in tcImplicitTKBndrs. An effect
of this is that reporing kind errors gets delayed more frequently.
This seems to be a net benefit in error reporting; often, alongside
a kind error, the type error is now reported (and users might find
type errors easier to understand).

Some of these errors ended up at the top level, where it was
discovered that the GlobalRdrEnv containing the definitions in the
local module was not in the TcGblEnv, and thus errors were reported
with qualified names unnecessarily. This commit rejiggers some of
the logic around captureTopConstraints accordingly.

One error message (typecheck/should_fail/T1633)
is a regression, mentioning the name of a default method. However,
that problem is already reported as #10087, its solution is far from
clear, and so I'm not addressing it here.

This commit fixes #15141. As it's an internal refactor, there is
no concrete test case for it.

Along the way, we no longer need the hsib_closed field of
HsImplicitBndrs (it was used only in decideKindGeneralisationPlan)
and so it's been removed, simplifying the datatype structure.

Along the way, I removed code in the validity checker that looks
at coercions. This isn't related to this patch, really (though
it was, at one point), but it's an improvement, so I kept it.

This updates the haddock submodule.
parent c50574a8
......@@ -204,7 +204,7 @@ get_scoped_tvs (L _ signature)
-- Both implicit and explicit quantified variables
-- We need the implicit ones for f :: forall (a::k). blah
-- here 'k' scopes too
| HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_vars }
| HsIB { hsib_ext = implicit_vars
, hsib_body = hs_ty } <- sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars
......@@ -544,7 +544,7 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 }
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_ext = HsIBRn { hsib_vars = var_names }
repTyFamEqn (HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_pats = tys
, feqn_rhs = rhs }})
= do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
......@@ -561,7 +561,7 @@ repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = HsIBRn { hsib_vars = var_names }
(HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_pats = tys
, feqn_rhs = defn }})})
......@@ -651,7 +651,7 @@ repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig _ n sig))
| HsWC { hswc_body = HsIB { hsib_ext = HsIBRn { hsib_vars = vars } }} <- sig
| HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
= unLoc n : vars
ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
= panic "ruleBndrNames"
......@@ -1042,7 +1042,7 @@ repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
repCtxt preds
repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
repHsSigType (HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_tvs }
repHsSigType (HsIB { hsib_ext = implicit_tvs
, hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
= addSimpleTyVarBinds implicit_tvs $
......
......@@ -20,7 +20,7 @@ module HsTypes (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..), HsQTvsRn(..),
HsImplicitBndrs(..), HsIBRn(..),
HsImplicitBndrs(..),
HsWildCardBndrs(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
......@@ -332,23 +332,18 @@ isEmptyLHsQTvs _ = False
-- | Haskell Implicit Binders
data HsImplicitBndrs pass thing -- See Note [HsType binders]
= HsIB { hsib_ext :: XHsIB pass thing
= HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name]
-- Implicitly-bound kind & type vars
-- Order is important; see
-- Note [Ordering of implicit variables]
, hsib_body :: thing -- Main payload (type or list of types)
}
| XHsImplicitBndrs (XXHsImplicitBndrs pass thing)
data HsIBRn
= HsIBRn { hsib_vars :: [Name] -- Implicitly-bound kind & type vars
-- Order is important; see
-- Note [Ordering of implicit variables]
, hsib_closed :: Bool -- Taking the hsib_vars into account,
-- is the payload closed? Used in
-- TcHsType.decideKindGeneralisationPlan
} deriving Data
type instance XHsIB GhcPs _ = NoExt
type instance XHsIB GhcRn _ = HsIBRn
type instance XHsIB GhcTc _ = HsIBRn
type instance XHsIB GhcRn _ = [Name]
type instance XHsIB GhcTc _ = [Name]
type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt
......@@ -429,9 +424,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
mkEmptyImplicitBndrs x = HsIB { hsib_ext = HsIBRn
{ hsib_vars = []
, hsib_closed = False }
mkEmptyImplicitBndrs x = HsIB { hsib_ext = []
, hsib_body = x }
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
......@@ -928,7 +921,7 @@ hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
-- because they scope in the same way
hsWcScopedTvs sig_ty
| HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsIB { hsib_ext = HsIBRn { hsib_vars = vars}
, HsIB { hsib_ext = vars
, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
......@@ -942,7 +935,7 @@ hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs"
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
hsScopedTvs sig_ty
| HsIB { hsib_ext = HsIBRn { hsib_vars = vars }
| HsIB { hsib_ext = vars
, hsib_body = sig_ty2 } <- sig_ty
, L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
= vars ++ map hsLTyVarName tvs
......@@ -1132,7 +1125,7 @@ splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
-> ([Name], LHsContext GhcRn, LHsType GhcRn)
-- Split up an instance decl type, returning the pieces
splitLHsInstDeclTy (HsIB { hsib_ext = HsIBRn { hsib_vars = itkvs }
splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
, hsib_body = inst_ty })
| (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty
= (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
......
......@@ -765,8 +765,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
all_fvs = fvs `addOneFV` unLoc tycon'
-- type instance => use, hence addOneFV
; return (HsIB { hsib_ext = HsIBRn { hsib_vars = all_ibs
, hsib_closed = True }
; return (HsIB { hsib_ext = all_ibs
, hsib_body
= FamEqn { feqn_ext = noExt
, feqn_tycon = tycon'
......@@ -1691,7 +1690,7 @@ rnLDerivStrategy doc mds thing_inside
NewtypeStrategy -> boring_case (L loc NewtypeStrategy)
ViaStrategy via_ty ->
do (via_ty', fvs1) <- rnHsSigType doc via_ty
let HsIB { hsib_ext = HsIBRn { hsib_vars = via_imp_tvs }
let HsIB { hsib_ext = via_imp_tvs
, hsib_body = via_body } = via_ty'
(via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
......
......@@ -127,7 +127,8 @@ rn_hs_sig_wc_type always_bind_free_tvs ctxt
; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1
ib_ty' = HsIB { hsib_ext = vars
, hsib_body = hs_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
......@@ -300,7 +301,9 @@ rnHsSigType ctx (HsIB { hsib_body = hs_ty })
; vars <- extractFilteredRdrTyVarsDups hs_ty
; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
; return ( HsIB { hsib_ext = vars
, hsib_body = body' }
, fvs ) } }
rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
......@@ -367,18 +370,6 @@ rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
-- Do not try to decompose the inst_ty in case it is malformed
rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
mk_implicit_bndrs :: [Name] -- implicitly bound
-> a -- payload
-> FreeVars -- FreeVars of payload
-> HsImplicitBndrs GhcRn a
mk_implicit_bndrs vars body fvs
= HsIB { hsib_ext = HsIBRn
{ hsib_vars = vars
, hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
, hsib_body = body }
{- ******************************************************
* *
LHsType and HsType
......
......@@ -713,17 +713,14 @@ tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType ctxt
(HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = HsIBRn
{ hsib_vars = vars
, hsib_closed = closed }
(HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
, hsib_body = deriv_ty_body })})
| (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 = HsIBRn { hsib_vars = vars
, hsib_closed = closed }
HsIB { hsib_ext = vars
, hsib_body
= L (getLoc deriv_ty_body) $
HsForAllTy { hst_bndrs = tvs
......
......@@ -614,8 +614,10 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
tvs
_other -> tvs `unionVarSet` id_tvs
where
id_tvs = tyCoVarsOfType (idType id)
is_closed_type = not (anyVarSet isTyVar id_tvs)
id_ty = idType id
id_tvs = tyCoVarsOfType id_ty
id_co_tvs = closeOverKinds (coVarsOfType id_ty)
is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))
-- We only care about being closed wrt /type/ variables
-- E.g. a top-level binding might have a type like
-- foo :: t |> co
......
......@@ -38,6 +38,7 @@ module TcHsType (
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
failIfEmitsConstraints,
solveEqualities, -- useful re-export
typeLevelMode, kindLevelMode,
......@@ -69,6 +70,7 @@ import TcUnify
import TcIface
import TcSimplify
import TcHsSyn
import TcErrors ( reportAllUnsolved )
import TcType
import Inst ( tcInstTyBinders, tcInstTyBinder )
import TyCoRep( TyBinder(..) ) -- Used in tcDataKindSig
......@@ -178,7 +180,7 @@ 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
, hsib_ext = HsIBRn { hsib_vars = sig_vars }})
, hsib_ext = sig_vars })
= addSigCtxt (funsSigCtxt names) hs_ty $
discardResult $
tcImplicitTKBndrs skol_info sig_vars $
......@@ -205,10 +207,7 @@ tcHsSigType ctxt sig_ty
-- of kind * in a Template Haskell quote eg [t| Maybe |]
-- Generalise here: see Note [Kind generalisation]
; do_kind_gen <- decideKindGeneralisationPlan sig_ty
; ty <- if do_kind_gen
then tc_hs_sig_type_and_gen skol_info sig_ty kind >>= zonkTcType
else tc_hs_sig_type skol_info sig_ty kind
; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind >>= zonkTcType
; checkValidType ctxt ty
; traceTc "end tcHsSigType }" (ppr ty)
......@@ -222,38 +221,23 @@ tc_hs_sig_type_and_gen :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type
-- 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
= HsIBRn { hsib_vars = sig_vars }
tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext = sig_vars
, hsib_body = hs_ty }) kind
= do { (tkvs, ty) <- solveEqualities $
tcImplicitTKBndrs skol_info sig_vars $
tc_lhs_type typeLevelMode hs_ty kind
-- NB the call to solveEqualities, which unifies all those
-- kind variables floating about, immediately prior to
-- kind generalisation
; ty1 <- zonkPromoteType $ mkSpecForAllTys tkvs ty
; kvs <- kindGeneralize ty1
= 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
; kvs <- kindGeneralizeLocal wanted ty1
; emitConstraints wanted -- we still need to solve these
; return (mkInvForAllTys kvs ty1) }
tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type
-- Kind-check/desugar a 'LHsSigType', but does not solve
-- the equalities that arise from doing so; instead it may
-- emit kind-equality constraints into the monad
-- Zonking, but no validity checking
tc_hs_sig_type skol_info (HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars }
, hsib_body = hs_ty }) kind
= do { (tkvs, ty) <- tcImplicitTKBndrs skol_info sig_vars $
tc_lhs_type typeLevelMode hs_ty kind
-- need to promote any remaining metavariables; test case:
-- dependent/should_fail/T14066e.
; zonkPromoteType (mkSpecForAllTys tkvs ty) }
tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"
-----------------
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
......@@ -330,7 +314,14 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt
-- Like tcHsSigType, but for a class instance declaration
tcHsClsInstType user_ctxt hs_inst_ty
= setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
do { inst_ty <- tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) hs_inst_ty constraintKind
{- 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 emptyZonkEnv inst_ty
; checkValidInstance user_ctxt hs_inst_ty inst_ty }
......@@ -345,6 +336,12 @@ tcHsTypeApp wc_ty kind
-- signature so we want to solve its equalities right now
tcWildCardBinders sig_wcs $ \ _ ->
tcCheckLHsType hs_ty kind
-- We must promote here. Ex:
-- f :: forall a. a
-- g = f @(forall b. Proxy b -> ()) @Int ...
-- After when processing the @Int, we'll have to check its kind
-- against the as-yet-unknown kind of b. This check causes an assertion
-- failure if we don't promote.
; ty <- zonkPromoteType ty
; checkValidType TypeAppCtxt ty
; return ty }
......@@ -392,50 +389,7 @@ tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty)
where
mode = allowUnsaturated typeLevelMode
---------------------------
-- | Should we generalise the kind of this type signature?
-- We *should* generalise if the type is closed
-- or if NoMonoLocalBinds is set. Otherwise, nope.
-- See Note [Kind generalisation plan]
decideKindGeneralisationPlan :: LHsSigType GhcRn -> TcM Bool
decideKindGeneralisationPlan sig_ty@(HsIB { hsib_ext
= HsIBRn { hsib_closed = closed } })
= do { mono_locals <- xoptM LangExt.MonoLocalBinds
; let should_gen = not mono_locals || closed
; traceTc "decideKindGeneralisationPlan"
(ppr sig_ty $$ text "should gen?" <+> ppr should_gen)
; return should_gen }
decideKindGeneralisationPlan(XHsImplicitBndrs _)
= panic "decideKindGeneralisationPlan"
{- Note [Kind generalisation plan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When should we do kind-generalisation for user-written type signature?
Answer: we use the same rule as for value bindings:
* We always kind-generalise if the type signature is closed
* Additionally, we attempt to generalise if we have NoMonoLocalBinds
Trac #13337 shows the problem if we kind-generalise an open type (i.e.
one that mentions in-scope type variable
foo :: forall k (a :: k) proxy. (Typeable k, Typeable a)
=> proxy a -> String
foo _ = case eqT :: Maybe (k :~: Type) of
Nothing -> ...
Just Refl -> case eqT :: Maybe (a :~: Int) of ...
In the expression type sig on the last line, we have (a :: k)
but (Int :: Type). Since (:~:) is kind-homogeneous, this requires
k ~ *, which is true in the Refl branch of the outer case.
That equality will be solved if we allow it to float out to the
implication constraint for the Refl match, but not not if we aggressively
attempt to solve all equalities the moment they occur; that is, when
checking (Maybe (a :~: Int)). (NB: solveEqualities fails unless it
solves all the kind equalities, which is the right thing at top level.)
So here the right thing is simply not to do kind generalisation!
{-
************************************************************************
* *
Type-checking modes
......@@ -1495,9 +1449,10 @@ Checking a user-written signature requires several steps:
1. Generate constraints.
2. Solve constraints.
3. Zonk and promote tyvars.
4. (Optional) Kind-generalize.
5. Check validity.
3. Zonk.
4. Promote tyvars and/or kind-generalize.
5. Zonk.
6. Check validity.
There may be some surprises in here:
......@@ -1507,12 +1462,34 @@ to get these in the right order (see Note [Keeping scoped variables in
order: Implicit]). Additionally, solving is necessary in order to
kind-generalize correctly.
Step 3 requires *promoting* type variables. If there are any foralls
in a type, the TcLevel will be bumped within the forall. This might
lead to the generation of matavars with a high level. If we don't promote,
we violate MetaTvInv of Note [TcLevel and untouchable type variables]
In Step 4, we have to deal with the fact that metatyvars generated
in the type may have a bumped TcLevel, because explicit foralls
raise the TcLevel. To avoid these variables from every being visible
in the surrounding context, we must obey the following dictum:
Every metavariable in a type must either be
(A) promoted, or
(B) generalized.
If a variable is generalized, then it becomes a skolem and no longer
has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as
it's not really in play here.) On the other hand, if it is not
generalized (because we're not generalizing the construct -- e.g., pattern
sig -- or because the metavars are constrained -- see kindGeneralizeLocal)
we need to promote to (MetaTvInv) of Note [TcLevel and untouchable type variables]
in TcType.
After promoting/generalizing, we need to zonk *again* because both
promoting and generalizing fill in metavariables.
To avoid the double-zonk, we do two things:
1. zonkPromoteType and friends zonk and promote at the same time.
Accordingly, the function does setps 3-5 all at once, preventing
the need for multiple traversals.
2. kindGeneralize does not require a zonked type -- it zonks as it
gathers free variables. So this way effectively sidesteps step 3.
-}
tcWildCardBinders :: [Name]
......@@ -1921,14 +1898,36 @@ 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
-- type variables. So in both cases, all the free vars are kind vars
-- Input must be zonked.
-- Input needn't be zonked.
-- NB: You must call solveEqualities or solveLocalEqualities before
-- kind generalization
kindGeneralize kind_or_type
= do { let kvs = tyCoVarsOfTypeDSet kind_or_type
dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet }
kindGeneralize = kindGeneralizeLocal emptyWC
-- | This variant of 'kindGeneralize' refuses to generalize over any
-- variables free in the given WantedConstraints. Instead, it promotes
-- these variables into an outer TcLevel. See also
-- Note [Promoting unification variables] in TcSimplify
kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]
kindGeneralizeLocal wanted kind_or_type
= do {
-- This bit is very much like decideMonoTyVars in TcSimplify,
-- but constraints are so much simpler in kinds, it is much
-- easier here. (In particular, we never quantify over a
-- constraint in a type.)
; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)
; (_, constrained) <- promoteTyVarSet constrained
-- NB: zonk here, after promotion
; kvs <- zonkTcTypeAndFV kind_or_type
; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet }
; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
; quantifyTyVars gbl_tvs dvs }
; traceTc "kindGeneralizeLocal" (vcat [ ppr wanted
, ppr kind_or_type
, ppr constrained
, ppr dvs ])
; quantifyTyVars (gbl_tvs `unionVarSet` constrained) dvs }
{-
Note [Kind generalisation]
......@@ -2268,7 +2267,7 @@ tcHsPartialSigType
-- See Note [Recipe for checking a signature]
tcHsPartialSigType ctxt sig_ty
| HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_hs_tvs }
, HsIB { hsib_ext = implicit_hs_tvs
, hsib_body = hs_ty } <- ib_ty
, (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
= addSigCtxt ctxt hs_ty $
......@@ -2392,7 +2391,7 @@ tcHsPatSigType :: UserTypeCtxt
-- See Note [Recipe for checking a signature]
tcHsPatSigType ctxt sig_ty
| HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars}
, HsIB { hsib_ext = sig_vars
, hsib_body = hs_ty } <- ib_ty
= addSigCtxt ctxt hs_ty $
do { sig_tkvs <- mapM new_implicit_tv sig_vars
......@@ -2406,6 +2405,9 @@ tcHsPatSigType ctxt sig_ty
-- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty
-- contains a forall). Promote these.
-- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...
-- When we instantiate x, we have to compare the kind of the argument
-- to a's kind, which will be a metavariable.
; sig_ty <- zonkPromoteType sig_ty
; checkValidType ctxt sig_ty
......@@ -2582,7 +2584,7 @@ unifyKinds rn_tys act_kinds
-- to make sure that any free meta-tyvars in the type are promoted to the
-- current TcLevel. (They might be at a higher level due to the level-bumping
-- in tcExplicitTKBndrs, for example.) This function both zonks *and*
-- promotes.
-- promotes. Why at the same time? See Note [Recipe for checking a signature]
zonkPromoteType :: TcType -> TcM TcType
zonkPromoteType = mapType zonkPromoteMapper ()
......@@ -2618,10 +2620,8 @@ zonkPromoteTcTyVar tv
= do { let ref = metaTyVarRef tv
; contents <- readTcRef ref
; case contents of
Flexi -> do { promoted <- promoteTyVar tv
; if promoted
then zonkPromoteTcTyVar tv -- read it again
else mkTyVarTy <$> zonkPromoteTyCoVarKind tv }
Flexi -> do { (_, promoted_tv) <- promoteTyVar tv
; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }
Indirect ty -> zonkPromoteType ty }
| isTcTyVar tv && isSkolemTyVar tv -- NB: isSkolemTyVar says "True" to pure TyVars
......@@ -2667,6 +2667,7 @@ tcLHsKindSig ctxt hs_kind
= do { kind <- solveLocalEqualities $
tc_lhs_kind kindLevelMode hs_kind
; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
-- No generalization, so we must promote
; kind <- zonkPromoteType kind
-- This zonk is very important in the case of higher rank kinds
-- E.g. Trac #13879 f :: forall (p :: forall z (y::z). <blah>).
......@@ -2762,3 +2763,14 @@ 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;
-- 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
; reportAllUnsolved lie
; return res
}
......@@ -588,9 +588,8 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
-- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext
= HsIBRn { hsib_vars = tv_names }
, hsib_body =
(L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
, hsib_body =
FamEqn { feqn_pats = pats
, feqn_tycon = fam_tc_name
, feqn_fixity = fixity
......
......@@ -1307,6 +1307,8 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
-- variables free in anything (term-level or type-level) in scope. We thus
-- don't have to worry about clashes with things that are not in scope, because
-- if they are reachable, then they'll be returned here.
-- NB: This is closed over kinds, so it can return unification variables mentioned
-- in the kinds of in-scope tyvars.
tcGetGlobalTyCoVars :: TcM TcTyVarSet
tcGetGlobalTyCoVars
= do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
......
......@@ -391,14 +391,14 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-> TcM TcGblEnv
tcRnSrcDecls explicit_mod_hdr decls
= do { -- Do all the declarations
; ((tcg_env, tcl_env), lie) <- captureTopConstraints $
do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
-- Check for the 'main' declaration
-- Must do this inside the captureTopConstraints
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
; return (tcg_env, tcl_env) }
-- Check for the 'main' declaration
-- Must do this inside the captureTopConstraints
; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
-- always set envs *before* captureTopConstraints
captureTopConstraints $
checkMain explicit_mod_hdr
; setEnvs (tcg_env, tcl_env) $ do {
......@@ -412,7 +412,7 @@ tcRnSrcDecls explicit_mod_hdr decls
-- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
; new_ev_binds <- {-# SCC "simplifyTop" #-}
simplifyTop lie
simplifyTop (lie `andWC` lie_main)
-- Emit Typeable bindings
; tcg_env <- mkTypeableBinds
......@@ -470,16 +470,17 @@ run_th_modfinalizers = do
then getEnvs
else do
writeTcRef th_modfinalizers_var []
(envs, lie) <- captureTopConstraints $ do
sequence_ th_modfinalizers
-- Finalizers can add top-level declarations with addTopDecls.
tc_rn_src_decls []
setEnvs envs $ do
(_, lie_th) <- captureTopConstraints $
sequence_ th_modfinalizers
-- Finalizers can add top-level declarations with addTopDecls, so
-- we have to run tc_rn_src_decls to get them
(tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
setEnvs (tcg_env