From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 8 Feb 2019 09:25:39 +0000 (+0100)
Subject: Initial commit
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=ac7b63667302f503429153ca00889d1c98f498d4;p=minfp.git

Initial commit
---

ac7b63667302f503429153ca00889d1c98f498d4
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)