add -fsimpleopt-before-flatten

[ghc-hetmet.git] / compiler / prelude / TysPrim.lhs

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 4e1576f..a5d9335 100644 (file)
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -10,8 +10,9 @@
 --   They are all, therefore, wired-in TyCons.  C.f module TysWiredIn
 module TysPrim(
        alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
-       alphaTy, betaTy, gammaTy, deltaTy,
+       alphaTy, betaTy, gammaTy, deltaTy, ecTyVars,
        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
+        argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
 
        primTyCons,
 
@@ -46,7 +47,7 @@ module TysPrim(
        word64PrimTyCon,        word64PrimTy,
 
        -- * Any
-       anyTyCon, anyType, anyTyConOfKind, anyTypeOfKind
+       anyTyCon, anyTyConOfKind, anyTypeOfKind
   ) where
 
 #include "HsVersions.h"
@@ -57,6 +58,8 @@ import OccName                ( mkTcOcc )
 import OccName         ( mkTyVarOccFS, mkTcOccFS )
 import TyCon           ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
 import Type
+import TypeRep          ( ecKind )
+import Coercion
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import PrelNames
@@ -156,6 +159,9 @@ tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
                            where c = chr (u-2 + ord 'a')
                 ]
 
+ecTyVars :: [TyVar]
+ecTyVars = tyVarList ecKind
+
 alphaTyVars :: [TyVar]
 alphaTyVars = tyVarList liftedTypeKind
 
@@ -179,7 +185,13 @@ openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind
 
 openAlphaTy, openBetaTy :: Type
 openAlphaTy = mkTyVarTy openAlphaTyVar
-openBetaTy   = mkTyVarTy openBetaTyVar
+openBetaTy  = mkTyVarTy openBetaTyVar
+
+argAlphaTyVar, argBetaTyVar :: TyVar
+(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind
+argAlphaTy, argBetaTy :: Type
+argAlphaTy = mkTyVarTy argAlphaTyVar
+argBetaTy  = mkTyVarTy argBetaTyVar
 \end{code}
 
 
@@ -232,8 +244,13 @@ Note [Uniques of Any]
 Although Any(*->*), say, doesn't have a binding site, it still needs
 to have a Unique.  Unlike tuples (which are also an infinite family)
 there is no convenient way to index them, so we use the Unique from
-their OccName instead.  That should be unique!  (But in principle we
-must take care: it does not include the module/package.)
+their OccName instead.  That should be unique, 
+  - both wrt each other, because their strings differ
+
+  - and wrt any other Name, because Names get uniques with 
+    various 'char' tags, but the OccName of Any will 
+    get a Unique built with mkTcOccUnique, which has a particular 'char' 
+    tag; see Unique.mkTcOccUnique!
 
 Note [Strangely-kinded void TyCons]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -262,22 +279,14 @@ anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
 anyTyCon :: TyCon
 anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
 
-anyType :: Type
-anyType = mkTyConApp anyTyCon []
-
 anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind
-  | isLiftedTypeKind kind = anyType
-  | otherwise             = mkTyConApp (mk_any_tycon kind) []
+anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
 
 anyTyConOfKind :: Kind -> TyCon
+-- Map all superkinds of liftedTypeKind to liftedTypeKind
 anyTyConOfKind kind 
-  | isLiftedTypeKind kind = anyTyCon
-  | otherwise             = mk_any_tycon kind
-
-mk_any_tycon :: Kind -> TyCon
-mk_any_tycon kind    -- Kind other than *
-  = tycon
+  | liftedTypeKind `isSubKind` kind = anyTyCon
+  | otherwise                       = tycon
   where
          -- Derive the name from the kind, thus:
          --     Any(*->*), Any(*->*->*)