Commit faec8d35 authored by Richard Eisenberg's avatar Richard Eisenberg

Track type variable scope more carefully.

The main job of this commit is to track more accurately the scope
of tyvars introduced by user-written foralls. For example, it would
be to have something like this:

  forall a. Int -> (forall k (b :: k). Proxy '[a, b]) -> Bool

In that type, a's kind must be k, but k isn't in scope. We had a
terrible way of doing this before (not worth repeating or describing
here, but see the old tcImplicitTKBndrs and friends), but now
we have a principled approach: make an Implication when kind-checking
a forall. Doing so then hooks into the existing machinery for
preventing skolem-escape, performing floating, etc. This also means
that we bump the TcLevel whenever going into a forall.

The new behavior is done in TcHsType.scopeTyVars, but see also
TcHsType.tc{Im,Ex}plicitTKBndrs, which have undergone significant
rewriting. There are several Notes near there to guide you. Of
particular interest there is that Implication constraints can now
have skolems that are out of order; this situation is reported in
TcErrors.

A major consequence of this is a slightly tweaked process for type-
checking type declarations. The new Note [Use SigTvs in kind-checking
pass] in TcTyClsDecls lays it out.

The error message for dependent/should_fail/TypeSkolEscape has become
noticeably worse. However, this is because the code in TcErrors goes to
some length to preserve pre-8.0 error messages for kind errors. It's time
to rip off that plaster and get rid of much of the kind-error-specific
error messages. I tried this, and doing so led to a lovely error message
for TypeSkolEscape. So: I'm accepting the error message quality regression
for now, but will open up a new ticket to fix it, along with a larger
error-message improvement I've been pondering. This applies also to
dependent/should_fail/{BadTelescope2,T14066,T14066e}, polykinds/T11142.

Other minor changes:
 - isUnliftedTypeKind didn't look for tuples and sums. It does now.

 - check_type used check_arg_type on both sides of an AppTy. But the left
   side of an AppTy isn't an arg, and this was causing a bad error message.
   I've changed it to use check_type on the left-hand side.

 - Some refactoring around when we print (TYPE blah) in error messages.
   The changes decrease the times when we do so, to good effect.
   Of course, this is still all controlled by
   -fprint-explicit-runtime-reps

Fixes #14066 #14749

Test cases: dependent/should_compile/{T14066a,T14749},
            dependent/should_fail/T14066{,c,d,e,f,g,h}
parent ca535f95
......@@ -894,7 +894,11 @@ mkDataCon name declared_infix prom_info
== Set.fromList (binderVars user_tvbs)
user_tvbs' =
ASSERT2( user_tvbs_invariant
, ppr univ_tvs $$ ppr ex_tvs $$ ppr user_tvbs )
, (vcat [ ppr name
, ppr univ_tvs
, ppr ex_tvs
, ppr eq_spec
, ppr user_tvbs ]) )
user_tvbs
con = MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
......
......@@ -35,7 +35,7 @@
module Var (
-- * The main data type and synonyms
Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,
TyVar, TypeVar, KindVar, TKVar, TyCoVar,
TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,
-- * In and Out variants
InVar, InCoVar, InId, InTyVar,
......@@ -128,6 +128,9 @@ type TyVar = Var -- Type *or* kind variable (historical)
-- | Type or Kind Variable
type TKVar = Var -- Type *or* kind variable (historical)
-- | Type variable that might be a metavariable
type TcTyVar = Var
-- | Type Variable
type TypeVar = Var -- Definitely a type variable
......@@ -378,8 +381,9 @@ updateVarTypeM f id = do { ty' <- f (varType id)
-- permitted by request ('Specified') (visible type application), or
-- prohibited entirely from appearing in source Haskell ('Inferred')?
-- See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] in TyCoRep
data ArgFlag = Required | Specified | Inferred
deriving (Eq, Data)
data ArgFlag = Inferred | Specified | Required
deriving (Eq, Ord, Data)
-- (<) on ArgFlag meant "is less visible than"
-- | Does this 'ArgFlag' classify an argument that is written in Haskell?
isVisibleArgFlag :: ArgFlag -> Bool
......
......@@ -1167,6 +1167,6 @@ badUseOfLevPolyPrimop id ty
levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
levPolyPrimopErr primop ty bad_tys
= errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
2 (ppr primop <+> dcolon <+> ppr ty)
2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
, hang (text "Levity-polymorphic arguments:")
2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ]
2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
......@@ -19,7 +19,7 @@
module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDerivingClause(..), LHsDerivingClause,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl,
......@@ -35,7 +35,7 @@ module HsDecls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
FamInstEqn, LFamInstEqn, FamEqn(..),
......@@ -958,7 +958,7 @@ famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- all un-associated open families have CUSKs!
-- all un-associated open families have CUSKs
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......@@ -1114,6 +1114,11 @@ data NewOrData
| DataType -- ^ @data Blah ...@
deriving( Eq, Data ) -- Needed because Demand derives Eq
-- | Convert a 'NewOrData' to a 'TyConFlavour'
newOrDataToFlavour :: NewOrData -> TyConFlavour
newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour
-- | Located data Constructor Declaration
type LConDecl pass = Located (ConDecl pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
......
......@@ -1036,13 +1036,13 @@ splitLHsSigmaTy ty
= (tvs, ctxt, ty2)
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsParTy ty)) = splitLHsForAllTy ty
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t
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 (L _ (HsParTy t)) = splitLHsQualTy t
splitLHsQualTy body = (noLoc [], body)
splitLHsInstDeclTy :: LHsSigType GhcRn
......
......@@ -53,6 +53,7 @@ module IfaceType (
import GhcPrelude
import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy )
import DynFlags
import TyCon hiding ( pprPromotionQuote )
......@@ -671,7 +672,7 @@ overhead.
For this reason it was decided that we would hide RuntimeRep variables for now
(see #11549). We do this by defaulting all type variables of kind RuntimeRep to
PtrLiftedRep. This is done in a pass right before pretty-printing
LiftedRep. This is done in a pass right before pretty-printing
(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
-}
......@@ -690,8 +691,8 @@ PtrLiftedRep. This is done in a pass right before pretty-printing
-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
--
defaultRuntimeRepVars :: IfaceType -> IfaceType
defaultRuntimeRepVars = go emptyFsEnv
defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
defaultRuntimeRepVars sty = go emptyFsEnv
where
go :: FastStringEnv () -> IfaceType -> IfaceType
go subs (IfaceForAllTy bndr ty)
......@@ -707,12 +708,27 @@ defaultRuntimeRepVars = go emptyFsEnv
var :: IfLclName
(var, var_kind) = binderVar bndr
go subs (IfaceTyVar tv)
go subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go _ ty@(IfaceFreeTyVar tv)
| userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
-- don't require -fprint-explicit-runtime-reps for good debugging output
= IfaceTyConApp liftedRep ITC_Nil
| otherwise
= ty
go subs (IfaceFunTy kind ty)
= IfaceFunTy (go subs kind) (go subs ty)
go subs (IfaceTyConApp tc tc_args)
= IfaceTyConApp tc (go_args subs tc_args)
go subs (IfaceTupleTy sort is_prom tc_args)
= IfaceTupleTy sort is_prom (go_args subs tc_args)
go subs (IfaceFunTy arg res)
= IfaceFunTy (go subs arg) (go subs res)
go subs (IfaceAppTy x y)
= IfaceAppTy (go subs x) (go subs y)
......@@ -723,7 +739,13 @@ defaultRuntimeRepVars = go emptyFsEnv
go subs (IfaceCastTy x co)
= IfaceCastTy (go subs x) co
go _ other = other
go _ ty@(IfaceLitTy {}) = ty
go _ ty@(IfaceCoercionTy {}) = ty
go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
go_args _ ITC_Nil = ITC_Nil
go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
liftedRep :: IfaceTyCon
liftedRep =
......@@ -739,7 +761,7 @@ eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitRuntimeReps dflags
then f ty
else f (defaultRuntimeRepVars ty)
else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
instance Outputable IfaceTcArgs where
ppr tca = pprIfaceTcArgs tca
......
......@@ -74,9 +74,13 @@ import Data.Maybe ( catMaybes )
----------------
toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceKind (tyVarKind tyvar)
)
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceTypeX fr (tyVarKind tyvar)
)
toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
......@@ -120,7 +124,7 @@ toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType
| otherwise = IfaceTyVar (toIfaceTyVar tv)
toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy t1 t2)
| isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
......@@ -160,7 +164,10 @@ toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis
toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
toIfaceForAllBndrX :: VarSet -> TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndrX fr (TvBndr v vis) = TvBndr (toIfaceTvBndrX fr v) vis
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
......
......@@ -1008,5 +1008,3 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
r_dying_br = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
live_branch_only)
-- See Note [Unique Determinism and code generation]
......@@ -2025,12 +2025,16 @@ tupleRepDataConKey = mkPreludeDataConUnique 72
sumRepDataConKey = mkPreludeDataConUnique 73
-- See Note [Wiring in RuntimeRep] in TysWiredIn
runtimeRepSimpleDataConKeys :: [Unique]
runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(
liftedRepDataConKey : _)
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
= map mkPreludeDataConUnique [74..82]
unliftedRepDataConKeys = vecRepDataConKey :
tupleRepDataConKey :
sumRepDataConKey :
unliftedSimpleRepDataConKeys
-- See Note [Wiring in RuntimeRep] in TysWiredIn
-- VecCount
vecCountDataConKeys :: [Unique]
......
......@@ -40,7 +40,7 @@ import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe)
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import TysPrim
import TysWiredIn( mkBoxedTupleTy )
import Id
......@@ -987,14 +987,14 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
| otherwise -- Can't happen; by now we know it's a partial sig
= pprPanic "report_sig_tv_err" (ppr sig)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcTyVar
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
choose_psig_context _ annotated_theta Nothing
= do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
`unionVarSet` tau_tvs)
; return (free_tvs, annotated_theta) }
choose_psig_context psig_qtvs annotated_theta (Just wc_var)
choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
= do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
-- growThetaVars just like the no-type-sig case
-- Omitting this caused #12844
......@@ -1012,7 +1012,13 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
| pred <- my_theta
, all (not . (`eqType` pred)) annotated_theta ]
; ctuple <- mk_ctuple inferred_diff
; writeMetaTyVar wc_var ctuple
; case tcGetCastedTyVar_maybe wc_var_ty of
-- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
-- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
-- make the kinds work out, we reverse the cast here.
Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
; traceTc "completeTheta" $
vcat [ ppr sig
......@@ -1517,6 +1523,7 @@ 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]
= tcExtendTyVarEnv2 wcs $
tcExtendTyVarEnv2 skol_prs $
thing_inside
......@@ -1656,6 +1663,30 @@ 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.
************************************************************************
* *
Generalisation
......
......@@ -144,11 +144,15 @@ tcClassSigs clas sigs def_methods
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
skol_info = TyConSkol ClassFlavour clas
tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
-> TcM [TcMethInfo]
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
; op_ty <- tcClassSigType op_names op_hs_ty -- Class tyvars already in scope
; op_ty <- tcClassSigType skol_info op_names op_hs_ty
-- Class tyvars already in scope
; traceTc "ClsSig 2" (ppr op_names)
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
......@@ -157,7 +161,7 @@ tcClassSigs clas sigs def_methods
| otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
= do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
{-
......@@ -194,6 +198,9 @@ 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
......@@ -276,7 +283,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
, sig_loc = getLoc (hsSigType hs_ty) }
; (ev_binds, (tc_bind, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $
<- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
......
......@@ -717,6 +717,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
= setSrcSpan (getLoc (hsSigType deriv_pred)) $
-- Use loc of the 'deriving' item
do { (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 $
tcHsDeriv deriv_pred
-- Deriving preds may (now) mention
......
......@@ -401,10 +401,18 @@ 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
= tcExtendTyVarEnv2 (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.
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside
-- this should be used only for explicitly mentioned scoped variables.
......
This diff is collapsed.
......@@ -401,6 +401,14 @@ data EvBindsVar
-- See Note [Tracking redundant constraints] in TcSimplify
}
| NoEvBindsVar { -- used when we're solving only for equalities,
-- which don't have bindings
-- see above for comments
ebv_uniq :: Unique,
ebv_tcvs :: IORef CoVarSet
}
instance Data.Data TcEvBinds where
-- Placeholder; we can't travers into TcEvBinds
toConstr _ = abstractConstr "TcEvBinds"
......@@ -873,9 +881,11 @@ instance Outputable TcEvBinds where
instance Outputable EvBindsVar where
ppr (EvBindsVar { ebv_uniq = u })
= text "EvBindsVar" <> angleBrackets (ppr u)
ppr (NoEvBindsVar { ebv_uniq = u })
= text "NoEvBindsVar" <> angleBrackets (ppr u)
instance Uniquable EvBindsVar where
getUnique (EvBindsVar { ebv_uniq = u }) = u
getUnique = ebv_uniq
instance Outputable EvBind where
ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given })
......
......@@ -1518,6 +1518,7 @@ zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
= do { bs <- readMutVar ref
; zonkEvBinds env (evBindMapBinds bs) }
zonkEvBindsVar env (NoEvBindsVar {}) = return (env, emptyBag)
zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds env binds
......
This diff is collapsed.
......@@ -479,9 +479,9 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
-- Next, process any associated types.
; traceTc "tcLocalInstDecl" (ppr poly_ty)
; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
; tyfam_insts0 <- scopeTyVars InstSkol tyvars $
mapAndRecoverM (tcTyFamInstDecl mb_info) ats
; datafam_stuff <- tcExtendTyVarEnv tyvars $
; 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
......@@ -1282,6 +1282,8 @@ 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
= tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
-- The lexical_tvs scope over the 'where' part
do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
......
......@@ -393,9 +393,11 @@ runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
runSolverPipeline pipeline workItem
= do { wl <- getWorkList
; inerts <- getTcSInerts
; tclevel <- getTcLevel
; traceTcS "----------------------------- " empty
; traceTcS "Start solver pipeline {" $
vcat [ text "work item =" <+> ppr workItem
vcat [ text "tclevel =" <+> ppr tclevel
, text "work item =" <+> ppr workItem
, text "inerts =" <+> ppr inerts
, text "rest of worklist =" <+> ppr wl ]
......@@ -673,6 +675,18 @@ that this chain of events won't happen, but that's very fragile.)
interactIrred
* *
*********************************************************************************
Note [Multiple matching irreds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You might think that it's impossible to have multiple irreds all match the
work item; after all, interactIrred looks for matches and solves one from the
other. However, note that interacting insoluble, non-droppable irreds does not
do this matching. We thus might end up with several insoluble, non-droppable,
matching irreds in the inert set. When another irred comes along that we have
not yet labeled insoluble, we can find multiple matches. These multiple matches
cause no harm, but it would be wrong to ASSERT that they aren't there (as we
once had done). This problem can be tickled by typecheck/should_compile/holes.
-}
-- Two pieces of irreducible evidence: if their types are *exactly identical*
......@@ -690,10 +704,10 @@ interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })
= continueWith workItem
| let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
, ((ct_i, swap) : rest) <- bagToList matching_irreds
, ((ct_i, swap) : _rest) <- bagToList matching_irreds
-- See Note [Multiple matching irreds]
, let ev_i = ctEvidence ct_i
= ASSERT( null rest )
do { what_next <- solveOneFromTheOther ev_i ev_w
= do { what_next <- solveOneFromTheOther ev_i ev_w
; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)
; case what_next of
KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
......
......@@ -45,7 +45,7 @@ module TcMType (
newEvVar, newEvVars, newDict,
newWanted, newWanteds, cloneWanted, cloneWC,
emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
newTcEvBinds, addTcEvBind,
newTcEvBinds, newNoTcEvBinds, addTcEvBind,
newCoercionHole, fillCoercionHole, isFilledCoercionHole,
unpackCoercionHole, unpackCoercionHole_maybe,
......@@ -55,13 +55,13 @@ module TcMType (
-- Instantiation
newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
newMetaSigTyVars, newMetaSigTyVarX,
newSigTyVar, newWildCardX,
newSigTyVar, newSkolemTyVar, newWildCardX,
tcInstType,
tcInstSkolTyVars,tcInstSkolTyVarsX,
tcInstSuperSkolTyVarsX,
tcSkolDFunType, tcSuperSkolTyVars,
instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX,
instSkolTyCoVarsX, freshenTyVarBndrs, freshenCoVarBndrsX,
--------------------------------
-- Zonking and tidying
......@@ -78,6 +78,7 @@ module TcMType (
zonkTcTyCoVarBndr, zonkTcTyVarBinder,
zonkTcType, zonkTcTypes, zonkCo,
zonkTyCoVarKind, zonkTcTypeMapper,
zonkTcTypeInKnot,
zonkEvVar, zonkWC, zonkSimples,
zonkId, zonkCoVar,
......@@ -147,6 +148,7 @@ newMetaKindVar :: TcM TcKind
newMetaKindVar = do { uniq <- newUnique
; details <- newMetaDetails TauTv
; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details
; traceTc "newMetaKindVar" (ppr kv)
; return (mkTyVarTy kv) }
newMetaKindVars :: Int -> TcM [TcKind]
......@@ -607,7 +609,14 @@ instead of the buggous
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { details <- newMetaDetails SigTv
; return (mkTcTyVar name kind details) }
; let tyvar = mkTcTyVar name kind details
; traceTc "newSigTyVar" (ppr tyvar)
; return tyvar }
-- makes a new skolem tv
newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
newSkolemTyVar name kind = do { lvl <- getTcLevel
; return (mkTcTyVar name kind (SkolemTv lvl False)) }
newFmvTyVar :: TcType -> TcM TcTyVar
-- Very like newMetaTyVar, except sets mtv_tclvl to one less
......@@ -638,7 +647,9 @@ cloneMetaTyVar tv
details' = case tcTyVarDetails tv of
details@(MetaTv {}) -> details { mtv_ref = ref }
_ -> pprPanic "cloneMetaTyVar" (ppr tv)
; return (mkTcTyVar name' (tyVarKind tv) details') }
tyvar = mkTcTyVar name' (tyVarKind tv) details'
; traceTc "cloneMetaTyVar" (ppr tyvar)
; return tyvar }
-- Works for both type and kind variables
readMetaTyVar :: TyVar -> TcM MetaDetails
......@@ -700,9 +711,7 @@ writeMetaTyVarRef tyvar ref ty
; zonked_ty <- zonkTcType ty
; let zonked_ty_kind = typeKind zonked_ty -- need to zonk even before typeKind;
-- otherwise, we can panic in piResultTy
kind_check_ok = isPredTy tv_kind -- Don't check kinds for updates
-- to coercion variables. TODO (RAE): Why not?
|| isConstraintKind zonked_tv_kind
kind_check_ok = isConstraintKind zonked_tv_kind
|| tcEqKind zonked_ty_kind zonked_tv_kind
-- Hack alert! isConstraintKind: see TcHsType
-- Note [Extra-constraint holes in partial type signatures]
......@@ -802,7 +811,9 @@ newAnonMetaTyVar meta_info kind
FlatSkolTv -> fsLit "fsk"
SigTv -> fsLit "a"
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
; let tyvar = mkTcTyVar name kind details
; traceTc "newAnonMetaTyVar" (ppr tyvar)
; return tyvar }
cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
-- Same as newAnonMetaTyVar, but use a supplied TyVar as the source of the print-name
......@@ -811,7 +822,9 @@ cloneAnonMetaTyVar info tv kind
; details <- newMetaDetails info
; let name = mkSystemName uniq (getOccName tv)
-- See Note [Name of an instantiated type variable]
; return (mkTcTyVar name kind details) }
tyvar = mkTcTyVar name kind details
; traceTc "cloneAnonMetaTyVar" (ppr tyvar)
; return tyvar }
{- Note [Name of an instantiated type variable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -922,7 +935,7 @@ also free in the type. Eg
Typeable k (a::k)
has free vars {k,a}. But the type (see Trac #7916)
(f::k->*) (a::k)
has free vars {f,a}, but we must add 'k' as well! Hence step (3).
has free vars {f,a}, but we must add 'k' as well! Hence step (2).
* This function distinguishes between dependent and non-dependent
variables only to keep correct defaulting behavior with -XNoPolyKinds.
......@@ -1007,6 +1020,10 @@ quantifyTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })
-- * Kind variables, with -XNoPolyKinds: don't quantify over these
-- * RuntimeRep variables: we never quantify over these
zonk_quant default_kind tkv
| not (isTyVar tkv)
= 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
......@@ -1526,11 +1543,17 @@ zonkCo :: Coercion -> TcM Coercion
zonkCo = mapCoercion zonkTcTypeMapper ()
zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar
-- A tyvar binder is never a unification variable (MetaTv),
-- rather it is always a skolems. BUT it may have a kind
-- A tyvar binder is never a unification variable (TauTv),
-- rather it is always a skolem. It *might* be a SigTv.
-- (Because non-CUSK type declarations use SigTvs.)
-- Regardless, it may have a kind
-- that has not yet been zonked, and may include kind
-- unification variables.
zonkTcTyCoVarBndr tyvar
| isSigTyVar tyvar
= tcGetTyVar "zonkTcTyCoVarBndr SigTv" <$> zonkTcTyVar tyvar
| otherwise
-- can't use isCoVar, because it looks at a TyCon. Argh.
= ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar )
updateTyVarKindM zonkTcType tyvar
......@@ -1724,8 +1747,8 @@ formatLevPolyErr :: Type -- levity-polymorphic type
-> SDoc
formatLevPolyErr ty