[commit: ghc] master: Fix egregious typo in cmpTypeX (0239d78)

[Simon Peyton Jones]

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

On branch  : master

https://github.com/ghc/ghc/commit/0239d783bcda0fb0e45df7b40159d6ad29bfab63

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

commit 0239d783bcda0fb0e45df7b40159d6ad29bfab63
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jun 10 11:57:06 2013 +0100

    Fix egregious typo in cmpTypeX
    
    Reported in Trac #7272.  "tv1" should be "tv2"!
    
    However, things weren't as simple as they sound, because
    treating (x:Open) as different from (x:*) gave rise to
    new failures; see Note [Comparison with OpenTypeKind] in Type.
    
    My hacky solution is to treat OpenKind as equal to * and #,
    at least in Core etc.  Hence the faff in Type.cmpTc.
    
    I do not like this.  But it seems like another messy consequence
    of including sub-kinding.  Sigh.

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

 compiler/typecheck/TcSimplify.lhs |  6 ++----
 compiler/types/Kind.lhs           | 14 +++++++++-----
 compiler/types/Type.lhs           | 28 ++++++++++++++++++++++++----
 3 files changed, 35 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 2cbb5af..4945a0c 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -23,6 +23,7 @@ import TcMType as TcM
 import TcType 
 import TcSMonad as TcS
 import TcInteract 
+import Kind     ( defaultKind_maybe )
 import Inst
 import FunDeps  ( growThetaTyVars )
 import Type     ( classifyPredType, PredTree(..), getClassPredTys_maybe )
@@ -782,7 +783,7 @@ defaultTyVar :: TcTyVar -> TcS TcTyVar
 -- Precondition: MetaTyVars only
 -- See Note [DefaultTyVar]
 defaultTyVar the_tv
-  | not (k `eqKind` default_k)
+  | Just default_k <- defaultKind_maybe (tyVarKind the_tv)
   = do { tv' <- TcS.cloneMetaTyVar the_tv
        ; let new_tv = setTyVarKind tv' default_k
        ; traceTcS "defaultTyVar" (ppr the_tv <+> ppr new_tv)
@@ -793,9 +794,6 @@ defaultTyVar the_tv
              -- We keep the same Untouchables on tv'
 
   | otherwise = return the_tv	 -- The common case
-  where
-    k = tyVarKind the_tv
-    default_k = defaultKind k
 
 approximateWC :: WantedConstraints -> Cts
 -- Postcondition: Wanted or Derived Cts 
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index 0082a33..a37e485 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -43,7 +43,7 @@ module Kind (
         isSubOpenTypeKind, 
         isSubKind, isSubKindCon, 
         tcIsSubKind, tcIsSubKindCon,
-        defaultKind,
+        defaultKind, defaultKind_maybe,
 
         -- ** Functions on variables
         kiVarsOfKind, kiVarsOfKinds
@@ -60,6 +60,7 @@ import TyCon
 import VarSet
 import PrelNames
 import Outputable
+import Maybes( orElse )
 import Util
 \end{code}
 
@@ -271,7 +272,8 @@ tcIsSubKindCon kc1 kc2
   | otherwise               = isSubKindCon kc1 kc2
 
 -------------------------
-defaultKind :: Kind -> Kind
+defaultKind       :: Kind -> Kind
+defaultKind_maybe :: Kind -> Maybe Kind
 -- ^ Used when generalising: default OpenKind and ArgKind to *.
 -- See "Type#kind_subtyping" for more information on what that means
 
@@ -289,9 +291,11 @@ defaultKind :: Kind -> Kind
 -- This defaulting is done in TcMType.zonkTcTyVarBndr.
 --
 -- The test is really whether the kind is strictly above '*'
-defaultKind (TyConApp kc _args)
-  | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind
-defaultKind k = k
+defaultKind_maybe (TyConApp kc _args)
+  | isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind
+defaultKind_maybe _      = Nothing
+
+defaultKind k = defaultKind_maybe k `orElse` k
 
 -- Returns the free kind variables in a kind
 kiVarsOfKind :: Kind -> VarSet
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 836465f..91991d6 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 #-}
+{-# OPTIONS_GHC -fno-warn-orphans -w #-}
 
 -- | Main functions for manipulating types and type-related things
 module Type (
@@ -159,8 +159,8 @@ import Class
 import TyCon
 import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeSymbolKind )
-import PrelNames ( eqTyConKey, ipClassNameKey,
-                   constraintKindTyConKey, liftedTypeKindTyConKey )
+import PrelNames ( eqTyConKey, ipClassNameKey, openTypeKindTyConKey,
+                   constraintKindTyConKey, liftedTypeKindTyConKey, unliftedTypeKindTyConKey )
 import CoAxiom
 
 -- others
@@ -1257,14 +1257,34 @@ cmpTypesX _   _         []        = GT
 cmpTc :: TyCon -> TyCon -> Ordering
 -- Here we treat * and Constraint as equal
 -- See Note [Kind Constraint and kind *] in Kinds.lhs
-cmpTc tc1 tc2 = nu1 `compare` nu2
+--
+-- 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
   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]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In PrimOpWrappers we have things like
+   PrimOpWrappers.mkWeak# = /\ a b c. Prim.mkWeak# a b c
+where
+   Prim.mkWeak# :: forall (a:Open) b c. a -> b -> c 
+                                     -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+Now, eta reduction will turn the definition into
+     PrimOpWrappers.mkWeak# = Prim.mkWeak#
+which is kind-of OK, but now the types aren't really equal.  So HACK HACK
+we pretend (in Core) that Open is equal to * or #.  I hate this.
+
 Note [cmpTypeX]
 ~~~~~~~~~~~~~~~