From 8271e638a28c70d69cdea378669e9c41fac6df1b Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 6 Mar 2019 11:21:15 +0100
Subject: [PATCH] interpret

---
 Makefile           |  2 +-
 ast.dcl            |  6 +++--
 ast.icl            |  5 ++--
 check.dcl          |  2 +-
 check.icl          | 57 +++++++++++++++++++++++++++-------------------
 int.dcl            |  1 +
 int.icl            | 55 ++++++++++++--------------------------------
 main.icl           |  2 +-
 parse.icl          |  1 +
 tests/preamble.mfp | 11 +++++----
 10 files changed, 66 insertions(+), 76 deletions(-)

diff --git a/Makefile b/Makefile
index 412aba0..c0b5828 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;
-- 
2.20.1