[commit: ghc] master: Actually make the change described in 'Fix egregious typo in cmpTypeX' (6ecfa98)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/6ecfa98d7b9860ccf29359d0bb3d6fda1d7c7335

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

commit 6ecfa98d7b9860ccf29359d0bb3d6fda1d7c7335
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jun 11 09:49:20 2013 +0100

    Actually make the change described in 'Fix egregious typo in cmpTypeX'
    
    I reverted it to try something else and forgot to put it back!
    Fixes Trac #7272 (again!).

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

 compiler/types/Kind.lhs | 30 ++++++++++++++----------------
 compiler/types/Type.lhs | 14 ++++++--------
 2 files changed, 20 insertions(+), 24 deletions(-)

diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index a37e485..ff0ad01 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -40,7 +40,7 @@ module Kind (
         isAnyKind, isAnyKindCon,
         okArrowArgKind, okArrowResultKind,
 
-        isSubOpenTypeKind, 
+        isSubOpenTypeKind, isSubOpenTypeKindKey,
         isSubKind, isSubKindCon, 
         tcIsSubKind, tcIsSubKindCon,
         defaultKind, defaultKind_maybe,
@@ -173,13 +173,8 @@ returnsConstraintKind _               = False
 --     arg -> res
 
 okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool
-okArrowArgKindCon kc
-  | isLiftedTypeKindCon   kc = True
-  | isUnliftedTypeKindCon kc = True
-  | isConstraintKindCon   kc = True
-  | otherwise                = False
-
-okArrowResultKindCon = okArrowArgKindCon
+okArrowArgKindCon    = isSubOpenTypeKindCon
+okArrowResultKindCon = isSubOpenTypeKindCon
 
 okArrowArgKind, okArrowResultKind :: Kind -> Bool
 okArrowArgKind    (TyConApp kc []) = okArrowArgKindCon kc
@@ -199,14 +194,17 @@ isSubOpenTypeKind :: Kind -> Bool
 isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc
 isSubOpenTypeKind _                = False
 
-isSubOpenTypeKindCon kc
-  =  isOpenTypeKindCon   kc
-  || isUnliftedTypeKindCon kc
-  || isLiftedTypeKindCon   kc  
-  || isConstraintKindCon kc   -- Needed for error (Num a) "blah"
-                              -- and so that (Ord a -> Eq a) is well-kinded
-                              -- and so that (# Eq a, Ord b #) is well-kinded
-                              -- See Note [Kind Constraint and kind *]
+isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc)
+
+isSubOpenTypeKindKey :: Unique -> Bool
+isSubOpenTypeKindKey uniq
+  =  uniq == openTypeKindTyConKey
+  || uniq == unliftedTypeKindTyConKey
+  || uniq == liftedTypeKindTyConKey
+  || uniq == constraintKindTyConKey  -- Needed for error (Num a) "blah"
+                                     -- and so that (Ord a -> Eq a) is well-kinded
+                                     -- and so that (# Eq a, Ord b #) is well-kinded
+                              	     -- See Note [Kind Constraint and kind *]
 
 -- | Is this a kind (i.e. a type-of-types)?
 isKind :: Kind -> Bool
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 91991d6..9935070 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -6,7 +6,7 @@
 Type - public interface
 
 \begin{code}
-{-# OPTIONS_GHC -fno-warn-orphans -w #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Main functions for manipulating types and type-related things
 module Type (
@@ -160,7 +160,7 @@ import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeSymbolKind )
 import PrelNames ( eqTyConKey, ipClassNameKey, openTypeKindTyConKey,
-                   constraintKindTyConKey, liftedTypeKindTyConKey, unliftedTypeKindTyConKey )
+                   constraintKindTyConKey, liftedTypeKindTyConKey )
 import CoAxiom
 
 -- others
@@ -1216,7 +1216,7 @@ cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2
 -- So the RHS has a data type
 
 cmpTypeX env (TyVarTy tv1)       (TyVarTy tv2)       = rnOccL env tv1 `compare` rnOccR env tv2
-cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX env (tyVarKind tv1) (tyVarKind tv1)
+cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2)
                                                        `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
 cmpTypeX env (AppTy s1 t1)       (AppTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
 cmpTypeX env (FunTy s1 t1)       (FunTy s2 t2)       = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
@@ -1261,16 +1261,14 @@ cmpTc :: TyCon -> TyCon -> Ordering
 -- Also we treat OpenTypeKind as equal to either * or #
 -- See Note [Comparison with OpenTypeKind]
 cmpTc tc1 tc2 
---  | u1 == openTypeKindTyConKey, is_type nu2 = EQ
---  | u2 == openTypeKindTyConKey, is_type nu1 = EQ
-  | otherwise                               = nu1 `compare` nu2
+  | u1 == openTypeKindTyConKey, isSubOpenTypeKindKey u2 = EQ
+  | u2 == openTypeKindTyConKey, isSubOpenTypeKindKey u1 = EQ
+  | otherwise = nu1 `compare` nu2
   where
     u1  = tyConUnique tc1
     nu1 = if u1==constraintKindTyConKey then liftedTypeKindTyConKey else u1
     u2  = tyConUnique tc2
     nu2 = if u2==constraintKindTyConKey then liftedTypeKindTyConKey else u2
-
-    is_type u = u == liftedTypeKindTyConKey || u == unliftedTypeKindTyConKey
 \end{code}
 
 Note [Comparison with OpenTypeKind]