GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Transfer: reimplement operators with type classes.

Browse Source
This commit is contained in:
bringert
2005-11-30 17:40:32 +00:00
parent 94b99219b8
commit a68cd282cb
6 changed files with 157 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
src/Transfer/Interpreter.hs
View File

@@ -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) =

38
src/Transfer/SyntaxToCore.hs
View File

@@ -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
--

3
transfer/examples/fib.tr
View File

@@ -1,6 +1,7 @@
import nat
import prelude
fib : Int -> Int
fib : Integer -> Integer
fib 0 = 1
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

2
transfer/lib/bool.tr
View File

@@ -1,3 +1,5 @@
import prelude
depif : (A:Type) -> (B:Type) -> (b:Bool) -> A -> B -> if Type b then A else B
depif _ _ True x _ = x
depif _ _ False _ y = y

16
transfer/lib/nat.tr
View File

@@ -1,18 +1,24 @@
import prelude
data Nat : Type where
Zero : Nat
Succ : (n:Nat) -> Nat
plus : Nat -> Nat -> Nat
plus Zero y = y
plus (Succ x) y = Succ (plus x y)
add_Nat : Add Nat
add_Nat = rec zero = Zero
plus = natPlus
natPlus : Nat -> Nat -> Nat
natPlus Zero y = y
natPlus (Succ x) y = Succ (natPlus x y)
pred : Nat -> Nat
pred Zero = Zero
pred (Succ n) = n
natToInt : Nat -> Int
natToInt : Nat -> Integer
natToInt Zero = 0
natToInt (Succ n) = 1 + natToInt n
intToNat : Int -> Nat
intToNat : Integer -> Nat
intToNat n = if n == 0 then Zero else Succ (intToNat (n-1))

101
transfer/lib/prelude.tr
View File

@@ -26,6 +26,35 @@ not : Bool -> Bool
not b = if b then False else True
--
-- The Num class
--
Num : Type -> Type
Num = sig zero : A
plus : A -> A -> A
minus : A -> A -> A
one : A
times : A -> A -> A
div : A -> A -> A
mod : A -> A -> A
negate : A -> A
eq : A -> A -> Bool
compare : A -> A -> Ordering
-- Instances:
num_Integer : Num Integer
num_Integer = rec zero = 0
plus = prim_add_Int
minus = prim_sub_Int
one = 1
times = prim_mul_Int
div = prim_div_Int
mod = prim_mod_Int
negate = prim_neg_Int
eq = prim_eq_Int
compare = prim_cmp_Int
--
-- The Add class
@@ -53,31 +82,42 @@ sum A d (Cons _ x xs) = d.plus x (sum A d xs)
-- Instances:
add_Integer : Add Integer
add_Integer = rec zero = 0
plus = prim_add_Int
-- num_Integer
add_String : Add String
add_String = rec zero = ""
plus = prim_add_Str
--
-- The Sub class
--
Sub : Type -> Type
Sub = sig minus : A -> A -> A
minus : (A : Type) -> Sub A -> A
minus _ d = d.minus
-- Instances:
-- num_Integer
--
-- The Prod class
-- The Mul class
--
Prod : Type -> Type
Prod = sig one : A
times : A -> A -> A
Mul : Type -> Type
Mul = sig one : A
times : A -> A -> A
one : (A : Type) -> Prod A -> A
one : (A : Type) -> Mul A -> A
one _ d = d.one
times : (A : Type) -> Prod A -> A -> A -> A
times : (A : Type) -> Mul A -> A -> A -> A
times _ d = d.times
product : (A:Type) -> Prod A -> List A -> A
product : (A:Type) -> Mul A -> List A -> A
product _ d (Nil _) = d.one
product A d (Cons _ x xs) = d.times x (product A d xs)
@@ -89,9 +129,34 @@ product A d (Cons _ x xs) = d.times x (product A d xs)
-- Instances:
prod_Integer : Add Integer
prod_Integer = rec one = 1
times = prim_mul_Int
-- num_Integer
--
-- The Div class
--
Div : Type -> Type
Div = sig div : A -> A -> A
mod : A -> A -> A
div : (A : Type) -> Div A -> A -> A -> A
div _ d = d.div
mod : (A : Type) -> Div A -> A -> A -> A
mod _ d = d.mod
-- Operators:
{-
(x / y) => (div ? ? x y)
(x % y) => (mod ? ? x y)
-}
-- Instances:
-- num_Integer
--
@@ -112,8 +177,7 @@ negate _ d = d.neg
-- Instances:
neg_Integer : Neg Integer
neg_Integer = rec negate = prim_neg_Int
-- num_Integer
neg_Bool : Neg Bool
neg_Bool = rec negate = not
@@ -143,8 +207,7 @@ neq A d x y = not (eq A d x y)
-- Instances:
eq_Integer : Eq Integer
eq_Integer = rec eq = prim_eq_Int
-- num_Integer
eq_String : Eq String
eq_String = rec eq = prim_eq_Str
@@ -193,9 +256,7 @@ gt = ordOp (\o -> case o of { GT -> True; _ -> False })
-- Instances:
ord_Integer : Ord Integer
ord_Integer = rec eq = prim_eq_Int
compare = prim_cmp_Int
-- num_Integer
ord_String : Ord String
ord_String = rec eq = prim_eq_Str