Commit 646866ff authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix superclass generation in an instance

More fallout from the silent-superclass refactoring; nothing drastic.
Fixes Trac #10335.
parent a2f9fef1
......@@ -854,15 +854,16 @@ dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (ma
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= do { let scrut_ty = idType v
dsEvTerm (EvTupleSel tm n)
= do { tup <- dsEvTerm tm
; let scrut_ty = exprType tup
(tc, tys) = splitTyConApp scrut_ty
Just [dc] = tyConDataCons_maybe tc
xs = mkTemplateLocals tys
the_x = getNth xs n
; ASSERT( isTupleTyCon tc )
return $
Case (Var v) (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
Case tup (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
dsEvTerm (EvTupleMk tms)
= return (Var (dataConWorkId dc) `mkTyApps` map idType tms `mkApps` map Var tms)
......
......@@ -195,8 +195,7 @@ canTuple ev preds
; stopWith ev "Decomposed tuple constraint" }
| 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..])
= do { given_evs <- newGivenEvVars loc (mkEvTupleSelectors (EvId evar) preds)
; emitWorkNC given_evs
; stopWith ev "Decomposed tuple constraint" }
......
......@@ -11,10 +11,10 @@ module TcEvidence (
-- Evidence bindings
TcEvBinds(..), EvBindsVar(..),
EvBindMap(..), emptyEvBindMap, extendEvBinds,
EvBindMap(..), emptyEvBindMap, extendEvBinds,
lookupEvBind, evBindMapBinds, foldEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
EvTerm(..), mkEvCast, evVarsOfTerm,
EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors,
EvLit(..), evTermCoercion,
EvCallStack(..),
EvTypeable(..),
......@@ -37,10 +37,11 @@ module TcEvidence (
import Var
import Coercion
import PprCore () -- Instance OutputableBndr TyVar
import TypeRep -- Knows type representation
import TypeRep -- Knows type representation
import TcType
import Type
import TyCon
import Class( Class )
import CoAxiom
import PrelNames
import VarEnv
......@@ -711,7 +712,7 @@ data EvTerm
| EvDFunApp DFunId -- Dictionary instance application
[Type] [EvId]
| EvTupleSel EvId Int -- n'th component of the tuple, 0-indexed
| EvTupleSel EvTerm Int -- n'th component of the tuple, 0-indexed
| EvTupleMk [EvId] -- tuple built from this stuff
......@@ -974,6 +975,17 @@ mkEvCast ev lco
isTcReflCo lco = ev
| otherwise = EvCast ev lco
mkEvTupleSelectors :: EvTerm -> [TcPredType] -> [(TcPredType, EvTerm)]
mkEvTupleSelectors ev preds = zipWith mk_pr preds [0..]
where
mk_pr pred i = (pred, EvTupleSel ev i)
mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)]
mkEvScSelectors ev cls tys
= zipWith mk_pr (immSuperClasses cls tys) [0..]
where
mk_pr pred i = (pred, EvSuperClass ev i)
emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag
......@@ -994,7 +1006,7 @@ evVarsOfTerm :: EvTerm -> VarSet
evVarsOfTerm (EvId v) = unitVarSet v
evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co
evVarsOfTerm (EvDFunApp _ _ evs) = mkVarSet evs
evVarsOfTerm (EvTupleSel v _) = unitVarSet v
evVarsOfTerm (EvTupleSel ev _) = evVarsOfTerm ev
evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v
evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co
evVarsOfTerm (EvTupleMk evs) = mkVarSet evs
......
......@@ -1247,7 +1247,6 @@ 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) = return (EvTupleSel (zonkIdOcc env tm) n)
zonkEvTerm env (EvTupleMk tms) = return (EvTupleMk (zonkIdOccs env tms))
zonkEvTerm _ (EvLit l) = return (EvLit l)
......@@ -1271,6 +1270,9 @@ zonkEvTerm env (EvCallStack cs)
; return (EvCallStack (EvCsTop n l tm')) }
EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
; return (EvCallStack (EvCsPushCall n l tm')) }
zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm
; return (EvTupleSel tm' n) }
zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
; return (EvSuperClass d' n) }
zonkEvTerm env (EvDFunApp df tys tms)
......
......@@ -1006,38 +1006,38 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th
head_size = sizeTypes inst_tys
------------
given_cls_preds :: [(EvTerm, TcType)] -- (ev_term, type of that ev_term)
-- given_cls_preds is the list of (ev_term, type) that can be derived
-- from the dfun_evs, using the rules (sc1) and (sc3) of
given_cls_preds :: [(TcPredType, EvTerm)] -- (type of that ev_term, ev_term)
-- given_cls_preds is the list of (type, ev_term) that can be derived
-- from the dfun_evs, using the rules (sc1) and (sc2) of
-- Note [Recursive superclasses] below
-- When solving for superclasses, we search this list
given_cls_preds
= [ ev_pr | dfun_ev <- dfun_evs
, ev_pr <- super_classes (EvId dfun_ev, idType dfun_ev) ]
, ev_pr <- super_classes (idType dfun_ev, EvId dfun_ev) ]
------------
super_classes ev_pair
| (ev_tm, pred) <- normalise_pr ev_pair
, ClassPred cls tys <- classifyPredType pred
= (ev_tm, pred) : super_classes_help ev_tm cls tys
| otherwise
= []
= case classifyPredType pred of
ClassPred cls tys -> (pred, ev_tm) : super_classes_help ev_tm cls tys
TuplePred preds -> concatMap super_classes (mkEvTupleSelectors ev_tm preds)
_ -> []
where
(pred, ev_tm) = normalise_pr ev_pair
------------
super_classes_help :: EvTerm -> Class -> [TcType] -> [(EvTerm, TcType)]
super_classes_help :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)]
super_classes_help ev_tm cls tys -- ev_tm :: cls tys
| sizeTypes tys >= head_size -- Here is where we test for
= [] -- a smaller dictionary
| otherwise
= concatMap super_classes ([EvSuperClass ev_tm i | i <- [0..]]
`zip` immSuperClasses cls tys)
= concatMap super_classes (mkEvScSelectors ev_tm cls tys)
------------
normalise_pr :: (EvTerm, TcPredType) -> (EvTerm, TcPredType)
normalise_pr :: (TcPredType, EvTerm) -> (TcPredType, EvTerm)
-- Normalise type functions as much as possible
normalise_pr (ev_tm, pred)
| isReflCo norm_co = (ev_tm, pred)
| otherwise = (mkEvCast ev_tm tc_co, norm_pred)
normalise_pr (pred, ev_tm)
| isReflCo norm_co = (pred, ev_tm)
| otherwise = (norm_pred, mkEvCast ev_tm tc_co)
where
(norm_co, norm_pred) = normaliseType fam_envs Nominal pred
tc_co = TcCoercion (mkSubCo norm_co)
......@@ -1087,7 +1087,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_th
-------------------
emit_sc_cls_pred sc_pred cls tys
| (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds
| (ev_tm:_) <- [ ev_tm | (ev_ty, ev_tm) <- given_cls_preds
, ev_ty `tcEqType` sc_pred ]
= do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm)
; return ev_tm }
......@@ -1198,10 +1198,10 @@ definition. More precisely:
To achieve the Superclass Invariant, in a dfun definition we can
generate a guaranteed-non-bottom superclass witness from:
(sc1) one of the dictionary arguments itself (all non-bottom)
(sc2) a call of a dfun (always returns a dictionary constructor)
(sc3) an immediate superclass of a smaller dictionary
(sc2) an immediate superclass of a smaller dictionary
(sc3) a call of a dfun (always returns a dictionary constructor)
The tricky case is (sc3). We proceed by induction on the size of
The tricky case is (sc2). We proceed by induction on the size of
the (type of) the dictionary, defined by TcValidity.sizePred.
Let's suppose we are building a dictionary of size 3, and
suppose the Superclass Invariant holds of smaller dictionaries.
......
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}
module Foo where
type X a = (Eq a, Show a)
class Eq a => C a b
-- HEAD was unable to find the (Eq a) superclass
-- for a while in March/April 2015
instance X a => C a [b]
......@@ -450,3 +450,4 @@ test('T10185', expect_broken(10185), compile, [''])
test('T10195', normal, compile, [''])
test('T10109', normal, compile, [''])
test('TcCustomSolverSuper', normal, compile, [''])
test('T10335', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment