Improve `Typeable` solver.

1 files changed, 14 insertions, 18 deletions

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 8f85dd3c81..5f54130632 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1845,23 +1845,19 @@ isCallStackIP _ _ _
 matchTypeableClass :: Class -> Kind -> Type -> CtLoc -> TcS LookupInstResult
 matchTypeableClass clas k t loc
   | isForAllTy k                               = return NoInstance
-  | Just (tc, ks_tys) <- splitTyConApp_maybe t = doTyConApp tc ks_tys
+  | Just (tc, ks) <- splitTyConApp_maybe t
+  , all isKind ks                              = doTyCon tc ks
   | Just (f,kt)       <- splitAppTy_maybe t    = doTyApp f kt
-  | Just _            <- isNumLitTy t          = mkEv [] (EvTypeableTyLit t)
-  | Just _            <- isStrLitTy t          = mkEv [] (EvTypeableTyLit t)
+  | Just _            <- isNumLitTy t          = mkSimpEv (EvTypeableTyLit t)
+  | Just _            <- isStrLitTy t          = mkSimpEv (EvTypeableTyLit t)
   | otherwise                                  = return NoInstance
 
   where
-  -- Representation for type constructor applied to some kinds and some types.
-  doTyConApp tc ks_ts =
+  -- Representation for type constructor applied to some kinds
+  doTyCon tc ks =
     case mapM kindRep ks of
-      Nothing    -> return NoInstance      -- Not concrete kinds
-      Just kReps ->
-        do tCts <- mapM subGoal ts
-           mkEv tCts (EvTypeableTyCon tc kReps (map ctEvTerm tCts `zip` ts))
-    where
-    (ks,ts)    = span isKind ks_ts
-
+      Nothing    -> return NoInstance
+      Just kReps -> mkSimpEv (EvTypeableTyCon tc kReps [])
 
   {- Representation for an application of a type to a type-or-kind.
   This may happen when the type expression starts with a type variable.
@@ -1876,7 +1872,9 @@ matchTypeableClass clas k t loc
     | otherwise =
       do ct1 <- subGoal f
          ct2 <- subGoal tk
-         mkEv [ct1,ct2] (EvTypeableTyApp (ctEvTerm ct1,f) (ctEvTerm ct2,tk))
+         let realSubs = [ c | (c,Fresh) <- [ct1,ct2] ]
+         return $ GenInst realSubs
+                $ EvTypeable $ EvTypeableTyApp (getEv ct1,f) (getEv ct2,tk)
 
 
   -- Representation for concrete kinds.  We just use the kind itself,
@@ -1886,13 +1884,11 @@ matchTypeableClass clas k t loc
                   mapM_ kindRep ks
                   return ki
 
+  getEv (ct,_fresh) = ctEvTerm ct
 
   -- Emit a `Typeable` constraint for the given type.
   subGoal ty = do let goal = mkClassPred clas [ typeKind ty, ty ]
-                  ev <- newWantedEvVarNC loc goal
-                  return ev
-
-
-  mkEv subs ev = return (GenInst subs (EvTypeable ev))
+                  newWantedEvVar loc goal
 
+  mkSimpEv ev = return (GenInst [] (EvTypeable ev))