[commit: ghc] wip/14691: Avoid exprType in evSuperClass, it does not work pre-zonking (3318a0d)

[git at git.haskell.org]

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

On branch  : wip/14691
Link       : http://ghc.haskell.org/trac/ghc/changeset/3318a0d2e8305f15c8d2ccf42237d0b7f893d07c/ghc

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

commit 3318a0d2e8305f15c8d2ccf42237d0b7f893d07c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 23 09:42:51 2018 -0500

    Avoid exprType in evSuperClass, it does not work pre-zonking
    
    but luckily mkEvScSelectors, the only caller of evSuperClass, knows the
    Class and the arguments.


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

3318a0d2e8305f15c8d2ccf42237d0b7f893d07c
 compiler/typecheck/TcEvidence.hs | 16 ++++------------
 compiler/types/Type.hs           |  2 +-
 2 files changed, 5 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 7bf01fd..bee7045 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -20,7 +20,7 @@ module TcEvidence (
 
   -- EvTerm (already a CoreExpr)
   EvTerm(..), EvExpr,
-  evId, evCoercion, evCast, evDFunApp,  evSuperClass, evSelector,
+  evId, evCoercion, evCast, evDFunApp,  evSelector,
   mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable,
 
   evTermCoercion,
@@ -63,7 +63,6 @@ import Name
 import Pair
 
 import CoreSyn
-import CoreUtils
 import Class ( classSCSelId )
 import Id ( isEvVar )
 import CoreFVs ( exprSomeFreeVars )
@@ -512,15 +511,6 @@ evCast et tc | isReflCo tc = et
 evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvExpr
 evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets
 
--- n'th superclass. Used for both equalities and
--- dictionaries, even though the former have no
--- selector Id.  We count up from _0_
-evSuperClass :: EvExpr -> Int -> EvExpr
-evSuperClass d n = Var sc_sel_id `mkTyApps` tys `App` d
-  where
-    (cls, tys) = getClassPredTys (exprType d)
-    sc_sel_id  = classSCSelId cls n -- Zero-indexed
-
 -- Selector id plus the types at which it
 -- should be instantiated, used for HasField
 -- dictionaries; see Note [HasField instances]
@@ -756,7 +746,9 @@ mkEvScSelectors :: EvExpr -> Class -> [TcType] -> [(TcPredType, EvExpr)]
 mkEvScSelectors ev cls tys
    = zipWith mk_pr (immSuperClasses cls tys) [0..]
   where
-    mk_pr pred i = (pred, evSuperClass ev i)
+    mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys `App` ev)
+      where
+        sc_sel_id  = classSCSelId cls i -- Zero-indexed
 
 emptyTcEvBinds :: TcEvBinds
 emptyTcEvBinds = EvBinds emptyBag
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index acc7a63..3f893db 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -1760,7 +1760,7 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
       | Just clas <- tyConClass_maybe tc  -> ClassPred clas tys
     _                                     -> IrredPred ev_ty
 
-getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
 getClassPredTys ty = case getClassPredTys_maybe ty of
         Just (clas, tys) -> (clas, tys)
         Nothing          -> pprPanic "getClassPredTys" (ppr ty)