interpret

diff --git a/Makefile b/Makefile
index 412aba0..c0b5828 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CLM?=clm
-CLMFLAGS?=-b -lat
+CLMFLAGS?=-b
 CLMLIBS?=-IL Platform
 
 all: main

diff --git a/ast.dcl b/ast.dcl
index 720855a..5f7b1b5 100644 (file)
--- a/ast.dcl
+++ b/ast.dcl
@@ -1,7 +1,10 @@
 definition module ast
 
+from Data.Either import :: Either
 from StdOverloaded import class toString
 
+from int import :: Eval
+
 :: Function = Function [Char] [[Char]] Expression
 
 :: Expression
@@ -9,12 +12,11 @@ from StdOverloaded import class toString
        | Var [Char]
        | App Expression Expression
        | Lambda [Char] Expression
-       | Builtin [Char] [Expression]
        | Let [Char] Expression Expression
 
 :: Value
        = Int Int
        | Bool Bool
-       | Func Int [Expression] ([Expression] -> Expression)
+       | Func (Expression -> Eval Value)
 
 instance toString Function, Expression, Value

diff --git a/ast.icl b/ast.icl
index 8ee15a2..a240b55 100644 (file)
--- a/ast.icl
+++ b/ast.icl
@@ -1,7 +1,9 @@
 implementation module ast
 
 import StdEnv
+import Data.Either
 import Text
+import int
 
 instance toString Function where
        toString (Function i a e) = concat [toString i, " ", join " " (map toString a), " = ", toString e]
@@ -11,11 +13,10 @@ instance toString Expression where
        toString (Var s) = toString s
        toString (App l r) = concat ["(", toString l, " ", toString r, ")"]
        toString (Lambda a e) = concat ["(\\", toString a, ".", toString e, ")"]
-       toString (Builtin v as) = concat ["'", toString v, "'", join " " (map toString as)]
        toString (Let i b r) = concat [toString i, " = ", toString b, "\n", toString r]
        toString _ = abort "toString Expression not implemented"
 
 instance toString Value where
        toString (Int i) = toString i
        toString (Bool b) = toString b
-       toString (Func a as _) = concat ["Function arity ", toString a, " curried ", join "," (map toString as)]
+       toString (Func a) = concat ["Function "]

diff --git a/check.dcl b/check.dcl
index 322bd4a..91059a7 100644 (file)
--- a/check.dcl
+++ b/check.dcl
@@ -5,7 +5,7 @@ from Data.Either import :: Either
 from ast import :: Function, :: Expression
 
 :: Scheme = Forall [[Char]] Type
-:: Type = TVar [Char] | TInt | TBool | TFun Type Type
+:: Type = TVar [Char] | TInt | TBool | (-->) infixr 9 Type Type
 
 instance toString Scheme, Type
 

diff --git a/check.icl b/check.icl
index 3800632..68d258a 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -22,7 +22,7 @@ check fs
                ([], _) = Left ["No start function defined"]
                ([Function _ [] e], fs)
                        # e = foldr (\(Function i a e)->Let i (foldr ((o) o Lambda) id a e)) e fs
-                       = (\x->(e, x)) <$> runInfer (infer newMap e)
+                       = (\x->(e, x)) <$> runInfer (infer preamble e)
                ([Function _ _ _], _) = Left ["Start cannot have arguments"]
 
 instance toString Scheme where
@@ -32,9 +32,18 @@ instance toString Type where
        toString (TVar a) = toString a
        toString TInt = "Int"
        toString TBool = "Bool"
-       toString (TFun a b) = concat ["(", toString a, ") -> ", toString b]
+       toString (a --> b) = concat ["(", toString a, ") -> ", toString b]
 
 :: TypeEnv :== Map [Char] Scheme
+preamble :: TypeEnv
+preamble = fromList
+       [(['_if'],  Forall [['_ift']]
+               $ TBool --> TVar ['_ift'] --> TVar ['_ift'] --> TVar ['_ift'])
+       ,(['_eq'],  Forall [['_eq']] $ TInt --> TInt --> TBool)
+       ,(['_mul'], Forall [['_mul']] $ TInt --> TInt --> TInt)
+       ,(['_add'], Forall [['_add']] $ TInt --> TInt --> TInt)
+       ,(['_sub'], Forall [['_sub']] $ TInt --> TInt --> TInt)
+       ]
 :: Subst   :== Map [Char] Type
 
 :: Infer a :== StateT [Int] (Either [String]) a
@@ -45,8 +54,8 @@ runInfer i = uncurry ((o) (generalize newMap) o apply)
 fresh :: Infer Type
 fresh = getState >>= \[s:ss]->put ss >>| pure (TVar (['v':[c\\c<-:toString s]]))
 
-compose :: Subst Subst -> Subst
-compose s1 s2 = 'Data.Map'.union (apply s1 <$> s2) s1
+(oo) infixr 9 :: Subst Subst -> Subst
+(oo) s1 s2 = 'Data.Map'.union (apply s1 <$> s2) s1
 
 class Substitutable a where
        apply :: Subst a -> a
