diff options
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcCanonical.hs | 50 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs | 30 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 9 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.hs | 12 | ||||
| -rw-r--r-- | compiler/typecheck/TcMType.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 47 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.hs | 8 |
9 files changed, 85 insertions, 95 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index c2d21bd9fb..30b6c5a0e5 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -849,27 +849,22 @@ dsEvTerm (EvCast tm co) -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. -dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms - ; return (Var df `mkTyApps` tys `mkApps` tms') } - +dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms)) dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox dsEvTerm (EvTupleSel v n) - = do { tm' <- dsEvTerm v - ; let scrut_ty = exprType tm' + = do { let scrut_ty = idType v (tc, tys) = splitTyConApp scrut_ty Just [dc] = tyConDataCons_maybe tc xs = mkTemplateLocals tys the_x = getNth xs n ; ASSERT( isTupleTyCon tc ) return $ - Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } + Case (Var v) (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } dsEvTerm (EvTupleMk tms) - = do { tms' <- mapM dsEvTerm tms - ; let tys = map exprType tms' - ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' } + = return (Var (dataConWorkId dc) `mkTyApps` map idType tms `mkApps` map Var tms) where dc = tupleCon ConstraintTuple (length tms) @@ -878,7 +873,6 @@ dsEvTerm (EvSuperClass d n) ; let (cls, tys) = getClassPredTys (exprType d') sc_sel_id = classSCSelId cls n -- Zero-indexed ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } - where dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] where diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index bb86fcd661..bd8b3ba49e 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -189,13 +189,13 @@ canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct) canTuple ev preds | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev = do { new_evars <- mapM (newWantedEvVar loc) preds - ; setWantedEvBind evar (EvTupleMk (map (ctEvTerm . fst) new_evars)) + ; setWantedEvBind evar (EvTupleMk (map (ctEvId . fst) new_evars)) ; emitWorkNC (freshGoals new_evars) -- Note the "NC": these are fresh goals, not necessarily canonical ; stopWith ev "Decomposed tuple constraint" } - | CtGiven { ctev_evtm = tm, ctev_loc = loc } <- ev - = do { let mk_pr pred i = (pred, EvTupleSel tm i) + | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev + = do { let mk_pr pred i = (pred, EvTupleSel evar i) ; given_evs <- newGivenEvVars loc (zipWith mk_pr preds [0..]) ; emitWorkNC given_evs ; stopWith ev "Decomposed tuple constraint" } @@ -353,9 +353,9 @@ newSCWorkFromFlavored flavor cls xis = return () -- Deriveds don't yield more superclasses because we will -- add them transitively in the case of wanteds. - | CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- flavor + | CtGiven { ctev_evar = evar, ctev_loc = loc } <- flavor = do { let sc_theta = immSuperClasses cls xis - mk_pr sc_pred i = (sc_pred, EvSuperClass ev_tm i) + mk_pr sc_pred i = (sc_pred, EvSuperClass (EvId evar) i) ; given_evs <- newGivenEvVars loc (zipWith mk_pr sc_theta [0..]) ; emitWorkNC given_evs } @@ -666,8 +666,8 @@ can_eq_app ev s1 t1 s2 t2 ; let co = mkTcAppCo (ctEvCoercion ev_s) co_t ; setWantedEvBind evar (EvCoercion co) ; canEqNC ev_s NomEq s1 s2 } - | CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- ev - = do { let co = evTermCoercion ev_tm + | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev + = do { let co = mkTcCoVarCo evar co_s = mkTcLRCo CLeft co co_t = mkTcLRCo CRight co ; evar_s <- newGivenEvVar loc (mkTcEqPred s1 s2, EvCoercion co_s) @@ -730,8 +730,8 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 -> do { cos <- zipWith3M (unifyWanted loc) tc_roles tys1 tys2 ; setWantedEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) } - CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } - -> do { let ev_co = evTermCoercion ev_tm + CtGiven { ctev_evar = evar, ctev_loc = loc } + -> do { let ev_co = mkTcCoVarCo evar ; given_evs <- newGivenEvVars loc $ [ ( mkTcEqPredRole r ty1 ty2 , EvCoercion (mkTcNthCo i ev_co) ) @@ -1227,23 +1227,6 @@ as possible. Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar. ************************************************************************ -} -{- -Note [Bind new Givens immediately] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Givens we make new EvVars and bind them immediately. We don't worry -about caching, but we don't expect complicated calculations among Givens. -It is important to bind each given: - class (a~b) => C a b where .... - f :: C a b => .... -Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. -But that superclass selector can't (yet) appear in a coercion -(see evTermCoercion), so the easy thing is to bind it to an Id. - -See Note [Coercion evidence terms] in TcEvidence. --} - - ------------------------------ data StopOrContinue a = ContinueWith a -- The constraint was not solved, although it may have -- been rewritten @@ -1331,14 +1314,14 @@ rewriteEvidence old_ev new_pred co | isTcReflCo co -- See Note [Rewriting with Refl] = return (ContinueWith (old_ev { ctev_pred = new_pred })) -rewriteEvidence ev@(CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) -- See Note [Bind new Givens immediately] +rewriteEvidence ev@(CtGiven { ctev_evar = old_evar , ctev_loc = loc }) new_pred co + = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) ; return (ContinueWith new_ev) } where -- mkEvCast optimises ReflCo - new_tm = mkEvCast old_tm (tcDowngradeRole Representational - (ctEvRole ev) - (mkTcSymCo co)) + new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational + (ctEvRole ev) + (mkTcSymCo co)) rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co = do { (new_ev, freshness) <- newWantedEvVar loc new_pred @@ -1386,12 +1369,11 @@ rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co Just new_ev -> continueWith new_ev Nothing -> stopWith old_ev "Cached derived" } - | CtGiven { ctev_evtm = old_tm } <- old_ev + | CtGiven { ctev_evar = old_evar } <- old_ev = do { let new_tm = EvCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (evTermCoercion old_tm) + `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) `mkTcTransCo` mkTcSymCo rhs_co) ; new_ev <- newGivenEvVar loc' (new_pred, new_tm) - -- See Note [Bind new Givens immediately] ; return (ContinueWith new_ev) } | CtWanted { ctev_evar = evar } <- old_ev diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 9e0b40b7c5..54f84d8ec5 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -709,11 +709,11 @@ data EvTerm | EvCast EvTerm TcCoercion -- d |> co, the coercion being at role representational | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvTerm] + [Type] [EvId] - | EvTupleSel EvTerm Int -- n'th component of the tuple, 0-indexed + | EvTupleSel EvId Int -- n'th component of the tuple, 0-indexed - | EvTupleMk [EvTerm] -- tuple built from this stuff + | EvTupleMk [EvId] -- tuple built from this stuff | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] @@ -787,7 +787,7 @@ Instead we make a binding g1 :: a~Bool = g |> ax7 a and the constraint [G] g1 :: a~Bool -See Trac [7238] and Note [Bind new Givens immediately] in TcSMonad +See Trac [7238] and Note [Bind new Givens immediately] in TcRnTypes Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ @@ -993,11 +993,11 @@ evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm) evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm (EvId v) = unitVarSet v evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co -evVarsOfTerm (EvDFunApp _ _ evs) = evVarsOfTerms evs -evVarsOfTerm (EvTupleSel v _) = evVarsOfTerm v +evVarsOfTerm (EvDFunApp _ _ evs) = mkVarSet evs +evVarsOfTerm (EvTupleSel v _) = unitVarSet v evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co -evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs +evVarsOfTerm (EvTupleMk evs) = mkVarSet evs evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs @@ -1074,15 +1074,15 @@ instance Outputable EvBind where -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where - ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) - ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs - ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs + ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] - ppr (EvLit l) = ppr l - ppr (EvCallStack cs) = ppr cs + ppr (EvLit l) = ppr l + ppr (EvCallStack cs) = ppr cs ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] ppr (EvTypeable ev) = ppr ev diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 45f384ac01..fcac1d0959 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1247,10 +1247,8 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm ; co' <- zonkTcCoToCo env co ; return (mkEvCast tm' co') } -zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm - ; return (EvTupleSel tm' n) } -zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms - ; return (EvTupleMk tms') } +zonkEvTerm env (EvTupleSel tm n) = return (EvTupleSel (zonkIdOcc env tm) n) +zonkEvTerm env (EvTupleMk tms) = return (EvTupleMk (zonkIdOccs env tms)) zonkEvTerm _ (EvLit l) = return (EvLit l) zonkEvTerm env (EvTypeable ev) = @@ -1277,8 +1275,7 @@ zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d ; return (EvSuperClass d' n) } zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys - ; tms' <- mapM (zonkEvTerm env) tms - ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } + ; return (EvDFunApp (zonkIdOcc env df) tys' (zonkIdOccs env tms)) } zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty ; return (EvDelayedError ty' msg) } diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index de9840b5ba..b1a28c740d 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1066,8 +1066,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th -- sc_co :: sc_pred ~ norm_sc_pred , ClassPred cls tys <- classifyPredType norm_sc_pred , className cls /= typeableClassName - -- `Typeable` has custom solving rules, which is why we exlucde it - -- from the short cut, and fall throught to calling the solver. + -- `Typeable` has custom solving rules, which is why we exclude it + -- from the short cut, and fall through to calling the solver. = do { sc_ev_tm <- emit_sc_cls_pred norm_sc_pred cls tys ; sc_ev_id <- newEvVar sc_pred @@ -1097,7 +1097,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th -> do { let dfun_id = instanceDFunId ispec ; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys ; arg_evs <- emitWanteds ScOrigin inst_theta - ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs) + ; let dict_app = EvDFunApp dfun_id inst_tys arg_evs ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app) ; return dict_app } @@ -1379,7 +1379,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; self_dict <- newDict clas inst_tys ; let self_ev_bind = mkWantedEvBind self_dict - (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) + (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) ; (meth_id, local_meth_sig, hs_wrap) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index d36bcffc16..15ef8e1906 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -131,7 +131,7 @@ solveSimpleGivens loc givens | otherwise = go (map mk_given_ct givens) where - mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evtm = EvId ev_id + mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id , ctev_pred = evVarPred ev_id , ctev_loc = loc }) go givens = do { solveSimples (listToBag givens) @@ -504,9 +504,7 @@ solveOneFromTheOther ev_i ev_w lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w - has_binding binds ev - | EvId v <- ctEvTerm ev = isJust (lookupEvBind binds v) - | otherwise = True + has_binding binds ev = isJust (lookupEvBind binds (ctEvId ev)) use_replacement | isIPPred pred = lvl_w > lvl_i @@ -806,8 +804,8 @@ lookupFlattenTyVar inert_eqs ftv reactFunEq :: CtEvidence -> TcTyVar -- From this :: F tys ~ fsk1 -> CtEvidence -> TcTyVar -- Solve this :: F tys ~ fsk2 -> TcS () -reactFunEq from_this fsk1 (CtGiven { ctev_evtm = tm, ctev_loc = loc }) fsk2 - = do { let fsk_eq_co = mkTcSymCo (evTermCoercion tm) +reactFunEq from_this fsk1 (CtGiven { ctev_evar = evar, ctev_loc = loc }) fsk2 + = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo` ctEvCoercion from_this -- :: fsk2 ~ fsk1 fsk_eq_pred = mkTcEqPred (mkTyVarTy fsk2) (mkTyVarTy fsk1) @@ -1742,7 +1740,7 @@ matchClassInst inerts clas tys loc ; evc_vars <- mapM (newWantedEvVar loc) theta ; let new_ev_vars = freshGoals evc_vars -- new_ev_vars are only the real new variables that can be emitted - dfun_app = EvDFunApp dfun_id tys (map (ctEvTerm . fst) evc_vars) + dfun_app = EvDFunApp dfun_id tys (map (ctEvId . fst) evc_vars) ; return $ GenInst new_ev_vars dfun_app } unifiable_givens :: Cts diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index e00690759b..2fffcd476b 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -935,7 +935,7 @@ tidyCt env ct _ -> mkNonCanonical (tidy_ev env (ctEvidence ct)) where tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evtm/var field because we don't + -- NB: we do not tidy the ctev_evar field because we don't -- show it in error messages tidy_ev env ctev@(CtGiven { ctev_pred = pred }) = ctev { ctev_pred = tidyType env pred } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index da8e1c7d27..0cc06630e0 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1646,14 +1646,39 @@ pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) Note [Evidence field of CtEvidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During constraint solving we never look at the type of ctev_evtm, or -ctev_evar; instead we look at the cte_pred field. The evtm/evar field +During constraint solving we never look at the type of ctev_evar; +instead we look at the cte_pred field. The evtm/evar field may be un-zonked. + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. Two main reasons: + * Gain sharing. E.g. suppose we start with g :: C a b, where + class D a => C a b + class (E a, F a) => D a + If we generate all g's superclasses as separate EvTerms we might + get selD1 (selC1 g) :: E a + selD2 (selC1 g) :: F a + selC1 g :: D a + which we could do more economically as: + g1 :: D a = selC1 g + g2 :: E a = selD1 g1 + g3 :: F a = selD2 g1 + + * For *coercion* evidence we *must* bind each given: + class (a~b) => C a b where .... + f :: C a b => .... + Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + But that superclass selector can't (yet) appear in a coercion + (see evTermCoercion), so the easy thing is to bind it to an Id. + +So a Given has EvVar inside it rather that (as previously) an EvTerm. -} + data CtEvidence = CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evtm :: EvTerm -- See Note [Evidence field of CtEvidence] + , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] , ctev_loc :: CtLoc } -- Truly given, not depending on subgoals -- NB: Spontaneous unifications belong here @@ -1685,25 +1710,19 @@ ctEvRole :: CtEvidence -> Role ctEvRole = eqRelRole . ctEvEqRel ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm (CtGiven { ctev_evtm = tm }) = tm -ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev -ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" - (ppr ctev) +ctEvTerm ev = EvId (ctEvId ev) ctEvCoercion :: CtEvidence -> TcCoercion --- ctEvCoercion ev = evTermCoercion (ctEvTerm ev) -ctEvCoercion (CtGiven { ctev_evtm = tm }) = evTermCoercion tm -ctEvCoercion (CtWanted { ctev_evar = v }) = mkTcCoVarCo v -ctEvCoercion ctev@(CtDerived {}) = pprPanic "ctEvCoercion: derived constraint cannot have id" - (ppr ctev) +ctEvCoercion ev = mkTcCoVarCo (ctEvId ev) ctEvId :: CtEvidence -> TcId -ctEvId (CtWanted { ctev_evar = ev }) = ev +ctEvId (CtWanted { ctev_evar = ev }) = ev +ctEvId (CtGiven { ctev_evar = ev }) = ev ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) instance Outputable CtEvidence where ppr fl = case fl of - CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty + CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evar fl) <+> ppr_pty CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 5000fd5a64..be28deb2ca 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -1604,9 +1604,8 @@ newFlattenSkolem Given loc fam_ty do { uniq <- TcM.newUnique ; let name = TcM.mkTcTyVarName uniq (fsLit "fsk") ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } - ; let ev = CtGiven { ctev_pred = mkTcEqPred fam_ty (mkTyVarTy fsk) - , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty) - , ctev_loc = loc } + ; ev <- newGivenEvVar loc (mkTcEqPred fam_ty (mkTyVarTy fsk), + EvCoercion (mkTcNomReflCo fam_ty)) ; return (ev, fsk) } newFlattenSkolem _ loc fam_ty -- Make a wanted @@ -1706,6 +1705,7 @@ newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence -- Make a new variable of the given PredType, -- immediately bind it to the given term -- and return its CtEvidence +-- See Note [Bind new Givens immediately] in TcRnTypes -- Precondition: this is not a kind equality -- See Note [Do not create Given kind equalities] newGivenEvVar loc (pred, rhs) @@ -1713,7 +1713,7 @@ newGivenEvVar loc (pred, rhs) do { checkReductionDepth loc pred ; new_ev <- newEvVar pred ; setEvBind (mkGivenEvBind new_ev rhs) - ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) } + ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -- Like newGivenEvVar, but automatically discard kind equalities |