mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-17 08:49:31 -06:00
Transfer: reimplement operators with type classes.
This commit is contained in:
bringert
@@ -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) =
|
||||
|
||||
@@ -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,21 +361,31 @@ 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
|
||||
--
|
||||
|
||||
Reference in New Issue
Block a user