X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=86e8f0904a6b2db0339af14ffa8286ae76411fd2;hp=8b907d212c8f00a37641deffea2345fd30c53b07;hb=HEAD;hpb=b2524b3960999fffdb3767900f58825903f6560f

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 8b907d2..86e8f09 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -48,7 +48,7 @@ import Var
 import VarSet
 import VarEnv
 import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim( intPrimTy, ecKind )
 import PrimOp( tagToEnumKey )
 import PrelNames
 import Module
@@ -173,18 +173,38 @@ 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
-       ; 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
-       ; 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
-       ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) }
+       ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }
+
+tcExpr (HsKappa  match) res_ty =
+    do	{ v1 <- newFlexiTyVar liftedTypeKind
+        ; v2 <- newFlexiTyVar liftedTypeKind
+        ; v3 <- newFlexiTyVar liftedTypeKind
+        ; (_, [ty_ab, ty_c]) <- matchExpectedTyConApp hetMetKappaTyCon res_ty
+        ; (_, [ty_a,  ty_b]) <- matchExpectedTyConApp pairTyCon ty_ab
+        ; (co_fn, match') <- tcMatchLambda match (mkFunTy
+                                                     (mkHetMetKappaTy unitTy ty_a)
+                                                     (mkHetMetKappaTy ty_b ty_c))
+	; return (HsKappa match') }
+
+tcExpr (HsKappaApp e1 e2) res_ty =
+    do	{ v1 <- newFlexiTyVar liftedTypeKind
+        ; v2 <- newFlexiTyVar liftedTypeKind
+        ; v3 <- newFlexiTyVar liftedTypeKind
+        ; e1' <- tcExpr (unLoc e1) (mkHetMetKappaTy (mkTyConApp pairTyCon [(TyVarTy v1), (TyVarTy v2)]) (TyVarTy v3))
+        ; e2' <- tcExpr (unLoc e2) (mkHetMetKappaTy unitTy (TyVarTy v1))
+        ; unifyType res_ty (mkHetMetKappaTy (TyVarTy v2) (TyVarTy v3))
+	; return (HsKappaApp (noLoc e1') (noLoc e2')) }
 
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty