Simplify construction of equality predicates

There was an ASSERT which does not hold during type checking (and
should not) which is later checked by Core Lint

3 files changed, 12 insertions, 15 deletions

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index eb642b5f63..d293f0ea3b 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -27,7 +27,7 @@ import Name ( Name )
 import Var
 import VarEnv
 import Outputable
-import Control.Monad    ( when, unless )
+import Control.Monad    ( when )
 import MonadUtils
 import Control.Applicative ( (<|>) )
 
@@ -325,9 +325,7 @@ emitSuperclasses ct@(CDictCan { cc_depth = d, cc_flavor = fl
                               , cc_tyargs = xis_new, cc_class = cls })
             -- Add superclasses of this one here, See Note [Adding superclasses]. 
             -- But only if we are not simplifying the LHS of a rule. 
- = do { sctxt <- getTcSContext
-      ; unless (simplEqsOnly sctxt) $ 
-               newSCWorkFromFlavored d fl cls xis_new
+ = do { newSCWorkFromFlavored d fl cls xis_new
       -- Arguably we should "seq" the coercions if they are derived, 
       -- as we do below for emit_kind_constraint, to allow errors in
       -- superclasses to be executed if deferred to runtime! 
@@ -906,7 +904,7 @@ emitKindConstraint ct
        | otherwise
        = ASSERT( isKind k1 && isKind k2 )
          do { kev <- 
-                 do { mw <- newWantedEvVar (mkNakedEqPred superKind k1 k2) 
+                 do { mw <- newWantedEvVar (mkEqPred k1 k2) 
                     ; case mw of
                          Cached x -> return x
                          Fresh x  -> addToWork (canEq d (kind_co_fl x) k1 k2) >> return x }
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 8a23b5995d..ea9368014b 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -784,12 +784,18 @@ mkTcEqPred :: TcType -> TcType -> Type
 -- During type checking we build equalities between 
 -- type variables with OpenKind or ArgKind.  Ultimately
 -- they will all settle, but we want the equality predicate
--- itself to have kind '*'.  I think.  
+-- itself to have kind '*'.  I think.
+--
+-- But for now we call mkTyConApp, not mkEqPred, because the invariants
+-- of the latter might not be satisfied during type checking.
+-- Notably when we form an equalty   (a : OpenKind) ~ (Int : *)
 --
 -- But this is horribly delicate: what about type variables
 -- that turn out to be bound to Int#?
 mkTcEqPred ty1 ty2
-  = mkNakedEqPred (defaultKind (typeKind ty1)) ty1 ty2
+  = mkTyConApp eqTyCon [k, ty1, ty2]
+  where
+    k = defaultKind (typeKind ty1)
 \end{code}
 
 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 89c460ef52..1470160dd3 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -51,7 +51,7 @@ module Type (
 	-- Pred types
         mkFamilyTyConApp,
 	isDictLikeTy,
-        mkNakedEqPred, mkEqPred, mkPrimEqPred,
+        mkEqPred, mkPrimEqPred,
         mkClassPred,
 	mkIPPred,
         noParenPred, isClassPred, isEqPred, isIPPred,
@@ -861,13 +861,6 @@ Make PredTypes
 --------------------- Equality types ---------------------------------
 \begin{code}
 -- | Creates a type equality predicate
-mkNakedEqPred :: Kind -> Type -> Type -> PredType
-mkNakedEqPred k ty1 ty2
-  = WARN( not (typeKind ty1 `isSubKind` k) || not (typeKind ty2 `isSubKind` k), 
-          ppr k $$ (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)) 
-                $$ (ppr ty2 <+> dcolon <+> ppr (typeKind ty2)) )
-    TyConApp eqTyCon [k, ty1, ty2]
-
 mkEqPred :: Type -> Type -> PredType
 mkEqPred ty1 ty2
   = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 )