Transfer: reimplement operators with type classes.

2 files changed, 61 insertions, 37 deletions

diff --git a/src/Transfer/Interpreter.hs b/src/Transfer/Interpreter.hs
index 90e3a70ca..02c28bc53 100644
--- a/src/Transfer/Interpreter.hs
+++ b/src/Transfer/Interpreter.hs
@@ -53,33 +53,47 @@ builtin :: Env
 builtin = 
     mkEnv [(CIdent "Int",VType),
            (CIdent "String",VType),
-           mkIntUn  "neg" negate,
-           mkIntBin "add" (+),
-           mkIntBin "sub" (-),
-           mkIntBin "mul" (*),
-           mkIntBin "div" div,
-           mkIntBin "mod" mod,
-           mkIntCmp "lt"  (<),
-           mkIntCmp "le"  (<=),
-           mkIntCmp "gt"  (>),
-           mkIntCmp "ge"  (>=),
-           mkIntCmp "eq"  (==),
-           mkIntCmp "ne"  (/=)]
+           mkIntUn  "neg"  negate  toInt,
+           mkIntBin "add"  (+)     toInt,
+           mkIntBin "sub"  (-)     toInt,
+           mkIntBin "mul"  (*)     toInt,
+           mkIntBin "div"  div     toInt,
+           mkIntBin "mod"  mod     toInt,
+           mkIntBin "eq"   (==)    toBool,
+           mkIntBin "cmp"  compare toOrd,
+           mkIntUn  "show" show    toStr,
+           mkStrBin "add"  (++)    toStr,
+           mkStrBin "eq"   (==)    toBool,
+           mkStrBin "cmp"  compare toOrd,
+           mkStrUn  "show" show    toStr
+          ]
   where 
-  mkIntUn x f = let c = CIdent ("prim_"++x++"_Int")
-                 in (c, VPrim (\n -> appInt1 (VInt . f) n))
-  mkIntBin x f = let c = CIdent ("prim_"++x++"_Int")
-                  in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> VInt (f n m)) n m )))
-  mkIntCmp x f = let c = CIdent ("prim_"++x++"_Int")
-                  in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> toBool (f n m)) n m)))
-  toBool b = VCons (CIdent (if b then "True" else "False")) []
-  appInt1 f x = case x of
-                         VInt n -> f n
+  toInt i  = VInt i
+  toBool b = VCons (CIdent (show b)) []
+  toOrd o  = VCons (CIdent (show o)) []
+  toStr s  = VStr s
+  mkIntUn x f g = let c = CIdent ("prim_"++x++"_Int")
+                   in (c, VPrim (\n -> appInt1 f g n))
+  mkIntBin x f g = let c = CIdent ("prim_"++x++"_Int")
+                    in (c, VPrim (\n -> VPrim (\m -> appInt2 f g n m )))
+  appInt1 f g x = case x of
+                         VInt n -> g (f n)
                          _ -> error $ printValue x ++ " is not an integer"
-  appInt2 f x y = case (x,y) of
-                         (VInt n,VInt m) -> f n m
+  appInt2 f g x y = case (x,y) of
+                         (VInt n,VInt m) -> g (f n m)
                          _ -> error $ printValue x ++ " and " ++ printValue y 
                                       ++ " are not both integers"
+  mkStrUn x f g = let c = CIdent ("prim_"++x++"_Str")
+                   in (c, VPrim (\n -> appStr1 f g n))
+  mkStrBin x f g = let c = CIdent ("prim_"++x++"_Str")
+                    in (c, VPrim (\n -> VPrim (\m -> appStr2 f g n m )))
+  appStr1 f g x = case x of
+                         VStr n -> g (f n)
+                         _ -> error $ printValue x ++ " is not an integer"
+  appStr2 f g x y = case (x,y) of
+                         (VStr n,VStr m) -> g (f n m)
+                         _ -> error $ printValue x ++ " and " ++ printValue y 
+                                      ++ " are not both strings"
 
 addModuleEnv :: Env -> Module -> Env
 addModuleEnv env (Module ds) = 
diff --git a/src/Transfer/SyntaxToCore.hs b/src/Transfer/SyntaxToCore.hs
index 3a5bdac20..ad3e68f86 100644
--- a/src/Transfer/SyntaxToCore.hs
+++ b/src/Transfer/SyntaxToCore.hs
@@ -28,11 +28,11 @@ declsToCore :: [Decl] -> [Decl]
 declsToCore m = evalState (declsToCore_ m) newState
 
 declsToCore_ :: [Decl] -> C [Decl]
-declsToCore_ =     numberMetas
+declsToCore_ =     desugar 
+               >>> numberMetas
                >>> deriveDecls
                >>> replaceCons 
                >>> compilePattDecls 
-               >>> desugar 
                >>> optimize
 
 optimize :: [Decl] -> C [Decl]
@@ -361,22 +361,32 @@ desugar = return . map f
               EPiNoVar exp0 exp1 -> EPi VWild       <| exp0 <| exp1
               EOr  exp0 exp1     -> andBool         <| exp0 <| exp1
               EAnd exp0 exp1     -> orBool          <| exp0 <| exp1
-              EEq  exp0 exp1     -> appIntBin "eq"  <| exp0 <| exp1
-              ENe  exp0 exp1     -> appIntBin "ne"  <| exp0 <| exp1
-              ELt  exp0 exp1     -> appIntBin "lt"  <| exp0 <| exp1
-              ELe  exp0 exp1     -> appIntBin "le"  <| exp0 <| exp1
-              EGt  exp0 exp1     -> appIntBin "gt"  <| exp0 <| exp1
-              EGe  exp0 exp1     -> appIntBin "ge"  <| exp0 <| exp1
-              EAdd exp0 exp1     -> appIntBin "add" <| exp0 <| exp1
-              ESub exp0 exp1     -> appIntBin "sub" <| exp0 <| exp1
-              EMul exp0 exp1     -> appIntBin "mul" <| exp0 <| exp1
-              EDiv exp0 exp1     -> appIntBin "div" <| exp0 <| exp1
-              EMod exp0 exp1     -> appIntBin "mod" <| exp0 <| exp1
-              ENeg exp0          -> appIntUn  "neg" <| exp0
+              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
+              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
               _                  -> composOp f x
     where g <| x = g (f x)
 
 --
+-- * Use an overloaded function.
+--
+
+overlUn :: String -> Exp -> Exp
+overlUn f e1 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1] -- FIXME: hack, should be ?
+
+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
 --