Fix superclass generation in an instance

More fallout from the silent-superclass refactoring; nothing drastic.
Fixes Trac #10335.

compiler/deSugar/DsBinds.hs

@@ -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)

compiler/typecheck/TcCanonical.hs

@@ -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" }
 

compiler/typecheck/TcEvidence.hs

@@ -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

compiler/typecheck/TcHsSyn.hs

@@ -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)

compiler/typecheck/TcInstDcls.hs

@@ -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.

testsuite/tests/typecheck/should_compile/T10335.hs

+{-# 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]
+
+
+
+
+

testsuite/tests/typecheck/should_compile/all.T

@@ -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, [''])