[commit: ghc] master: Simplify construction of equality predicates (68b4a09)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/68b4a098fba82f8c13edb2331dca070837b2b32f

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

commit 68b4a098fba82f8c13edb2331dca070837b2b32f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Apr 16 15:27:22 2012 +0100

    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

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

 compiler/typecheck/TcCanonical.lhs |    8 +++-----
 compiler/typecheck/TcType.lhs      |    8 +++++++-
 compiler/types/Type.lhs            |    9 +--------
 3 files changed, 11 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index eb642b5..d293f0e 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 8a23b59..ea93680 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -786,10 +786,16 @@ mkTcEqPred :: TcType -> TcType -> Type
 -- they will all settle, but we want the equality predicate
 -- 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 89c460e..1470160 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 )