add -fsimpleopt-before-flatten

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

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index a6f9b47..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,
 --   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,
        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,

+        argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,

 
        primTyCons,
 
 
        primTyCons,
 

@@ -46,7 +47,7 @@ module TysPrim(
        word64PrimTyCon,        word64PrimTy,
 
        -- * Any
        word64PrimTyCon,        word64PrimTy,
 
        -- * Any

-       anyTyCon, anyType, anyTyConOfKind, anyTypeOfKind
+       anyTyCon, anyTyConOfKind, anyTypeOfKind

   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"

@@ -57,6 +58,7 @@ import OccName                ( mkTcOcc )
 import OccName         ( mkTyVarOccFS, mkTcOccFS )
 import TyCon           ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
 import Type
 import OccName         ( mkTyVarOccFS, mkTcOccFS )
 import TyCon           ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
 import Type

+import TypeRep          ( ecKind )

 import Coercion
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import Coercion
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )

@@ -157,6 +159,9 @@ tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
                            where c = chr (u-2 + ord 'a')
                 ]
 
                            where c = chr (u-2 + ord 'a')
                 ]
 

+ecTyVars :: [TyVar]
+ecTyVars = tyVarList ecKind
+

 alphaTyVars :: [TyVar]
 alphaTyVars = tyVarList liftedTypeKind
 
 alphaTyVars :: [TyVar]
 alphaTyVars = tyVarList liftedTypeKind
 

@@ -180,7 +185,13 @@ openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind
 
 openAlphaTy, openBetaTy :: Type
 openAlphaTy = mkTyVarTy openAlphaTyVar
 
 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}
 
 
 \end{code}
 
 

@@ -234,7 +245,6 @@ 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, 
 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, 

-

   - both wrt each other, because their strings differ
 
   - and wrt any other Name, because Names get uniques with 
   - both wrt each other, because their strings differ
 
   - and wrt any other Name, because Names get uniques with 

@@ -269,22 +279,14 @@ anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
 anyTyCon :: TyCon
 anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
 
 anyTyCon :: TyCon
 anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
 

-anyType :: Type
-anyType = mkTyConApp anyTyCon []
-

 anyTypeOfKind :: Kind -> Type
 anyTypeOfKind :: Kind -> Type

-anyTypeOfKind kind
-  | isLiftedTypeKind kind = anyType
-  | otherwise             = mkTyConApp (mk_any_tycon kind) []
+anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []

 
 anyTyConOfKind :: Kind -> TyCon
 
 anyTyConOfKind :: Kind -> TyCon

+-- Map all superkinds of liftedTypeKind to liftedTypeKind

 anyTyConOfKind kind 
 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(*->*->*)
   where
          -- Derive the name from the kind, thus:
          --     Any(*->*), Any(*->*->*)