add support for <{..}> and ~~> syntax as well as typing for Kappa-calculus

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 70592af..86e8f09 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -186,6 +186,26 @@ tcExpr (HsHetMetCSP _ e) res_ty =
                    $ tcExpr (unLoc e) res_ty
        ; 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
 
 tcExpr (HsLit lit)   res_ty =