Commit 2bbdd00c authored by Simon Peyton Jones's avatar Simon Peyton Jones

Orient TyVar/TyVar equalities with deepest on the left

Trac #15009 showed that, for Given TyVar/TyVar equalities, we really
want to orient them with the deepest-bound skolem on the left. As it
happens, we also want to do the same for Wanteds, but for a different
reason (more likely to be touchable).  Either way, deepest wins:
see TcUnify Note [Deeper level on the left].

This observation led me to some significant changes:

* A SkolemTv already had a TcLevel, but the level wasn't really being
  used.   Now it is!

* I updated added invariant (SkolInf) to TcType
  Note [TcLevel and untouchable type variables], documenting that
  the level number of all the ic_skols should be the same as the
  ic_tclvl of the implication

* FlatSkolTvs and FlatMetaTvs previously had a dummy level-number of
  zero, which messed the scheme up.   Now they get a level number the
  same way as all other TcTyVars, instead of being a special case.

* To make sure that FlatSkolTvs and FlatMetaTvs are untouchable (which
  was previously done via their magic zero level) isTouchableMetaTyVar
  just tests for those two cases.

* TcUnify.swapOverTyVars is the crucial orientation function; see the
  new Note [TyVar/TyVar orientation].  I completely rewrote this function,
  and it's now much much easier to understand.

I ended up doing some related refactoring, of course

* I noticed that tcImplicitTKBndrsX and tcExplicitTKBndrsX were doing
  a lot of useless work in the case where there are no skolems; I
  added a fast-patch

* Elminate the un-used tcExplicitTKBndrsSig; and thereby get rid of
  the higher-order parameter to tcExpliciTKBndrsX.

* Replace TcHsType.emitTvImplication with TcUnify.checkTvConstraints,
  by analogy with TcUnify.checkConstraints.

* Inline TcUnify.buildImplication into its only call-site in
  TcUnify.checkConstraints

* TcS.buildImplication becomes TcS.CheckConstraintsTcS, with a
  simpler API

* Now that we have NoEvBindsVar we have no need of termEvidenceAllowed;
  nuke the latter, adding Note [No evidence bindings] to TcEvidence.
parent efe40544
...@@ -747,14 +747,9 @@ can_eq_nc_forall ev eq_rel s1 s2 ...@@ -747,14 +747,9 @@ can_eq_nc_forall ev eq_rel s1 s2
empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
; (implic, _ev_binds, all_co) <- buildImplication skol_info skol_tvs [] $ ; all_co <- checkConstraintsTcS skol_info skol_tvs $
go skol_tvs empty_subst2 bndrs2 go skol_tvs empty_subst2 bndrs2
-- We have nowhere to put these bindings
-- but TcSimplify.setImplicationStatus
-- checks that we don't actually use them
-- when skol_info = UnifyForAllSkol
; updWorkListTcS (extendWorkListImplic implic)
; setWantedEq orig_dest all_co ; setWantedEq orig_dest all_co
; stopWith ev "Deferred polytype equality" } } ; stopWith ev "Deferred polytype equality" } }
...@@ -1757,24 +1752,6 @@ canEqTyVarTyVar, are these ...@@ -1757,24 +1752,6 @@ canEqTyVarTyVar, are these
substituted out Note [Elminate flat-skols] substituted out Note [Elminate flat-skols]
fsk ~ a fsk ~ a
Note [Eliminate flat-skols]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have [G] Num (F [a])
then we flatten to
[G] Num fsk
[G] F [a] ~ fsk
where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
type instance F [a] = a
then we'll reduce the second constraint to
[G] a ~ fsk
and then replace all uses of 'a' with fsk. That's bad because
in error messages intead of saying 'a' we'll say (F [a]). In all
places, including those where the programmer wrote 'a' in the first
place. Very confusing! See Trac #7862.
Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
the fsk.
Note [Equalities with incompatible kinds] Note [Equalities with incompatible kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What do we do when we have an equality What do we do when we have an equality
......
...@@ -413,10 +413,9 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope ...@@ -413,10 +413,9 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
, ic_given = map (tidyEvVar env1) given , ic_given = map (tidyEvVar env1) given
, ic_info = info' } , ic_info = info' }
ctxt1 | NoEvBindsVar{} <- evb = noDeferredBindings ctxt ctxt1 | NoEvBindsVar{} <- evb = noDeferredBindings ctxt
| termEvidenceAllowed info = ctxt | otherwise = ctxt
| otherwise = noDeferredBindings ctxt
-- If we go inside an implication that has no term -- If we go inside an implication that has no term
-- evidence (i.e. unifying under a forall), we can't defer -- evidence (e.g. unifying under a forall), we can't defer
-- type errors. You could imagine using the /enclosing/ -- type errors. You could imagine using the /enclosing/
-- bindings (in cec_binds), but that may not have enough stuff -- bindings (in cec_binds), but that may not have enough stuff
-- in scope for the bindings to be well typed. So we just -- in scope for the bindings to be well typed. So we just
......
...@@ -401,10 +401,9 @@ data EvBindsVar ...@@ -401,10 +401,9 @@ data EvBindsVar
-- See Note [Tracking redundant constraints] in TcSimplify -- See Note [Tracking redundant constraints] in TcSimplify
} }
| NoEvBindsVar { -- used when we're solving only for equalities, | NoEvBindsVar { -- See Note [No evidence bindings]
-- which don't have bindings
-- see above for comments -- See above for comments on ebv_uniq, evb_tcvs
ebv_uniq :: Unique, ebv_uniq :: Unique,
ebv_tcvs :: IORef CoVarSet ebv_tcvs :: IORef CoVarSet
} }
...@@ -415,6 +414,21 @@ instance Data.Data TcEvBinds where ...@@ -415,6 +414,21 @@ instance Data.Data TcEvBinds where
gunfold _ _ = error "gunfold" gunfold _ _ = error "gunfold"
dataTypeOf _ = Data.mkNoRepType "TcEvBinds" dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
{- Note [No evidence bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Class constraints etc give rise to /term/ bindings for evidence, and
we have nowhere to put term bindings in /types/. So in some places we
use NoEvBindsVar (see newNoTcEvBinds) to signal that no term-level
evidence bindings are allowed. Notebly ():
- Places in types where we are solving kind constraints (all of which
are equalities); see solveEqualities, solveLocalEqualities,
checkTvConstraints
- When unifying forall-types
-}
----------------- -----------------
newtype EvBindMap newtype EvBindMap
= EvBindMap { = EvBindMap {
......
...@@ -18,8 +18,8 @@ module TcHsType ( ...@@ -18,8 +18,8 @@ module TcHsType (
tcHsDeriv, tcHsVectInst, tcHsDeriv, tcHsVectInst,
tcHsTypeApp, tcHsTypeApp,
UserTypeCtxt(..), UserTypeCtxt(..),
tcImplicitTKBndrs, tcImplicitTKBndrsX, tcImplicitTKBndrsSig, tcImplicitTKBndrs, tcImplicitTKBndrsX,
tcExplicitTKBndrs, tcExplicitTKBndrsX, tcExplicitTKBndrsSig, tcExplicitTKBndrs,
kcExplicitTKBndrs, kcImplicitTKBndrs, kcExplicitTKBndrs, kcImplicitTKBndrs,
-- Type checking type and class decls -- Type checking type and class decls
...@@ -247,11 +247,12 @@ tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext ...@@ -247,11 +247,12 @@ tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext
-- kind variables floating about, immediately prior to -- kind variables floating about, immediately prior to
-- kind generalisation -- kind generalisation
-- We use "InKnot", because this is called on class method sigs -- We use the "InKnot" zonker, because this is called
-- in the knot -- on class method sigs in the knot
; ty1 <- zonkPromoteTypeInKnot $ mkSpecForAllTys tkvs ty ; ty1 <- zonkPromoteTypeInKnot $ mkSpecForAllTys tkvs ty
; kvs <- kindGeneralize ty1 ; kvs <- kindGeneralize ty1
; zonkSigType (mkInvForAllTys kvs ty1) } ; zonkSigType (mkInvForAllTys kvs ty1) }
tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen" tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type
...@@ -267,6 +268,7 @@ tc_hs_sig_type skol_info (HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars } ...@@ -267,6 +268,7 @@ tc_hs_sig_type skol_info (HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars }
-- need to promote any remaining metavariables; test case: -- need to promote any remaining metavariables; test case:
-- dependent/should_fail/T14066e. -- dependent/should_fail/T14066e.
; zonkPromoteType (mkSpecForAllTys tkvs ty) } ; zonkPromoteType (mkSpecForAllTys tkvs ty) }
tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"
----------------- -----------------
...@@ -395,7 +397,7 @@ Answer: we use the same rule as for value bindings: ...@@ -395,7 +397,7 @@ Answer: we use the same rule as for value bindings:
* Additionally, we attempt to generalise if we have NoMonoLocalBinds * Additionally, we attempt to generalise if we have NoMonoLocalBinds
Trac #13337 shows the problem if we kind-generalise an open type (i.e. Trac #13337 shows the problem if we kind-generalise an open type (i.e.
one that mentions in-scope tpe variable one that mentions in-scope type variable
foo :: forall k (a :: k) proxy. (Typeable k, Typeable a) foo :: forall k (a :: k) proxy. (Typeable k, Typeable a)
=> proxy a -> String => proxy a -> String
foo _ = case eqT :: Maybe (k :~: Type) of foo _ = case eqT :: Maybe (k :~: Type) of
...@@ -407,7 +409,7 @@ but (Int :: Type). Since (:~:) is kind-homogeneous, this requires ...@@ -407,7 +409,7 @@ but (Int :: Type). Since (:~:) is kind-homogeneous, this requires
k ~ *, which is true in the Refl branch of the outer case. 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 That equality will be solved if we allow it to float out to the
implication constraint for the Refl match, bnot not if we aggressively implication constraint for the Refl match, but not not if we aggressively
attempt to solve all equalities the moment they occur; that is, when attempt to solve all equalities the moment they occur; that is, when
checking (Maybe (a :~: Int)). (NB: solveEqualities fails unless it checking (Maybe (a :~: Int)). (NB: solveEqualities fails unless it
solves all the kind equalities, which is the right thing at top level.) solves all the kind equalities, which is the right thing at top level.)
...@@ -1766,24 +1768,31 @@ tcImplicitTKBndrsX :: (Name -> Kind -> TcM TcTyVar) -- new_tv function ...@@ -1766,24 +1768,31 @@ tcImplicitTKBndrsX :: (Name -> Kind -> TcM TcTyVar) -- new_tv function
-> [Name] -> [Name]
-> TcM a -> TcM a
-> TcM ([TcTyVar], a) -- these tyvars are dependency-ordered -> TcM ([TcTyVar], a) -- these tyvars are dependency-ordered
-- Returned TcTyVars have the supplied HsTyVarBndrs, -- * Guarantees to call solveLocalEqualities to unify
-- but may be in different order to the original [Name] -- all constraints from thing_inside.
--
-- * Returned TcTyVars have the supplied HsTyVarBndrs,
-- but may be in different order to the original [Name]
-- (because of sorting to respect dependency) -- (because of sorting to respect dependency)
-- Returned TcTyVars have zonked kinds --
-- See Note [Keeping scoped variables in order: Implicit] -- * Returned TcTyVars have zonked kinds
-- See Note [Keeping scoped variables in order: Implicit]
tcImplicitTKBndrsX new_tv m_kind skol_info tv_names thing_inside tcImplicitTKBndrsX new_tv m_kind 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) = do { (skol_tvs, result)
<- solveLocalEqualities $ <- solveLocalEqualities $
do { (inner_tclvl, wanted, (skol_tvs, result)) checkTvConstraints skol_info Nothing $
<- pushLevelAndCaptureConstraints $ do { tv_pairs <- mapM (tcHsTyVarName new_tv m_kind) tv_names
do { tv_pairs <- mapM (tcHsTyVarName new_tv m_kind) tv_names ; let must_scope_tvs = [ tv | (tv, False) <- tv_pairs ]
; let must_scope_tvs = [ tv | (tv, False) <- tv_pairs ] ; result <- tcExtendTyVarEnv must_scope_tvs $
; result <- tcExtendTyVarEnv must_scope_tvs $ thing_inside
thing_inside ; return (map fst tv_pairs, result) }
; return (map fst tv_pairs, result) }
; emitTvImplication inner_tclvl skol_tvs Nothing wanted skol_info
; return (skol_tvs, result) }
; skol_tvs <- mapM zonkTcTyCoVarBndr skol_tvs ; skol_tvs <- mapM zonkTcTyCoVarBndr skol_tvs
-- use zonkTcTyCoVarBndr because a skol_tv might be a SigTv -- use zonkTcTyCoVarBndr because a skol_tv might be a SigTv
...@@ -1812,24 +1821,8 @@ tcExplicitTKBndrs :: SkolemInfo ...@@ -1812,24 +1821,8 @@ tcExplicitTKBndrs :: SkolemInfo
-> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
-> TcM a -> TcM a
-> TcM ([TcTyVar], a) -> TcM ([TcTyVar], a)
-- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs
tcExplicitTKBndrs = tcExplicitTKBndrsX newSkolemTyVar
-- | This brings a bunch of tyvars into scope as SigTvs, where they can unify
-- with other type *variables* only.
tcExplicitTKBndrsSig :: SkolemInfo
-> [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
tcExplicitTKBndrsSig = tcExplicitTKBndrsX newSigTyVar
tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar)
-> SkolemInfo
-> [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
-- See also Note [Associated type tyvar names] in Class -- See also Note [Associated type tyvar names] in Class
tcExplicitTKBndrsX new_tv skol_info hs_tvs thing_inside tcExplicitTKBndrs skol_info hs_tvs thing_inside
-- This function brings into scope a telescope of binders as written by -- 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 -- 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. -- them into scope one at a time, bumping the TcLevel each time.
...@@ -1840,11 +1833,16 @@ tcExplicitTKBndrsX new_tv skol_info hs_tvs thing_inside ...@@ -1840,11 +1833,16 @@ tcExplicitTKBndrsX new_tv skol_info hs_tvs thing_inside
-- notice that the telescope is out of order. That's what we do here, -- notice that the telescope is out of order. That's what we do here,
-- following the logic of tcImplicitTKBndrsX. -- following the logic of tcImplicitTKBndrsX.
-- See also Note [Keeping scoped variables in order: Explicit] -- See also Note [Keeping scoped variables in order: Explicit]
= do { (inner_tclvl, wanted, (skol_tvs, result)) --
<- pushLevelAndCaptureConstraints $ -- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs
bind_tvbs hs_tvs | 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) }
; emitTvImplication inner_tclvl skol_tvs (Just doc) wanted skol_info | otherwise
= do { (skol_tvs, result) <- checkTvConstraints skol_info (Just doc) $
bind_tvbs hs_tvs
; traceTc "tcExplicitTKBndrs" $ ; traceTc "tcExplicitTKBndrs" $
vcat [ text "Hs vars:" <+> ppr hs_tvs vcat [ text "Hs vars:" <+> ppr hs_tvs
...@@ -1856,7 +1854,7 @@ tcExplicitTKBndrsX new_tv skol_info hs_tvs thing_inside ...@@ -1856,7 +1854,7 @@ tcExplicitTKBndrsX new_tv skol_info hs_tvs thing_inside
bind_tvbs [] = do { result <- thing_inside bind_tvbs [] = do { result <- thing_inside
; return ([], result) } ; return ([], result) }
bind_tvbs (L _ tvb : tvbs) bind_tvbs (L _ tvb : tvbs)
= do { (tv, in_scope) <- tcHsTyVarBndr new_tv tvb = do { (tv, in_scope) <- tcHsTyVarBndr newSkolemTyVar tvb
; (if in_scope then id else tcExtendTyVarEnv [tv]) $ ; (if in_scope then id else tcExtendTyVarEnv [tv]) $
do { (tvs, result) <- bind_tvbs tvbs do { (tvs, result) <- bind_tvbs tvbs
; return (tv : tvs, result) }} ; return (tv : tvs, result) }}
...@@ -1874,28 +1872,6 @@ kcExplicitTKBndrs (L _ hs_tv : hs_tvs) thing_inside ...@@ -1874,28 +1872,6 @@ kcExplicitTKBndrs (L _ hs_tv : hs_tvs) thing_inside
; tcExtendTyVarEnv [tv] $ ; tcExtendTyVarEnv [tv] $
kcExplicitTKBndrs hs_tvs thing_inside } kcExplicitTKBndrs hs_tvs thing_inside }
-- | Build and emit an Implication appropriate for type-checking a type.
-- This assumes all constraints will be equality constraints, and
-- so does not create an EvBindsVar
emitTvImplication :: TcLevel -- of the constraints
-> [TcTyVar] -- skolems
-> Maybe SDoc -- user-written telescope, if present
-> WantedConstraints
-> SkolemInfo
-> TcM ()
emitTvImplication inner_tclvl skol_tvs m_telescope wanted skol_info
= do { tc_lcl_env <- getLclEnv
; ev_binds <- newNoTcEvBinds
; let implic = newImplication { ic_tclvl = inner_tclvl
, ic_skols = skol_tvs
, ic_telescope = m_telescope
, ic_no_eqs = True
, ic_wanted = wanted
, ic_binds = ev_binds
, ic_info = skol_info
, ic_env = tc_lcl_env }
; emitImplication implic }
tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
-> HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool) -> HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool)
-- Return a TcTyVar, built using the provided function -- Return a TcTyVar, built using the provided function
......
...@@ -512,13 +512,24 @@ tcInstSkolTyVars' overlappable subst tvs ...@@ -512,13 +512,24 @@ tcInstSkolTyVars' overlappable subst tvs
; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs } ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs }
mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyCoVarMaker gbl lcl mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyCoVarMaker gbl lcl
mkTcSkolTyVar lvl loc overlappable old_name kind -- 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 = do { uniq <- newUnique
; let name = mkInternalName uniq (getOccName old_name) loc ; let name = mkInternalName uniq (getOccName old_name) loc
; return (mkTcTyVar name kind details) } ; return (mkTcTyVar name kind details) }
where where
details = SkolemTv (pushTcLevel lvl) overlappable details = SkolemTv (pushTcLevel tc_lvl) overlappable
-- NB: skolems bump the level -- 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.
-}
------------------ ------------------
freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar]) freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])
...@@ -569,9 +580,10 @@ newFskTyVar :: TcType -> TcM TcTyVar ...@@ -569,9 +580,10 @@ newFskTyVar :: TcType -> TcM TcTyVar
newFskTyVar fam_ty newFskTyVar fam_ty
= do { uniq <- newUnique = do { uniq <- newUnique
; ref <- newMutVar Flexi ; ref <- newMutVar Flexi
; tclvl <- getTcLevel
; let details = MetaTv { mtv_info = FlatSkolTv ; let details = MetaTv { mtv_info = FlatSkolTv
, mtv_ref = ref , mtv_ref = ref
, mtv_tclvl = fmvTcLevel } , mtv_tclvl = tclvl }
name = mkMetaTyVarName uniq (fsLit "fsk") name = mkMetaTyVarName uniq (fsLit "fsk")
; return (mkTcTyVar name (typeKind fam_ty) details) } ; return (mkTcTyVar name (typeKind fam_ty) details) }
...@@ -624,9 +636,10 @@ newFmvTyVar :: TcType -> TcM TcTyVar ...@@ -624,9 +636,10 @@ newFmvTyVar :: TcType -> TcM TcTyVar
newFmvTyVar fam_ty newFmvTyVar fam_ty
= do { uniq <- newUnique = do { uniq <- newUnique
; ref <- newMutVar Flexi ; ref <- newMutVar Flexi
; tclvl <- getTcLevel
; let details = MetaTv { mtv_info = FlatMetaTv ; let details = MetaTv { mtv_info = FlatMetaTv
, mtv_ref = ref , mtv_ref = ref
, mtv_tclvl = fmvTcLevel } , mtv_tclvl = tclvl }
name = mkMetaTyVarName uniq (fsLit "s") name = mkMetaTyVarName uniq (fsLit "s")
; return (mkTcTyVar name (typeKind fam_ty) details) } ; return (mkTcTyVar name (typeKind fam_ty) details) }
......
...@@ -636,9 +636,9 @@ tcPatSynMatcher (L loc name) lpat ...@@ -636,9 +636,9 @@ tcPatSynMatcher (L loc name) lpat
(args, arg_tys) pat_ty (args, arg_tys) pat_ty
= do { rr_name <- newNameAt (mkTyVarOcc "rep") loc = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
; tv_name <- newNameAt (mkTyVarOcc "r") loc ; tv_name <- newNameAt (mkTyVarOcc "r") loc
; let rr_tv = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv ; let rr_tv = mkTyVar rr_name runtimeRepTy
rr = mkTyVarTy rr_tv rr = mkTyVarTy rr_tv
res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv res_tv = mkTyVar tv_name (tYPE rr)
res_ty = mkTyVarTy res_tv res_ty = mkTyVarTy res_tv
is_unlifted = null args && null prov_dicts is_unlifted = null args && null prov_dicts
(cont_args, cont_arg_tys) (cont_args, cont_arg_tys)
...@@ -686,7 +686,7 @@ tcPatSynMatcher (L loc name) lpat ...@@ -686,7 +686,7 @@ tcPatSynMatcher (L loc name) lpat
} }
match = mkMatch (mkPrefixFunRhs (L loc name)) [] match = mkMatch (mkPrefixFunRhs (L loc name)) []
(mkHsLams (rr_tv:res_tv:univ_tvs) (mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body') req_dicts body')
(noLoc (EmptyLocalBinds noExt)) (noLoc (EmptyLocalBinds noExt))
mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg :: MatchGroup GhcTc (LHsExpr GhcTc)
mg = MG{ mg_alts = L (getLoc match) [match] mg = MG{ mg_alts = L (getLoc match) [match]
......
...@@ -106,7 +106,6 @@ module TcRnTypes( ...@@ -106,7 +106,6 @@ module TcRnTypes(
SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,
termEvidenceAllowed,
CtEvidence(..), TcEvDest(..), CtEvidence(..), TcEvDest(..),
mkKindLoc, toKindLoc, mkGivenLoc, mkKindLoc, toKindLoc, mkGivenLoc,
...@@ -3228,14 +3227,6 @@ data SkolemInfo ...@@ -3228,14 +3227,6 @@ data SkolemInfo
instance Outputable SkolemInfo where instance Outputable SkolemInfo where
ppr = pprSkolInfo ppr = pprSkolInfo
termEvidenceAllowed :: SkolemInfo -> Bool
-- Whether an implication constraint with this SkolemInfo
-- is permitted to have term-level evidence. There is
-- only one that is not, associated with unifiying
-- forall-types
termEvidenceAllowed (UnifyForAllSkol {}) = False
termEvidenceAllowed _ = True
pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo :: SkolemInfo -> SDoc
-- Complete the sentence "is a rigid type variable bound by..." -- Complete the sentence "is a rigid type variable bound by..."
pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
......
...@@ -16,7 +16,7 @@ module TcSMonad ( ...@@ -16,7 +16,7 @@ module TcSMonad (
TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
failTcS, warnTcS, addErrTcS, failTcS, warnTcS, addErrTcS,
runTcSEqualities, runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS, buildImplication, nestTcS, nestImplicTcS, setEvBindsTcS, checkConstraintsTcS,
runTcPluginTcS, addUsedGRE, addUsedGREs, runTcPluginTcS, addUsedGRE, addUsedGREs,
...@@ -1950,8 +1950,12 @@ getNoGivenEqs tclvl skol_tvs ...@@ -1950,8 +1950,12 @@ getNoGivenEqs tclvl skol_tvs
-- outer context but were refined to an insoluble by -- outer context but were refined to an insoluble by
-- a local equality; so do /not/ add ct_given_here. -- a local equality; so do /not/ add ct_given_here.
; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts ; traceTcS "getNoGivenEqs" $
, ppr insols]) vcat [ if has_given_eqs then text "May have given equalities"
else text "No given equalities"
, text "Skols:" <+> ppr skol_tvs
, text "Inerts:" <+> ppr inerts
, text "Insols:" <+> ppr insols]
; return (not has_given_eqs, insols) } ; return (not has_given_eqs, insols) }
where where
eqs_given_here :: EqualCtList -> Bool eqs_given_here :: EqualCtList -> Bool
...@@ -2094,6 +2098,10 @@ b) 'a' will have been completely substituted out in the inert set, ...@@ -2094,6 +2098,10 @@ b) 'a' will have been completely substituted out in the inert set,
returned as part of 'fsks' returned as part of 'fsks'
For an example, see Trac #9211. For an example, see Trac #9211.
See also TcUnify Note [Deeper level on the left] for how we ensure
that the right variable is on the left of the equality when both are
tyvars.
-} -}
removeInertCts :: [Ct] -> InertCans -> InertCans removeInertCts :: [Ct] -> InertCans -> InertCans
...@@ -2704,40 +2712,40 @@ nestTcS (TcS thing_inside) ...@@ -2704,40 +2712,40 @@ nestTcS (TcS thing_inside)
; return res } ; return res }
buildImplication :: SkolemInfo checkConstraintsTcS :: SkolemInfo
-> [TcTyVar] -- Skolems -> [TcTyVar] -- Skolems
-> [EvVar] -- Givens -> TcS result
-> TcS result -> TcS result
-> TcS (Bag Implication, TcEvBinds, result) -- Just like TcUnify.checkTvConstraints, but in the TcS monnad,
-- Just like TcUnify.buildImplication, but in the TcS monnad,
-- using the work-list to gather the constraints -- using the work-list to gather the constraints
buildImplication skol_info skol_tvs givens (TcS thing_inside) checkConstraintsTcS skol_info skol_tvs (TcS thing_inside)
= TcS $ \ env -> = TcS $ \ tcs_env ->
do { new_wl_var <- TcM.newTcRef emptyWorkList do { new_wl_var <- TcM.newTcRef emptyWorkList
; tc_lvl <- TcM.getTcLevel ; let new_tcs_env = tcs_env { tcs_worklist = new_wl_var }
; let new_tclvl = pushTcLevel tc_lvl
; res <- TcM.setTcLevel new_tclvl $ ; (res, new_tclvl) <- TcM.pushTcLevelM $
thing_inside (env { tcs_worklist = new_wl_var }) thing_inside new_tcs_env
; wl@WL { wl_eqs = eqs } <- TcM.readTcRef new_wl_var ; wl@WL { wl_eqs = eqs } <- TcM.readTcRef new_wl_var
; if null eqs ; ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) &&
then return (emptyBag, emptyTcEvBinds, res) null (wl_implics wl), ppr wl )
else unless (null eqs) $
do { env <- TcM.getLclEnv do { tcl_env <- TcM.getLclEnv
; ev_binds_var <- TcM.newTcEvBinds ; ev_binds_var <- TcM.newNoTcEvBinds
; let wc = ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) && ; let wc = WC { wc_simple = listToCts eqs
null (wl_implics wl), ppr wl ) , wc_impl = emptyBag }
WC { wc_simple = listToCts eqs imp = newImplication { ic_tclvl = new_tclvl
, wc_impl = emptyBag } , ic_skols = skol_tvs
imp = newImplication { ic_tclvl = new_tclvl , ic_wanted = wc
, ic_skols = skol_tvs , ic_binds = ev_binds_var
, ic_given = givens , ic_env = tcl_env
, ic_wanted = wc , ic_info = skol_info }
, ic_binds = ev_binds_var
, ic_env = env -- Add the implication to the work-list
, ic_info = skol_info } ; TcM.updTcRef (tcs_worklist tcs_env)
; return (unitBag imp, TcEvBinds ev_binds_var, res) } } (extendWorkListImplic (unitBag imp)) }
; return res }
{- {-
Note [Propagate the solved dictionaries] Note [Propagate the solved dictionaries]
...@@ -2778,9 +2786,7 @@ getWorkListImplics ...@@ -2778,9 +2786,7 @@ getWorkListImplics
updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
updWorkListTcS f updWorkListTcS f
= do { wl_var <- getTcSWorkListRef = do { wl_var <- getTcSWorkListRef
; wl_curr <- wrapTcS (TcM.readTcRef wl_var) ; wrapTcS (TcM.updTcRef wl_var f)}
; let new_work = f wl_curr
; wrapTcS (TcM.writeTcRef wl_var new_work) }