Commit 5e45ad10 authored by Tobias Dammers's avatar Tobias Dammers 🦈 Committed by Richard Eisenberg

Finish fix for #14880.

The real change that fixes the ticket is described in
Note [Naughty quantification candidates] in TcMType.

Fixing this required reworking candidateQTyVarsOfType, the function
that extracts free variables as candidates for quantification.
One consequence is that we now must be more careful when quantifying:
any skolems around must be quantified manually, and quantifyTyVars
will now only quantify over metavariables. This makes good sense,
as skolems are generally user-written and are listed in the AST.

As a bonus, we now have more control over the ordering of such
skolems.

Along the way, this commit fixes #15711 and refines the fix
to #14552 (by accepted a program that was previously rejected,
as we can now accept that program by zapping variables to Any).

This commit also does a fair amount of rejiggering kind inference
of datatypes. Notably, we now can skip the generalization step
in kcTyClGroup for types with CUSKs, because we get the
kind right the first time. This commit also thus fixes #15743 and
 #15592, which both concern datatype kind generalisation.
(#15591 is also very relevant.) For this aspect of the commit, see
Note [Required, Specified, and Inferred in types] in TcTyClsDecls.

Test cases: dependent/should_fail/T14880{,-2},
            dependent/should_fail/T15743[cd]
            dependent/should_compile/T15743{,e}
            ghci/scripts/T15743b
            polykinds/T15592
            dependent/should_fail/T15591[bc]
            ghci/scripts/T15591
parent e8a652f6
......@@ -405,6 +405,23 @@ sameVis Required _ = False
sameVis _ Required = False
sameVis _ _ = True
instance Outputable ArgFlag where
ppr Required = text "[req]"
ppr Specified = text "[spec]"
ppr Inferred = text "[infrd]"
instance Binary ArgFlag where
put_ bh Required = putByte bh 0
put_ bh Specified = putByte bh 1
put_ bh Inferred = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return Required
1 -> return Specified
_ -> return Inferred
{- *********************************************************************
* *
* VarBndr, TyCoVarBinder
......@@ -469,6 +486,19 @@ mkTyVarBinders vis = map (mkTyVarBinder vis)
isTyVarBinder :: TyCoVarBinder -> Bool
isTyVarBinder (Bndr v _) = isTyVar v
instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
ppr (Bndr v Required) = ppr v
ppr (Bndr v Specified) = char '@' <> ppr v
ppr (Bndr v Inferred) = braces (ppr v)
instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where
put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }
get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }
instance NamedThing tv => NamedThing (VarBndr tv flag) where
getName (Bndr tv _) = getName tv
{-
************************************************************************
* *
......@@ -524,35 +554,6 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
-------------------------------------
instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
ppr (Bndr v Required) = ppr v
ppr (Bndr v Specified) = char '@' <> ppr v
ppr (Bndr v Inferred) = braces (ppr v)
instance Outputable ArgFlag where
ppr Required = text "[req]"
ppr Specified = text "[spec]"
ppr Inferred = text "[infrd]"
instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where
put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }
get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }
instance Binary ArgFlag where
put_ bh Required = putByte bh 0
put_ bh Specified = putByte bh 1
put_ bh Inferred = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return Required
1 -> return Specified
_ -> return Inferred
{-
%************************************************************************
%* *
......
......@@ -237,6 +237,7 @@ unitDVarSet = unitUniqDSet
mkDVarSet :: [Var] -> DVarSet
mkDVarSet = mkUniqDSet
-- The new element always goes to the right of existing ones.
extendDVarSet :: DVarSet -> Var -> DVarSet
extendDVarSet = addOneToUniqDSet
......
......@@ -101,7 +101,7 @@ sortQuantVars :: [Var] -> [Var]
sortQuantVars vs = sorted_tcvs ++ ids
where
(tcvs, ids) = partition (isTyVar <||> isCoVar) vs
sorted_tcvs = toposortTyVars tcvs
sorted_tcvs = scopedSort tcvs
-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "CoreSyn#let_app_invariant")
......
......@@ -862,7 +862,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs
-- Add extra tyvar binders: Note [Free tyvars in rule LHS]
-- and extra dict binders: Note [Free dictionaries in rule LHS]
mk_extra_bndrs fn_id args
= toposortTyVars unbound_tvs ++ unbound_dicts
= scopedSort unbound_tvs ++ unbound_dicts
where
unbound_tvs = [ v | v <- unbound_vars, isTyVar v ]
unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
......
......@@ -2015,8 +2015,8 @@ tyThingParent_maybe (AConLike cl) = case cl of
RealDataCon dc -> Just (ATyCon (dataConTyCon dc))
PatSynCon{} -> Nothing
tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of
Just cls -> Just (ATyCon (classTyCon cls))
Nothing -> Nothing
Just tc -> Just (ATyCon tc)
Nothing -> Nothing
tyThingParent_maybe (AnId id) = case idDetails id of
RecSelId { sel_tycon = RecSelData tc } ->
Just (ATyCon tc)
......
......@@ -14,6 +14,8 @@ mkBoxedTupleTy :: [Type] -> Type
coercibleTyCon, heqTyCon :: TyCon
unitTy :: Type
liftedTypeKind :: Kind
constraintKind :: Kind
......
......@@ -827,7 +827,7 @@ bindHsQTyVars :: forall a b.
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-- The Bool is True <=> all kind variables used in the
-- kind signature are bound on the left. Reason:
-- the TypeInType clause of Note [Complete user-supplied
-- the last clause of Note [CUSKs: Complete user-supplied
-- kind signatures] in HsDecls
-> RnM (b, FreeVars)
......@@ -840,7 +840,6 @@ bindHsQTyVars :: forall a b.
bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
= do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
; rdr_env <- getLocalRdrEnv
; let -- See Note [bindHsQTyVars examples] for what
-- all these various things are doing
......@@ -850,8 +849,7 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
-- Make sure to list the binder kvs before the
-- body kvs, as mandated by
-- Note [Ordering of implicit variables]
implicit_kvs = filter_occs rdr_env bndrs kv_occs
-- Deleting bndrs: See Note [Kind-variable ordering]
implicit_kvs = filter_occs bndrs kv_occs
-- dep_bndrs is the subset of bndrs that are dependent
-- i.e. appear in bndr/body_kv_occs
-- Can't use implicit_kvs because we've deleted bndrs from that!
......@@ -879,17 +877,15 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
all_bound_on_lhs } }
where
filter_occs :: LocalRdrEnv -- In scope
-> [Located RdrName] -- Bound here
filter_occs :: [Located RdrName] -- Bound here
-> [Located RdrName] -- Potential implicit binders
-> [Located RdrName] -- Final implicit binders
-- Filter out any potential implicit binders that are either
-- already in scope, or are explicitly bound here
filter_occs rdr_env bndrs occs
-- already in scope, or are explicitly bound in the same HsQTyVars
filter_occs bndrs occs
= filterOut is_in_scope occs
where
is_in_scope locc@(L _ occ) = isJust (lookupLocalRdrEnv rdr_env occ)
|| locc `elemRdr` bndrs
is_in_scope locc = locc `elemRdr` bndrs
{- Note [bindHsQTyVars examples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1586,9 +1582,8 @@ must come after any variables mentioned in their kinds.
typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ...
The k comes first because a depends on k, even though the k appears later than
the a in the code. Thus, GHC does a *stable topological sort* on the variables.
By "stable", we mean that any two variables who do not depend on each other
preserve their existing left-to-right ordering.
the a in the code. Thus, GHC does ScopedSort on the variables.
See Note [ScopedSort] in Type.
Implicitly bound variables are collected by any function which returns a
FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
......
......@@ -87,8 +87,7 @@ import Literal ( litIsTrivial )
import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
import Name ( getOccName, mkSystemVarName )
import OccName ( occNameString )
import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType )
import TyCoRep ( closeOverKindsDSet )
import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )
import BasicTypes ( Arity, RecFlag(..), isRec )
import DataCon ( dataConOrigResTy )
import TysWiredIn
......
......@@ -1763,7 +1763,7 @@ abstractFloats dflags top_lvl main_tvs floats body
rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
-- tvs_here: see Note [Which type variables to abstract over]
tvs_here = toposortTyVars $
tvs_here = scopedSort $
filter (`elemVarSet` main_tv_set) $
closeOverKindsList $
exprSomeFreeVarsList isTyVar rhs'
......@@ -1791,7 +1791,7 @@ abstractFloats dflags top_lvl main_tvs floats body
-- If you ever want to be more selective, remember this bizarre case too:
-- x::a = x
-- Here, we must abstract 'x' over 'a'.
tvs_here = toposortTyVars main_tvs
tvs_here = scopedSort main_tvs
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 tvs_here var
......
......@@ -2091,7 +2091,7 @@ callToPats env bndr_occs call@(Call _ args con_env)
-- See Note [Shadowing] at the top
(ktvs, ids) = partition isTyVar qvars
qvars' = toposortTyVars ktvs ++ map sanitise ids
qvars' = scopedSort ktvs ++ map sanitise ids
-- Order into kind variables, type variables, term variables
-- The kind of a type variable may mention a kind variable
-- and the type of a term variable may mention a type variable
......
......@@ -168,7 +168,13 @@ newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
-- Note [Linting type synonym applications].
case lintTypes dflags tcvs' (rhs':lhs') of
Nothing -> pure ()
Just fail_msg -> pprPanic "Core Lint error" fail_msg
Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg
, ppr fam_tc
, ppr subst
, ppr tvs'
, ppr cvs'
, ppr lhs'
, ppr rhs' ])
; return (FamInst { fi_fam = tyConName fam_tc
, fi_flavor = flavor
, fi_tcs = roughMatchTcs lhs
......@@ -893,7 +899,7 @@ unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn
has_kinds = not $ isEmptyVarSet invis_vars
doc = sep [ what <+> text "variable" <>
pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . toposortTyVars)
pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)
, text "cannot be inferred from the right-hand side." ]
what = case (has_types, has_kinds) of
(True, True) -> text "Type and kind"
......
......@@ -514,8 +514,8 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
rhs' = substTyUnchecked subst' rhs_ty
tcv' = tyCoVarsOfTypesList pat_tys'
(tv', cv') = partition isTyVar tcv'
tvs' = toposortTyVars tv'
cvs' = toposortTyVars cv'
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'
fam_tc pat_tys' rhs'
......
......@@ -815,7 +815,7 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
final_tkvs = tyCoVarsOfTypesWellScoped $
final_cls_tys ++ final_tc_args
; let tkvs = toposortTyVars $ fvVarList $
; let tkvs = scopedSort $ fvVarList $
unionFV (tyCoFVsOfTypes tc_args_to_keep)
(FV.mkFVs deriv_tvs)
Just kind_subst = mb_match
......
......@@ -485,7 +485,7 @@ reportBadTelescope ctxt env (Just telescope) skols
text "are out of dependency order. Perhaps try this ordering:")
2 (pprTyVars sorted_tvs)
sorted_tvs = toposortTyVars skols
sorted_tvs = scopedSort skols
reportBadTelescope _ _ Nothing skols
= pprPanic "reportBadTelescope" (ppr skols)
......
......@@ -1840,8 +1840,8 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
(rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
rep_tvs' = toposortTyVars rep_tvs
rep_cvs' = toposortTyVars rep_cvs
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
......
......@@ -434,8 +434,8 @@ tc_mkRepFamInsts gk tycon inst_tys =
repTy' = substTy subst repTy
tcv' = tyCoVarsOfTypeList inst_ty
(tv', cv') = partition isTyVar tcv'
tvs' = toposortTyVars tv'
cvs' = toposortTyVars cv'
tvs' = scopedSort tv'
cvs' = scopedSort cv'
axiom = mkSingleCoAxiom Nominal rep_name tvs' cvs'
fam_tc inst_tys repTy'
......
......@@ -423,7 +423,7 @@ zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
zonkTyBndrX env tv
= ASSERT( isImmutableTyVar tv )
= ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
-- Internal names tidy up better, for iface files.
; let tv' = mkTyVar (tyVarName tv) ki
......
This diff is collapsed.
......@@ -648,7 +648,7 @@ tcDataFamInstDecl mb_clsinfo
; (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
ty_binders orig_res_ty cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
......
This diff is collapsed.
......@@ -164,13 +164,6 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
(prov_theta, prov_evs)
= unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
-- Report bad universal type variables
-- See Note [Type variables whose kind is captured]
; let bad_tvs = [ tv | tv <- univ_tvs
, tyCoVarsOfType (tyVarKind tv)
`intersectsVarSet` ex_tv_set ]
; mapM_ (badUnivTvErr ex_tvs) bad_tvs
-- Report coercions that esacpe
-- See Note [Coercions that escape]
; args <- mapM zonkId args
......@@ -217,20 +210,6 @@ mkProvEvidence ev_id
pred = evVarPred ev_id
eq_con_args = [evId ev_id]
badUnivTvErr :: [TyVar] -> TyVar -> TcM ()
-- See Note [Type variables whose kind is captured]
badUnivTvErr ex_tvs bad_tv
= addErrTc $
vcat [ text "Universal type variable" <+> quotes (ppr bad_tv)
<+> text "has existentially bound kind:"
, nest 2 (ppr_with_kind bad_tv)
, hang (text "Existentially-bound variables:")
2 (vcat (map ppr_with_kind ex_tvs))
, text "Probable fix: give the pattern synonym a type signature"
]
where
ppr_with_kind tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
......@@ -293,37 +272,6 @@ marginally less efficient, if the builder/martcher are not inlined.
See also Note [Lift equality constaints when quantifying] in TcType
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?)
So we just fail in this case, with a pretty terrible error message.
Maybe we could do better, but I can't see how. (It'd be possible to
default 's' to (Any k), but that probably isn't what the user wanted,
and it not straightforward to implement, because by the time we see
the problem, simplifyInfer has already skolemised 's'.)
This stuff can only happen in the presence of view patterns, with
PolyKinds, so it's a bit of a corner case.
Note [Coercions that escape]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trac #14507 showed an example where the inferred type of the matcher
......
......@@ -86,8 +86,8 @@ tcRule (HsRule { rd_ext = ext
; (stuff,_) <- pushTcLevelM $
generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
; let (id_bndrs, lhs', lhs_wanted
, rhs', rhs_wanted, rule_ty, tc_lvl) = stuff
; let (tv_bndrs, id_bndrs, lhs', lhs_wanted
, rhs', rhs_wanted, rule_ty, tc_lvl) = stuff
; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
, ppr lhs_wanted
......@@ -110,14 +110,16 @@ tcRule (HsRule { rd_ext = ext
-- during zonking (see TcHsSyn.zonkRule)
; let tpl_ids = lhs_evs ++ id_bndrs
; forall_tkvs <- zonkTcTypesAndSplitDepVars $
rule_ty : map idType tpl_ids
; gbls <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level
-- monomorphic bindings from the MR; test tc111
; forall_tkvs <- candidateQTyVarsOfTypes gbls $
map (mkSpecForAllTys tv_bndrs) $ -- don't quantify over lexical tyvars
rule_ty : map idType tpl_ids
; qtkvs <- quantifyTyVars gbls forall_tkvs
; traceTc "tcRule" (vcat [ pprFullRuleName rname
, ppr forall_tkvs
, ppr qtkvs
, ppr tv_bndrs
, ppr rule_ty
, vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
])
......@@ -127,10 +129,11 @@ tcRule (HsRule { rd_ext = ext
-- For the LHS constraints we must solve the remaining constraints
-- (a) so that we report insoluble ones
-- (b) so that we bind any soluble ones
; let skol_info = RuleSkol name
; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs
; let all_qtkvs = qtkvs ++ tv_bndrs
skol_info = RuleSkol name
; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
lhs_evs residual_lhs_wanted
; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs
; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
lhs_evs rhs_wanted
; emitImplications (lhs_implic `unionBags` rhs_implic)
......@@ -138,14 +141,15 @@ tcRule (HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
, rd_tyvs = ty_bndrs -- preserved for ppr-ing
, rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids)
, rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
tcRule (XRuleDecl _) = panic "tcRule"
generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
-> LHsExpr GhcRn -> LHsExpr GhcRn
-> TcM ( [TcId]
-> TcM ( [TyVar]
, [TcId]
, LHsExpr GhcTc, WantedConstraints
, LHsExpr GhcTc, WantedConstraints
, TcType
......@@ -166,9 +170,7 @@ generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
; (rhs', rhs_wanted) <- captureConstraints $
tcMonoExpr rhs (mkCheckExpType rule_ty)
; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
; return (id_bndrs, lhs', all_lhs_wanted
, rhs', rhs_wanted, rule_ty, lvl) } }
-- Slightly curious that tv_bndrs is not returned
; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty, lvl) } }
-- See Note [TcLevel in type checking rules]
tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
......
......@@ -105,7 +105,7 @@ module TcSMonad (
zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
zonkTyCoVarsAndFVList,
zonkSimples, zonkWC,
zonkTcTyCoVarBndr,
zonkTyCoVarKind,
-- References
newTcRef, readTcRef, writeTcRef, updTcRef,
......@@ -3095,14 +3095,7 @@ pprEq :: TcType -> TcType -> SDoc
pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
isFilledMetaTyVar_maybe tv
= case tcTyVarDetails tv of
MetaTv { mtv_ref = ref }
-> do { cts <- readTcRef ref
; case cts of
Indirect ty -> return (Just ty)
Flexi -> return Nothing }
_ -> return Nothing
isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)
isFilledMetaTyVar :: TcTyVar -> TcS Bool
isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
......@@ -3131,8 +3124,8 @@ zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
zonkWC :: WantedConstraints -> TcS WantedConstraints
zonkWC wc = wrapTcS (TcM.zonkWC wc)
zonkTcTyCoVarBndr :: TcTyCoVar -> TcS TcTyCoVar
zonkTcTyCoVarBndr tv = wrapTcS (TcM.zonkTcTyCoVarBndr tv)
zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
{- *********************************************************************
* *
......
......@@ -349,9 +349,9 @@ 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 zonkTcTyCoVarBndr implicit_tvs
; univ_tvs <- mapM zonkTcTyCoVarBndr univ_tvs
; ex_tvs <- mapM zonkTcTyCoVarBndr ex_tvs
; implicit_tvs <- mapM zonkTyCoVarKind implicit_tvs
; univ_tvs <- mapM zonkTyCoVarKind univ_tvs
; ex_tvs <- mapM zonkTyCoVarKind ex_tvs
; req <- zonkTcTypes req
; prov <- zonkTcTypes prov
; body_ty <- zonkTcType body_ty
......
......@@ -674,7 +674,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 <- zonkTcTypesAndSplitDepVars (map snd name_taus)
; dep_vars <- candidateQTyVarsOfTypes gbl_tvs (map snd name_taus)
; qtkvs <- quantifyTyVars gbl_tvs dep_vars
; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }
......@@ -1083,8 +1083,12 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
; (prom, _) <- promoteTyVarSet mono_tvs
-- Default any kind/levity vars
; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
= candidateQTyVarsOfTypes candidates
; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
<- candidateQTyVarsOfTypes mono_tvs candidates
-- any covars should already be handled by
-- the logic in decideMonoTyVars, which looks at
-- the constraints generated
; poly_kinds <- xoptM LangExt.PolyKinds
; default_kvs <- mapM (default_one poly_kinds True)
(dVarSetElems cand_kvs)
......@@ -1150,11 +1154,10 @@ 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)
; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
= candidateQTyVarsOfTypes $
psig_tys ++ candidates ++ tau_tys
pick = (`dVarSetIntersectVarSet` grown_tcvs)
dvs_plus = DV { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes mono_tvs $
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
......@@ -1696,7 +1699,7 @@ checkBadTelescope :: Implication -> TcS Bool
checkBadTelescope (Implic { ic_telescope = m_telescope
, ic_skols = skols })
| isJust m_telescope
= do{ skols <- mapM TcS.zonkTcTyCoVarBndr skols
= do{ skols <- mapM TcS.zonkTyCoVarKind skols
; return (go emptyVarSet (reverse skols))}
| otherwise
......
This diff is collapsed.
......@@ -104,7 +104,6 @@ module TcType (
-- * Finding "exact" (non-dead) type variables
exactTyCoVarsOfType, exactTyCoVarsOfTypes,
candidateQTyVarsOfType, candidateQTyVarsOfTypes, CandidatesQTvs(..),
anyRewritableTyVar,
---------------------------------
......@@ -181,7 +180,7 @@ module TcType (
pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
pprTCvBndr, pprTCvBndrs,
TypeSize, sizeType, sizeTypes, toposortTyVars,
TypeSize, sizeType, sizeTypes, scopedSort,
---------------------------------
-- argument visibility
......@@ -225,11 +224,10 @@ import FastString
import ErrUtils( Validity(..), MsgDoc, isValid )
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( mapAccumL )
import Data.List ( mapAccumL, foldl' )
import Data.Functor.Identity( Identity(..) )
import Data.IORef
import Data.List.NonEmpty( NonEmpty(..) )
import qualified Data.Semigroup as Semi
{-
************************************************************************
......@@ -1007,149 +1005,6 @@ would re-occur and we end up with an infinite loop in which each kicks
out the other (Trac #14363).
-}
{- *********************************************************************
* *
Type and kind variables in a type
* *
********************************************************************* -}
data CandidatesQTvs -- See Note [Dependent type variables]
-- See Note [CandidatesQTvs determinism and order]
= DV { dv_kvs :: DTyCoVarSet -- "kind" variables (dependent)
, dv_tvs :: DTyVarSet -- "type" variables (non-dependent)
-- A variable may appear in both sets
-- E.g. T k (x::k) The first occurrence of k makes it
-- show up in dv_tvs, the second in dv_kvs
-- See Note [Dependent type variables]
}
instance Semi.Semigroup CandidatesQTvs where
(DV { dv_kvs = kv1, dv_tvs = tv1 }) <> (DV { dv_kvs = kv2, dv_tvs = tv2 })
= DV { dv_kvs = kv1 `unionDVarSet` kv2
, dv_tvs = tv1 `unionDVarSet` tv2}
instance Monoid CandidatesQTvs where
mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }
mappend = (Semi.<>)
instance Outputable CandidatesQTvs where
ppr (DV {dv_kvs = kvs, dv_tvs = tvs })
= text "DV" <+> braces (sep [ text "dv_kvs =" <+> ppr kvs
, text "dv_tvs =" <+> ppr tvs ])
{- Note [Dependent type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Haskell type inference we quantify over type variables; but we only
quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds
we default the kind variables to *.
So, to support this defaulting, and only for that reason, when
collecting the free vars of a type, prior to quantifying, we must keep
the type and kind variables separate.
But what does that mean in a system where kind variables /are/ type
variables? It's a fairly arbitrary distinction based on how the
variables appear:
- "Kind variables" appear in the kind of some other free variable
PLUS any free coercion variables
These are the ones we default to * if -XPolyKinds is off
- "Type variables" are all free vars that are not kind variables
E.g. In the type T k (a::k)
'k' is a kind variable, because it occurs in the kind of 'a',
even though it also appears at "top level" of the type
'a' is a type variable, because it doesn't
We gather these variables using a CandidatesQTvs record:
DV { dv_kvs: Variables free in the kind of a free type variable
or of a forall-bound type variable