diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Transfer/Interpreter.hs | 60 | ||||
| -rw-r--r-- | src/Transfer/SyntaxToCore.hs | 38 |
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 -- |