From 7dfa1842859b408d0eadd4d79a5b1ce0267a13b2 Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Wed, 30 Nov 2005 20:27:01 +0000
Subject: Added bind operators, do-notation, a cons operator and list sytnax.

---
 src/Transfer/SyntaxToCore.hs | 38 +++++++++++++++++++++++++++++---------
 1 file changed, 29 insertions(+), 9 deletions(-)

(limited to 'src/Transfer/SyntaxToCore.hs')

diff --git a/src/Transfer/SyntaxToCore.hs b/src/Transfer/SyntaxToCore.hs
index a2dcde8a2..f3e7f828d 100644
--- a/src/Transfer/SyntaxToCore.hs
+++ b/src/Transfer/SyntaxToCore.hs
@@ -352,22 +352,28 @@ desugar = return . map f
  where
  f :: Tree a -> Tree a
  f x = case x of
-              EIf exp0 exp1 exp2 -> ifBool          <| exp0 <| exp1 <| exp2
-              EPiNoVar exp0 exp1 -> EPi VWild       <| exp0 <| exp1
-              EOr  exp0 exp1     -> andBool         <| exp0 <| exp1
-              EAnd exp0 exp1     -> orBool          <| exp0 <| exp1
+              EIf exp0 exp1 exp2 -> ifBool           <| exp0 <| exp1 <| exp2
+              EDo bs e           -> mkDo (map f bs) (f e)
+              BindNoVar exp0     -> BindVar VWild    <| exp0
+              EPiNoVar exp0 exp1 -> EPi VWild        <| exp0 <| exp1
+              EBind exp0 exp1    -> appBind          <| exp0 <| exp1
+              EBindC exp0 exp1   -> appBindC         <| exp0 <| exp1
+              EOr  exp0 exp1     -> andBool          <| exp0 <| exp1
+              EAnd exp0 exp1     -> orBool           <| exp0 <| exp1
               EEq  exp0 exp1     -> overlBin "eq"    <| exp0 <| exp1
               ENe  exp0 exp1     -> overlBin "ne"    <| exp0 <| exp1
               ELt  exp0 exp1     -> overlBin "lt"    <| exp0 <| exp1
               ELe  exp0 exp1     -> overlBin "le"    <| exp0 <| exp1
               EGt  exp0 exp1     -> overlBin "gt"    <| exp0 <| exp1
               EGe  exp0 exp1     -> overlBin "ge"    <| exp0 <| exp1
+              EListCons exp0 exp1 -> appCons         <| exp0 <| exp1
               EAdd exp0 exp1     -> overlBin "plus"  <| exp0 <| exp1
               ESub exp0 exp1     -> overlBin "minus" <| exp0 <| exp1
               EMul exp0 exp1     -> overlBin "times" <| exp0 <| exp1
               EDiv exp0 exp1     -> overlBin "div"   <| exp0 <| exp1
               EMod exp0 exp1     -> overlBin "mod"   <| exp0 <| exp1
               ENeg exp0          -> overlUn  "neg"   <| exp0
+              EList exps         -> mkList (map f exps)
               _                  -> composOp f x
     where g <| x = g (f x)
 
@@ -382,14 +388,28 @@ overlBin :: String -> Exp -> Exp -> Exp
 overlBin f e1 e2 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1,e2] -- FIXME: hack, should be ?
 
 --
--- * Integers
+-- * Monad
 --
 
-appIntUn :: String -> Exp -> Exp
-appIntUn f e = EApp (var ("prim_"++f++"_Int")) e
+mkDo :: [Bind] -> Exp -> Exp
+mkDo bs e = foldr (\ (BindVar v r) x -> appBind r (EAbs v x)) e bs
+
+appBind :: Exp -> Exp -> Exp
+appBind e1 e2 = apply (EVar (Ident "bind")) [EMeta,EMeta,EMeta,EMeta,e1,e2]
+
+appBindC :: Exp -> Exp -> Exp
+appBindC e1 e2 = appBind e1 (EAbs VWild e2)
+
+--
+-- * List
+--
+
+mkList :: [Exp] -> Exp
+mkList = foldr appCons (EApp (EVar (Ident "Nil")) EMeta)
+
+appCons :: Exp -> Exp -> Exp
+appCons e1 e2 = apply (EVar (Ident "Cons")) [EMeta,e1,e2]
 
-appIntBin :: String -> Exp -> Exp -> Exp
-appIntBin f e1 e2 = EApp (EApp (var ("prim_"++f++"_Int")) e1) e2
 
 --
 -- * Booleans
-- 
cgit v1.2.3