[commit: ghc] ghc-7.10: Fix superclass generation in an instance (7f24cdd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/7f24cdd63fbfd69a83f81e85384dc8cb7ef57704/ghc

>---------------------------------------------------------------

commit 7f24cdd63fbfd69a83f81e85384dc8cb7ef57704
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 21 13:38:32 2015 +0100

    Fix superclass generation in an instance
    
    More fallout from the silent-superclass refactoring; nothing drastic.
    Fixes Trac #10335.
    
    (cherry picked from commit 646866ff318d6eb8beeed98032644182dd9d997b)


>---------------------------------------------------------------

7f24cdd63fbfd69a83f81e85384dc8cb7ef57704
 compiler/deSugar/DsBinds.hs                        |  8 ++++----
 compiler/typecheck/TcEvidence.hs                   | 16 ++++++++++++++--
 testsuite/tests/typecheck/should_compile/T10335.hs | 16 ++++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 4 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 72f0801..bb10711 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -883,16 +883,16 @@ dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm 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'
+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 tm' (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)
   = do { tms' <- mapM dsEvTerm tms
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index a5a727b..9eef643 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -13,7 +13,7 @@ module TcEvidence (
   TcEvBinds(..), EvBindsVar(..),
   EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds,
   EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
-  EvTerm(..), mkEvCast, evVarsOfTerm,
+  EvTerm(..), mkEvCast, evVarsOfTerm, mkEvTupleSelectors, mkEvScSelectors,
   EvLit(..), evTermCoercion,
   EvTypeable(..),
 
@@ -34,10 +34,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
@@ -825,6 +826,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
 
diff --git a/testsuite/tests/typecheck/should_compile/T10335.hs b/testsuite/tests/typecheck/should_compile/T10335.hs
new file mode 100644
index 0000000..045c3a6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T10335.hs
@@ -0,0 +1,16 @@
+{-# 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]
+
+
+
+
+
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index e23f67c..af58fcd 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -443,3 +443,4 @@ test('T10072', normal, compile_fail, [''])
 test('T10177', normal, compile, [''])
 test('T10195', normal, compile, [''])
 test('T10109', normal, compile, [''])
+test('T10335', normal, compile, [''])