From ac7b63667302f503429153ca00889d1c98f498d4 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 8 Feb 2019 10:25:39 +0100
Subject: [PATCH] Initial commit

---
 .gitignore |   3 ++
 Makefile   |  11 +++++
 ast.dcl    |  23 ++++++++++
 ast.icl    |  28 ++++++++++++
 check.dcl  |   6 +++
 check.icl  | 129 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 gen.dcl    |   6 +++
 gen.icl    |   7 +++
 int.dcl    |   6 +++
 int.icl    |  89 ++++++++++++++++++++++++++++++++++++
 main.icl   |  13 ++++++
 parse.dcl  |   6 +++
 parse.icl  |  64 ++++++++++++++++++++++++++
 13 files changed, 391 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 Makefile
 create mode 100644 ast.dcl
 create mode 100644 ast.icl
 create mode 100644 check.dcl
 create mode 100644 check.icl
 create mode 100644 gen.dcl
 create mode 100644 gen.icl
 create mode 100644 int.dcl
 create mode 100644 int.icl
 create mode 100644 main.icl
 create mode 100644 parse.dcl
 create mode 100644 parse.icl

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..e13321d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+a.out
+Clean System Files
+main
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..3daeee7
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,11 @@
+CLM?=clm
+CLMFLAGS?=
+CLMLIBS?=-IL Platform
+
+all: main
+
+%: %.icl
+	$(CLM) $(CLMLIBS) $(CLMFLAGS) $* $(OUTPUT_OPTION)
+
+clean:
+	$(RM) -r "Clean System Files" main
diff --git a/ast.dcl b/ast.dcl
new file mode 100644
index 0000000..4bd177c
--- /dev/null
+++ b/ast.dcl
@@ -0,0 +1,23 @@
+definition module ast
+
+from Data.Either import :: Either
+from StdOverloaded import class toString
+
+:: AST = AST [Function]
+
+:: Function = Function [Char] [[Char]] Expression
+
+:: Expression
+	= Lit Value
+	| Var [Char]
+	| App Expression Expression
+	| Lambda [Char] Expression
+	| Builtin [Char] [Expression]
+
+:: Value
+	= Int Int
+	| Bool Bool
+	| Char Char
+	| Func Int [Expression] ([Expression] -> Expression)
+
+instance toString AST, Function, Expression, Value
diff --git a/ast.icl b/ast.icl
new file mode 100644
index 0000000..cee14de
--- /dev/null
+++ b/ast.icl
@@ -0,0 +1,28 @@
+implementation module ast
+
+import StdEnv
+import Text
+
+instance toString AST
+where
+	toString (AST f) = join "\n" (map toString f)
+
+instance toString Function
+where
+	toString (Function i a e) = concat [toString i, " ", join " " (map toString a), " = ", toString e]
+
+instance toString Expression
+where
+	toString (Lit v) = toString v
+	toString (Var s) = toString s
+	toString (App l r) = "(" +++ toString l +++ " " +++ toString r +++ ")"
+	toString (Lambda a e) = "(\\" +++ toString a +++ "." +++ toString e +++ ")"
+	toString (Builtin v as) = "'" +++ toString v +++ "'" +++ join " " (map toString as)
+	toString _ = abort "toString Expression not implemented"
+
+instance toString Value
+where
+	toString (Int i) = toString i
+	toString (Bool b) = toString b
+	toString (Char b) = "'" +++ toString b +++ "'"
+	toString (Func a as _) = "Function arity " +++ toString a +++ " curried " +++ join "," (map toString as)
diff --git a/check.dcl b/check.dcl
new file mode 100644
index 0000000..664b39e
--- /dev/null
+++ b/check.dcl
@@ -0,0 +1,6 @@
+definition module check
+
+from Data.Either import :: Either
+from ast import :: AST
+
+check :: AST -> Either [String] AST
diff --git a/check.icl b/check.icl
new file mode 100644
index 0000000..d717040
--- /dev/null
+++ b/check.icl
@@ -0,0 +1,129 @@
+implementation module check
+
+import StdEnv
+import Data.Either
+import Data.List
+import Data.Functor
+import Data.Func
+import Data.Maybe
+import Data.Monoid
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.RWST
+import qualified Data.Map as DM
+from Data.Map import instance Functor (Map k)
+
+import ast
+
+check :: AST -> Either [String] AST
+check (AST fs) = case find (\f->f=:(Function ['start'] [] _)) fs of
+	Nothing = Left ["No start function defined"]
+	Just _ = Right (AST fs)
+
+:: Type
+	= TVar [Char]
+	| TInt
+	| TBool
+	| TChar
+	| TFun Type Type
+instance == Type where
+	(==) (TVar a) (TVar b) = a == b
+	(==) TInt TInt = True
+	(==) TBool TBool = True
+	(==) TChar TChar = True
+	(==) (TFun a1 a2) (TFun b1 b2) = a1 == b1 && a2 == b2
+	(==) _ _ = False
+instance toString Type where
+	toString (TVar s) = toString s
+	toString TInt = "Int"
+	toString TBool = "Bool"
+	toString TChar = "Char"
+	toString (TFun t1 t2) = toString t1 +++ " -> " +++ toString t2
+:: Scheme = Scheme [[Char]] Type
+class Types a where
+	ftv :: a -> [[Char]]
+	apply :: Subst a -> a
+instance Types Type where
+	ftv (TVar n) = [n]
+	ftv TInt = []
+	ftv TBool = []
+	ftv TChar = []
+	ftv (TFun t1 t2) = union (ftv t1) (ftv t2)
+
+	apply s (TVar n) = case 'DM'.get n s of
+		Nothing = TVar n
+		Just t = t
+	apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2)
+	apply s t = t
+instance Types Scheme where
+	ftv (Scheme vars t) = difference (ftv t) vars
+	apply s (Scheme vars t) = Scheme vars (apply (foldr 'DM'.del s vars) t)
+instance Types [a] | Types a where
+	ftv l = foldr union [] (map ftv l)
+	apply s l = map (apply s) l
+
+:: Subst :== 'DM'.Map [Char] Type
+composeSubst s1 s2 = 'DM'.union ((apply s1) <$> s2) s1
+
+:: TypeEnv = TypeEnv ('DM'.Map [Char] Scheme)
+remove :: TypeEnv [Char] -> TypeEnv
+remove (TypeEnv env) var = TypeEnv ('DM'.del var env)
+
+instance Types TypeEnv where
+	ftv (TypeEnv env) = ftv ('DM'.elems env)
+	apply s (TypeEnv env) = TypeEnv (apply s <$> env)
+
+generalize :: TypeEnv Type -> Scheme
+generalize env t = Scheme (difference (ftv t) (ftv env)) t
+
+:: TI a :== RWST TIEnv () TIState (Either [String]) a
+:: TIState = {tiSupply :: Int, tiSubst :: Subst}
+:: TIEnv :== [Int]
+
+mgu :: Type Type -> TI Subst
+mgu (TFun l r) (TFun l` r`) = composeSubst <$> mgu l l` <*> mgu r r`
+mgu (TVar u) t = varBind u t
+mgu t (TVar u) = varBind u t
+mgu TInt TInt = pure 'DM'.newMap
+mgu TBool TBool = pure 'DM'.newMap
+mgu TChar TChar = pure 'DM'.newMap
+mgu t1 t2 = liftT (Left ["cannot unify: " +++ toString t1 +++ " with " +++ toString t2])
+
+varBind :: [Char] Type -> TI Subst
+varBind u t
+	| t == TVar u = pure 'DM'.newMap
+	| isMember u (ftv t) = liftT (Left ["occur check fails: " +++ toString u +++ " vs. " +++ toString t])
+	= pure ('DM'.singleton u t)
+
+newTyVar :: [Char] -> TI Type
+newTyVar prefix
+	=   get
+	>>= \t->put {t & tiSupply=t.tiSupply+1}
+	>>| pure (TVar (prefix ++ fromString (toString t.tiSupply)))
+
+instantiate :: Scheme -> TI Type
+instantiate (Scheme vars t)
+	= mapM (\_->newTyVar ['a']) vars
+	>>= \nvars->pure (apply ('DM'.fromList (zip2 vars nvars)) t)
+
+class infer a :: TypeEnv a -> TI (Subst, Type)
+instance infer Value where
+	infer _ (Int _) = pure ('DM'.newMap, TInt)
+	infer _ (Bool _) = pure ('DM'.newMap, TBool)
+	infer _ (Char _) = pure ('DM'.newMap, TChar)
+instance infer Expression where
+	infer e (Lit a) = infer e a
+	infer (TypeEnv env) (Var v) = case 'DM'.get v env of
+		Nothing = liftT (Left ["unbound variable: " +++ toString v])
+		Just s = instantiate s >>= \t->pure ('DM'.newMap, t)
+	infer env (App e1 e2)
+		=              newTyVar ['a']
+		>>= \tv      ->infer env e1
+		>>= \(s1, t1)->infer (apply s1 env) e2
+		>>= \(s2, t2)->mgu (apply s2 t1) (TFun t2 tv)
+		>>= \s3->pure (composeSubst s3 (composeSubst s2 s1), apply s3 tv)
+	//infer env (Lambda s e)
+	//	=        newTyVar ['l']
+	//	>>= \tv->pure undef//inEnv (s, Forall [] tv) (infer e)
+	//	>>= \t-> pure (TFun tv t)
diff --git a/gen.dcl b/gen.dcl
new file mode 100644
index 0000000..e9e876d
--- /dev/null
+++ b/gen.dcl
@@ -0,0 +1,6 @@
+definition module gen
+
+from Data.Either import :: Either
+from ast import :: AST
+
+gen :: AST -> Either [String] [String]
diff --git a/gen.icl b/gen.icl
new file mode 100644
index 0000000..b03d398
--- /dev/null
+++ b/gen.icl
@@ -0,0 +1,7 @@
+implementation module gen
+
+import StdEnv
+
+import ast
+
+gen :: AST -> Either [String] [String]
diff --git a/int.dcl b/int.dcl
new file mode 100644
index 0000000..1b8d96f
--- /dev/null
+++ b/int.dcl
@@ -0,0 +1,6 @@
+definition module int
+
+from Data.Either import :: Either
+from ast import :: AST, :: Value
+
+int :: AST -> Either [String] Value
diff --git a/int.icl b/int.icl
new file mode 100644
index 0000000..495494a
--- /dev/null
+++ b/int.icl
@@ -0,0 +1,89 @@
+implementation module int
+
+import StdEnv
+
+import Data.Either
+import Data.Functor
+import Data.Maybe
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+
+import ast
+
+int :: AST -> Either [String] Value
+int (AST fs) = evalStateT (mapM evalFun fs >>| getStart fs >>= eval >>= printer) preamble
+
+err :: String -> Eval a
+err e = liftT (Left [e])
+
+getStart :: [Function] -> Eval Expression
+getStart [] = err "No start rule defined"
+getStart [(Function ['start'] _ e):_] = pure e
+getStart [_:fs] = getStart fs
+
+:: 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']))
+	]
+
+putEnv :: [Char] Value -> Eval ()
+putEnv i v = modify (\vs->[(i,v):vs])
+
+getEnv :: [Char] -> Eval Value
+getEnv v = gets (lookup v)
+	>>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
+
+evalFun :: Function -> Eval ()
+evalFun (Function v a b) = putEnv v (Func (length a) [] (\es->fun a es b))
+where
+	fun [] [] body = body
+	fun [a:as] [e:es] body = fun as es (sub a e body)
+
+printer :: Value -> Eval Value
+printer t=:(Func 0 args body) = eval (body args) >>= printer
+printer a = pure a
+
+sub :: [Char] Expression Expression -> Expression
+sub ident subst (Var v)
+	| ident == v = subst
+sub ident subst (App e1 e2) = App (sub ident subst e1) (sub ident subst e2)
+sub ident subst (Lambda v b)
+	| ident <> v = Lambda v (sub ident b subst)
+sub _ _ x = x
+
+eval :: Expression -> Eval Value
+eval (Lit v) = pure v
+eval (Var v) = getEnv v
+eval (App e1 e2) = eval e1 >>= \v->case v of
+	(Func 0 a b) = err "Saturated function"
+	(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"
diff --git a/main.icl b/main.icl
new file mode 100644
index 0000000..229b12d
--- /dev/null
+++ b/main.icl
@@ -0,0 +1,13 @@
+module main
+
+import StdEnv
+import Data.Either
+import Data.Functor
+import Control.Monad
+
+import parse
+import ast
+import check
+import int
+
+Start = parse ['ap f x = f x; fac i = if (eq i 0) 1 (mul i (fac (sub i 1))); start = ap fac 5;'] >>= check >>= int
diff --git a/parse.dcl b/parse.dcl
new file mode 100644
index 0000000..011c9da
--- /dev/null
+++ b/parse.dcl
@@ -0,0 +1,6 @@
+definition module parse
+
+from Data.Either import :: Either
+from ast import :: AST
+
+parse :: [Char] -> Either [String] AST
diff --git a/parse.icl b/parse.icl
new file mode 100644
index 0000000..3ea9884
--- /dev/null
+++ b/parse.icl
@@ -0,0 +1,64 @@
+implementation module parse
+
+import Control.Applicative
+import Control.Monad
+import Data.Either
+import Data.Functor
+import Data.Func
+import StdEnv
+import Text.Parsers.Simple.ParserCombinators => qualified parse
+
+import ast
+
+(<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
+(<:>) l r = (\xs->[l:xs]) <$> r
+
+:: Token = TEq | TSemiColon | TLambda | TDot | TBrackOpen | TBrackClose | TBool Bool | TChar Char | TInt Int | TIdent [Char]
+
+lex :: [Char] -> Either [String] [Token]
+lex [] = pure []
+lex ['=':ts] = TEq <:> lex ts
+lex [';':ts] = TSemiColon <:> lex ts
+lex ['\\':ts] = TLambda <:> lex ts
+lex ['.':ts] = TDot <:> lex ts
+lex [')':ts] = TBrackClose <:> lex ts
+lex ['(':ts] = TBrackOpen <:> lex ts
+lex ['True':ts] = TBool True <:> lex ts
+lex ['False':ts] = TBool False <:> lex ts
+lex ['\'',c,'\'':ts] = TChar c <:> lex ts
+lex ['-',t:ts]
+	| isDigit t = lex [t:ts] >>= \v->case v of
+		[TInt i:rest] = Right [TInt (~i):rest]
+		x = pure x
+lex [t:ts]
+	| isSpace t = lex ts
+	| isDigit t
+		# (i, ts) = span isDigit [t:ts]
+		= TInt (toInt (toString i)) <:> lex ts
+	| isAlpha t
+		# (i, ts) = span isAlpha [t:ts]
+		= TIdent i <:> lex ts
+	= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
+
+parse :: [Char] -> Either [String] AST
+parse t = lex t >>= 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
+where
+	pId = (\(TIdent i)->i) <$> pSatisfy (\t->t=:(TIdent _))
+
+	pFunction :: Parser Token Function
+	pFunction
+		=   Function
+		<$> pId
+		<*> many pId
+		<*  pSatisfy (\t->t=:TEq)
+		<*> pExpression
+		<*  pSatisfy (\t->t=:TSemiColon)
+
+	pExpression :: Parser Token Expression
+	pExpression = flip pChainl1 (pure App) $
+		     (Lambda <$ pSatisfy (\t->t=:TLambda) <*> pId <* pSatisfy (\t->t=:TDot) <*> pExpression)
+		<<|> (pSatisfy (\t->t=:TBrackOpen) *> pExpression <* pSatisfy (\t->t=:TBrackClose))
+		<<|> ((\(TInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TInt _)))
+		<<|> ((\(TChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TChar _)))
+		<<|> ((\(TBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TBool _)))
+		<<|> (Var <$> pId)
-- 
2.20.1