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

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 2ac19ce..64b3476 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -217,12 +217,29 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)             = dsLExpr e
 
-dsExpr (HsHetMetBrak c   e)   = do { e' <- dsExpr (unLoc e)
-                                 ; brak <- dsLookupGlobalId hetmet_brak_name
-                                 ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
-dsExpr (HsHetMetEsc  c t e)   = do { e' <- dsExpr (unLoc e)
-                                 ; esc <- dsLookupGlobalId hetmet_esc_name
-                                 ; return $ mkApps (Var esc)  [ (Type c), (Type t), e'] }
+dsExpr (HsHetMetBrak c   e)   =
+    do { e' <- dsExpr (unLoc e)
+       ; brak <- dsLookupGlobalId hetmet_brak_name
+       ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
+dsExpr (HsHetMetEsc  c t e)   =
+    do { e' <- dsExpr (unLoc e)
+       ; esc <- dsLookupGlobalId hetmet_esc_name
+       ; return $ mkApps (Var esc)  [ (Type c), (Type t), e'] }
+dsExpr (HsKappa a_Match) =
+    do { e' <- dsExpr (HsLam a_Match)
+       ; let ([ua],bc) = tcSplitFunTys (exprType e')
+       ; let (_,[_,a]) = tcSplitAppTys ua
+       ; let (_,[b,c]) = tcSplitAppTys bc
+       ; kap <- dsLookupGlobalId hetmet_kappa_name
+       ; return $ mkApps (Var kap)  [ (Type a), (Type b), (Type c), e'] }
+dsExpr (HsKappaApp e1 e2) =
+    do { e1' <- dsExpr (unLoc e1)
+       ; e2' <- dsExpr (unLoc e2)
+       ; let (_,[_ ,a]) = tcSplitAppTys $ exprType e2'
+       ; let (_,[ab,c]) = tcSplitAppTys $ exprType e1'
+       ; let (_,[a,b])  = tcSplitAppTys $ ab
+       ; kap_app <- dsLookupGlobalId hetmet_kappa_app_name
+       ; return $ mkApps (Var kap_app)  [ (Type a), (Type b), (Type c), e1', e2'] }
 dsExpr (HsHetMetCSP  c   e)   = do { e' <- dsExpr (unLoc e)
                                  ; csp <- dsLookupGlobalId hetmet_csp_name
                                  ; return $ mkApps (Var csp)  [ (Type c), (Type $ exprType e'), e'] }
@@ -247,6 +264,7 @@ dsExpr (HsLam a_Match)
 
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
+
 \end{code}
 
 Operator sections.  At first it looks as if we can convert