adapt HetMet extensions to new GHC coercion representation

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index b2131ca..7ba91d9 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -15,6 +15,7 @@ import HsSyn
 import TcRnTypes
 import MkIface
 import Id
 import TcRnTypes
 import MkIface
 import Id

+import Pair

 import Name
 import CoreSyn
 import CoreSubst
 import Name
 import CoreSyn
 import CoreSubst

@@ -577,13 +578,14 @@ simplify (Var v)                 = Var v
 simplify (App e1 e2)             = App (simplify e1) (simplify e2)
 simplify (Lit lit)               = Lit lit
 simplify (Note note e)           = Note note (simplify e)
 simplify (App e1 e2)             = App (simplify e1) (simplify e2)
 simplify (Lit lit)               = Lit lit
 simplify (Note note e)           = Note note (simplify e)

-simplify (Cast e co)             = if tcEqType (fst $ coercionKind co) (snd $ coercionKind co)
+simplify (Cast e co)             = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)

                                        then simplify e
                                        else Cast (simplify e) co
 simplify (Lam v e)               = Lam v (simplify e)
                                        then simplify e
                                        else Cast (simplify e) co
 simplify (Lam v e)               = Lam v (simplify e)

-simplify (Type t)                = Type t

 simplify (Case e b ty as)        = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
 simplify (Let bind body)         = foldr Let (simplify body) (simplifyBind bind)
 simplify (Case e b ty as)        = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
 simplify (Let bind body)         = foldr Let (simplify body) (simplifyBind bind)

+simplify (Type t)                = Type t
+simplify (Coercion co)           = Coercion co

 
 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
 simplifyBind (NonRec b e)             = [NonRec b (simplify e)]
 
 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
 simplifyBind (NonRec b e)             = [NonRec b (simplify e)]

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index aee1594..2c2d5f9 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -30,6 +30,7 @@ import Coercion
 import TcType
 
 import CmmExpr
 import TcType
 
 import CmmExpr

+import qualified Var

 import CmmUtils
 import HscTypes
 import ForeignCall
 import CmmUtils
 import HscTypes
 import ForeignCall

diff --git a/compiler/hetmet b/compiler/hetmet
index d97b00a..0f137f4 160000 (submodule)
--- a/compiler/hetmet
+++ b/compiler/hetmet
@@ -1 +1 @@
-Subproject commit d97b00a6ff6e8e2244927d17bda4b9762fc3d716
+Subproject commit 0f137f4fbe7076b7a0f6b33d661b4f7aa8b4f160

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index aa5de15..4bbb479 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1328,7 +1328,6 @@ noSelTyConKey = mkPreludeTyConUnique 154
 
 repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156
 
 repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156

->>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5

 
 ---------------- Template Haskell -------------------
 --     USES TyConUniques 200-299
 
 ---------------- Template Haskell -------------------
 --     USES TyConUniques 200-299

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 4c70bcb..5cacacd 100644 (file)
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -27,6 +27,7 @@ module TysPrim(
        liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind,
         mkArrowKind, mkArrowKinds, isCoercionKind,
        liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind,
         mkArrowKind, mkArrowKinds, isCoercionKind,

+        ecKind,

 
         funTyCon, funTyConName,
         primTyCons,
 
         funTyCon, funTyConName,
         primTyCons,

@@ -74,8 +75,6 @@ import Name           ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
 import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
 import TyCon
 import TypeRep
 import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
 import TyCon
 import TypeRep

-import Type
-import Coercion

 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import PrelNames
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import PrelNames

@@ -177,6 +176,8 @@ tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
                            where c = chr (u-2 + ord 'a')
                 ]
 
                            where c = chr (u-2 + ord 'a')
                 ]
 

+ecKind           = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
+

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

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 8b907d2..70592af 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -48,7 +48,7 @@ import Var
 import VarSet
 import VarEnv
 import TysWiredIn
 import VarSet
 import VarEnv
 import TysWiredIn

-import TysPrim( intPrimTy )
+import TysPrim( intPrimTy, ecKind )

 import PrimOp( tagToEnumKey )
 import PrelNames
 import Module
 import PrimOp( tagToEnumKey )
 import PrelNames
 import Module

@@ -173,18 +173,18 @@ tcExpr (HsHetMetBrak _ e) res_ty =
        ; expr' <-  updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
                    $ tcPolyExpr e elt_ty
        ; unifyType (TyVarTy fresh_ec_name) inferred_name
        ; expr' <-  updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
                    $ tcPolyExpr e elt_ty
        ; unifyType (TyVarTy fresh_ec_name) inferred_name

-       ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
+       ; return $ mkHsWrapCo coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }

 tcExpr (HsHetMetEsc _ _ e) res_ty =
     do { cur_level <- getHetMetLevel
        ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
                    $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
        ; ty' <- zonkTcType res_ty
 tcExpr (HsHetMetEsc _ _ e) res_ty =
     do { cur_level <- getHetMetLevel
        ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
                    $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
        ; ty' <- zonkTcType res_ty

-       ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) }
+       ; return $ HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr') }

 tcExpr (HsHetMetCSP _ e) res_ty =
     do { cur_level <- getHetMetLevel
        ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
                    $ tcExpr (unLoc e) res_ty
 tcExpr (HsHetMetCSP _ e) res_ty =
     do { cur_level <- getHetMetLevel
        ; expr' <-  updHetMetLevel (\old_lev -> tail old_lev)
                    $ tcExpr (unLoc e) res_ty

-       ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) }
+       ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }

 
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
 
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 2174be3..f011f19 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -37,7 +37,7 @@ import TcMType
 import TcUnify
 import TcIface
 import TcType
 import TcUnify
 import TcIface
 import TcType

-import TypeRep ( ecKind )
+import TysPrim ( ecKind )

 import {- Kind parts of -} Type
 import Var
 import VarSet
 import {- Kind parts of -} Type
 import Var
 import VarSet

diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index 32a9eac..668ddda 100644 (file)
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -15,7 +15,6 @@ module Kind (
         -- Kind constructors...
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon,
         -- Kind constructors...
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon,

-        ecKind,

 
         -- Super Kinds
        tySuperKind, tySuperKindTyCon, 
 
         -- Super Kinds
        tySuperKind, tySuperKindTyCon, 

@@ -234,5 +233,4 @@ defaultKind k
   | isSubArgTypeKind k  = liftedTypeKind
   | otherwise        = k
 
   | isSubArgTypeKind k  = liftedTypeKind
   | otherwise        = k
 

-ecKind           = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)

 \end{code}
\ No newline at end of file
 \end{code}
\ No newline at end of file

diff --git a/libraries/base b/libraries/base
index 696df0c..a166b10 160000 (submodule)
--- a/libraries/base
+++ b/libraries/base
@@ -1 +1 @@
-Subproject commit 696df0cbdfe203a618c325e25c2ed60408ee54b9
+Subproject commit a166b102f16b45e2116f84f01fed840b981d3d40