@@ -54,11 +63,11 @@ class Substitutable a where
 
 instance Substitutable Type where
        apply s t=:(TVar v) = fromMaybe t (get v s)
-       apply s (TFun t1 t2) = on TFun (apply s) t1 t2
+       apply s (t1 --> t2) = apply s t1 --> apply s t2
        apply _ x = x
        
        ftv (TVar v) = [v]
-       ftv (TFun t1 t2) = on union ftv t1 t2
+       ftv (t1 --> t2) = on union ftv t1 t2
        ftv _ = []
 
 instance Substitutable Scheme where
@@ -77,22 +86,20 @@ occursCheck :: [Char] -> (a -> Bool) | Substitutable a
 occursCheck a = isMember a o ftv
 
 unify :: Type Type -> Infer Subst
-unify (TFun l r) (TFun l` r`)
+unify (l --> r) (l` --> r`)
        =        unify l l`
        >>= \s1->on unify (apply s1) r r`
-       >>= \s2->pure (compose s1 s2)
-unify (TVar a) t = bind a t
-unify t (TVar a) = bind a t
+       >>= \s2->pure (s1 oo s2)
+unify (TVar a) (TVar t)
+       | a == t = pure newMap
+unify (TVar a) t
+       | occursCheck a t = liftT (Left ["Infinite type: ", toString a, " to ", toString t])
+       = pure (singleton a t)
+unify t (TVar a) = unify (TVar a) t
 unify TInt TInt = pure newMap
 unify TBool TBool = pure newMap
 unify t1 t2 = liftT (Left ["Cannot unify: ", toString t1, " with ", toString t2])
 
-bind :: [Char] Type -> Infer Subst
-bind a (TVar t) | a == t = pure newMap
-bind a t
-       | occursCheck a t = liftT (Left ["Infinite type: ", toString a, " and ", toString t])
-       = pure (singleton a t)
-
 instantiate :: Scheme -> Infer Type
 instantiate (Forall as t)
        =         sequence [fresh\\_<-as]
@@ -111,14 +118,18 @@ infer env (App e1 e2)
        =              fresh
        >>= \tv->      infer env e1
        >>= \(s1, t1)->infer (apply s1 env) e2
-       >>= \(s2, t2)->unify (apply s2 t1) (TFun t2 tv)
-       >>= \s3->      pure (compose (compose s3 s2) s1, apply s3 tv)
+       >>= \(s2, t2)->unify (apply s2 t1) (t2 --> tv)
+       >>= \s3->      pure (s1 oo s2 oo s3, apply s3 tv)
 infer env (Lambda x b)
        =              fresh
        >>= \tv->      infer ('Data.Map'.put x (Forall [] tv) env) b
-       >>= \(s1, t1)->pure (s1, TFun (apply s1 tv) t1)
-infer env (Builtin c a) = undef
+       >>= \(s1, t1)->pure (s1, apply s1 tv --> t1)
+//infer env (Let x e1 e2)
+//     =              infer env e1
+//     >>= \(s1, t1)->infer ('Data.Map'.put x (generalize (apply s1 env) t1) env) e2
+//     >>= \(s2, t2)->pure (s1 oo s2, t2)
 infer env (Let x e1 e2)
-       =              infer env e1
-       >>= \(s1, t1)->let env` = apply s1 env in infer ('Data.Map'.put x (generalize env` t1) env) e2
-       >>= \(s2, t2)->pure (compose s1 s2, t2)
+       =              fresh
+       >>= \tv->      infer ('Data.Map'.put x (Forall [] tv) env) e1
+       >>= \(s1, t1)->infer ('Data.Map'.put x (generalize (apply s1 env) t1) env) e2
+       >>= \(s2, t2)->pure (s1 oo s2, t2)

diff --git a/int.dcl b/int.dcl
index b36e59a..356b986 100644 (file)
--- a/int.dcl
+++ b/int.dcl
@@ -3,4 +3,5 @@ definition module int
 from Data.Either import :: Either
 from ast import :: Expression, :: Value
 
+:: Eval a
 int :: Expression -> Either [String] Value

diff --git a/int.icl b/int.icl
index 3b82750..4eeedf0 100644 (file)
--- a/int.icl
+++ b/int.icl
@@ -14,21 +14,21 @@ import Control.Monad.Trans
 import ast
 
 int :: Expression -> Either [String] Value
-int e = evalStateT (eval e >>= printer) preamble
-
-err :: String -> Eval a
-err e = liftT (Left [e])
+int e = evalStateT (eval e) preamble
 
 :: Eval a :== StateT EvalState (Either [String]) a
 :: EvalState :== [([Char], Value)]
 preamble =
-       [(['if'], Func 3 [] (Builtin ['if']))
-       ,(['eq'], Func 2 [] (Builtin ['eq']))
-       ,(['mul'], Func 2 [] (Builtin ['mul']))
-       ,(['div'], Func 2 [] (Builtin ['div']))
-       ,(['add'], Func 2 [] (Builtin ['add']))
-       ,(['sub'], Func 2 [] (Builtin ['sub']))
+       [(['_if'], Func \i->pure (Func \t->pure (Func \e->eval i >>= \(Bool b)->
+               if b (eval t) (eval e))))
+       ,(['_eq'],  binop \(Int i) (Int j)->Bool (i==j))
+       ,(['_sub'], binop \(Int i) (Int j)->Int (i-j))
+       ,(['_add'], binop \(Int i) (Int j)->Int (i+j))
+       ,(['_mul'], binop \(Int i) (Int j)->Int (i*j))
+       ,(['_div'], binop \(Int i) (Int j)->Int (i/j))
        ]
+where
+       binop op = Func \l->pure (Func \r->op <$> eval l <*> eval r)
 
 sub :: [Char] Expression Expression -> Expression
 sub ident subst (Let v b rest)
@@ -41,37 +41,10 @@ sub ident subst (Lambda v b)
        | ident <> v = Lambda v (sub ident b subst)
 sub _ _ x = x
 
-printer :: Value -> Eval Value
-printer (Func 0 args body) = eval (body args) >>= printer
-printer a = pure a
-
 eval :: Expression -> Eval Value
 eval (Let ident body rest)
-       =   modify (\vs->[(ident, Func 0 [] \_->body):vs])
-       >>| eval rest
+       = eval body >>= \v->modify (\vs->[(ident, v):vs]) >>| eval rest
 eval (Lit v) = pure v
-eval (Var v) = gets (lookup v) >>= maybe (err (toString v +++ " not found")) pure
-eval (App e1 e2) = eval e1 >>= \v->case v of
-//     (Func 0 a b) = err ("Saturated function: : " +++ toString e1)
-       (Func n as b) = pure (Func (n-1) (as ++ [e2]) b)
-//     _ = err ("Cannot apply " +++ toString e2 +++ " to " +++ toString e1)
-eval (Lambda a b) = pure (Func 1 [] (\[arg]->sub a arg b))
-eval (Builtin i as) = case (i, as) of
-       (['if'], [p,t,e]) = eval p >>= printer >>= \v->case v of
-               Bool v = eval (if v t e)
-//             _ = err ("first argument of if must be a bool but is " +++ toString v)
-       (['add'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
-               (Int a, Int b) = pure (Int (a + b))
-//             _ = err "add only defined for integers"
-       (['sub'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
-               (Int a, Int b) = pure (Int (a - b))
-//             _ = err "sub only defined for integers"
-       (['mul'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
-               (Int a, Int b) = pure (Int (a * b))
-//             _ = err "mul only defined for integers"
-       (['div'], [l,r]) = eval l >>= \l->eval r >>= \r->case (l,r) of
-               (Int a, Int b) = pure (Int (a / b))
-//             _ = err "div only defined for integers"
-       (['eq'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
-               (Int a, Int b) = pure (Bool (a == b))
-//             _ = err "eq only defined for integers"
+eval (Var v) = gets (lookup v) >>= maybe (liftT (Left [toString v +++ " not found"])) pure
+eval (App e1 e2) = eval e1 >>= \(Func v)->v e2
+eval (Lambda a b) = pure (Func \arg->eval (sub a arg b))

diff --git a/main.icl b/main.icl
index a13f267..9f9fd86 100644 (file)
--- a/main.icl
+++ b/main.icl
@@ -46,6 +46,6 @@ Start w
                MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [opts]\n") opts]
                MLex = map (\x->toString x +++ "\n") <$> lex cs
                MParse = map (\x->toString x +++ "\n") <$> (lex cs >>= parse)
-               MType = (\(e, x)->[toString x, "\n", toString e]) <$> (lex cs >>= parse >>= check)
+               MType = (\(e, x)->["type: ",toString x, "\n", toString e]) <$> (lex cs >>= parse >>= check)
                MInterpret = (\x->[toString x]) <$> (lex cs >>= parse >>= check >>= int o fst)
                MGen = lex cs >>= parse >>= check >>= gen o fst

diff --git a/parse.icl b/parse.icl
index 7d4fb2e..0c30e8c 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -116,4 +116,5 @@ where
                <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
                <|> (\(TTInt i)->Lit (Int i)) <$> pTop ? (\t->t=:(TTInt _))
                <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
+               <|> (\x->Var ['_':x]) <$ pId ? ((==)['code']) <*> pId
                <|> Var <$> pId

diff --git a/tests/preamble.mfp b/tests/preamble.mfp
index 3263957..bfceec2 100644 (file)
--- a/tests/preamble.mfp
+++ b/tests/preamble.mfp
@@ -1,8 +1,9 @@
 $ ifxr 0 x y = x y;
 & ifxr 0 x y = y x;
-== ifxl 7 x y = eq x y;
-* ifxl 7 x y = mul x y;
-- ifxl 6 x y = sub x y;
-+ ifxl 6 x y = add x y;
-fac i = if (i == 0) 1 $ i * fac (i - 1);
+== ifxl 7 = code eq;
+* ifxl 7 = code mul;
+- ifxl 6 = code sub;
++ ifxl 6 = code add;
+if = code if;
+fac i = if (i == 0) 1 (i * fac (i - 1));
 start = fac 5;