From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 21 Feb 2019 12:58:34 +0000 (+0100)
Subject: more
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=7b0b4bbe170f0e087ca9e7fa5eb426ecfc082c7f;p=minfp.git

more
---

diff --git a/ast.dcl b/ast.dcl
index 4bd177c..392b589 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -20,4 +20,11 @@ from StdOverloaded import class toString
 	| Char Char
 	| Func Int [Expression] ([Expression] -> Expression)
 
-instance toString AST, Function, Expression, Value
+:: Type
+	= TVar [Char]
+	| TInt
+	| TBool
+	| TChar
+	| TFun Type Type
+
+instance toString AST, Function, Expression, Value, Type
diff --git a/ast.icl b/ast.icl
index cee14de..f4d780b 100644
--- a/ast.icl
+++ b/ast.icl
@@ -3,16 +3,13 @@ implementation module ast
 import StdEnv
 import Text
 
-instance toString AST
-where
+instance toString AST where
 	toString (AST f) = join "\n" (map toString f)
 
-instance toString Function
-where
+instance toString Function where
 	toString (Function i a e) = concat [toString i, " ", join " " (map toString a), " = ", toString e]
 
-instance toString Expression
-where
+instance toString Expression where
 	toString (Lit v) = toString v
 	toString (Var s) = toString s
 	toString (App l r) = "(" +++ toString l +++ " " +++ toString r +++ ")"
@@ -20,9 +17,15 @@ where
 	toString (Builtin v as) = "'" +++ toString v +++ "'" +++ join " " (map toString as)
 	toString _ = abort "toString Expression not implemented"
 
-instance toString Value
-where
+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)
+
+instance toString Type where
+	toString (TVar a) = toString a
+	toString TInt = "Int"
+	toString TBool = "Bool"
+	toString TChar = "Char"
+	toString (TFun a b) = "(" +++ toString a +++ ") ->" +++ toString b
diff --git a/check.dcl b/check.dcl
index 664b39e..015d891 100644
--- a/check.dcl
+++ b/check.dcl
@@ -1,6 +1,7 @@
 definition module check
 
 from Data.Either import :: Either
-from ast import :: AST
+from ast import :: AST, :: Type
 
-check :: AST -> Either [String] AST
+:: Scheme     =   Forall [[Char]] Type
+check :: AST -> Either [String] (AST, [([Char], Scheme)])
diff --git a/check.icl b/check.icl
index 452bb69..838e1fa 100644
--- a/check.icl
+++ b/check.icl
@@ -1,170 +1,192 @@
 implementation module check
 
 import StdEnv
-import Data.Either
-import Data.List
+
+import qualified Data.Map as DM
+from Data.Map import instance Functor (Map k)
+import qualified Data.Set as DS
 import Data.Functor
 import Data.Func
+import Data.Either
+import Data.List
 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 qualified Control.Monad.State as MS
+import Control.Monad.State => qualified gets, put, modify
+import Control.Monad.RWST => qualified put
 
 import ast
 
-//Start = runRWST (infer (AST [(Function ['s','t','a','r','t'] [] (Lit (Int 42)))])
-Start = runRWST (infer (TypeEnv 'DM'.newMap) t) [] {tiSupply=0,tiSubst='DM'.newMap}
+check :: AST -> Either [String] (AST, [([Char], Scheme)])
+check (AST fs) = pure (AST fs, [])/*case inferAST preamble fs of
+	Left e = Left e
+	Right s = Right (AST fs, 'DM'.toList s)
 where
-//	t = Function ['start'] [] (Lit (Int 42))
-	t =
-		[Function ['id'] [] (Lit (Int 42))
-		,Function ['start'] [] (App (Var ['id']) (Lit (Int 42)))
+	preamble = 'DM'.fromList
+		[(['if'], Forall [['a']] $ TFun TBool $ TFun (TVar ['a']) $ TFun (TVar ['a']) $ TVar ['a'])
+		,(['eq'], Forall [] $ TFun TInt $ TFun TInt TBool)
+		,(['mul'], Forall [] $ TFun TInt $ TFun TInt TInt)
+		,(['div'], Forall [] $ TFun TInt $ TFun TInt TInt)
+		,(['add'], Forall [] $ TFun TInt $ TFun TInt TInt)
+		,(['sub'], Forall [] $ TFun TInt $ TFun TInt TInt)
 		]
+*/
+
+:: TypeEnv    :== 'DM'.Map [Char] Scheme
+:: Constraint :== (Type, Type)
+:: Subst      :== 'DM'.Map [Char] Type
+:: Unifier    :== (Subst, [Constraint])
+:: Infer a    :== RWST TypeEnv [Constraint] InferState (Either [String]) a
+:: InferState =   { count :: Int }
+:: Scheme     =   Forall [[Char]] Type
+:: Solve a    :== StateT Unifier (Either [String]) a
 
-check :: AST -> Either [String] AST
-check (AST fs) = case sortBy (on (>) isStart) fs of
-	[(Function ['start'] as _):rest]
-		= case runRWST (infer (TypeEnv 'DM'.newMap) fs) [] {tiSupply=0,tiSubst='DM'.newMap} of
-			Left e = Left e
-			Right _ = Right (AST fs)
-	_ = Left ["No start function defined"]
+nullSubst :: Subst
+nullSubst = 'DM'.newMap
+
+uni :: Type Type -> Infer ()
+uni t1 t2 = tell [(t1, t2)]
+
+inEnv :: ([Char], Scheme) (Infer a) -> Infer a
+inEnv (x, sc) m = local (\e->'DM'.put x sc $ 'DM'.del x e) m
+
+letters :: [[Char]]
+letters = [1..] >>= flip replicateM ['a'..'z']
+
+fresh :: Infer Type
+fresh = get >>= \s=:{count}->'Control.Monad.RWST'.put {s & count=count + 1} >>| pure (TVar $ letters !! count)
+
+class Substitutable a
 where
-	isStart a = a=:(Function ['start'] [] _)
-
-instance < Bool where
-	< False True = True
-	< _ _ = False
-
-:: 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
+	ftv   :: a -> [[Char]]
 
-instance Types Type where
-	ftv (TVar n) = [n]
-	ftv TInt = []
-	ftv TBool = []
-	ftv TChar = []
-	ftv (TFun t1 t2) = union (ftv t1) (ftv t2)
+instance Substitutable Type
+where
+	apply s t=:(TVar a) = maybe t id $ 'DM'.get a s
+	apply s (TFun t1 t2)  = TFun (apply s t1) (apply s t2)
+	apply _ t = t
 
-	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
+	ftv (TVar a)     = [a]
+	ftv (TFun t1 t2) = union (ftv t1) (ftv t2)
+	ftv 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 Substitutable Scheme
+where
+	apply s (Forall as t)   = Forall as $ apply (foldr 'DM'.del s as) t
+	ftv (Forall as t) = difference (ftv t) as
 
-instance Types [a] | Types a where
-	ftv l = foldr union [] (map ftv l)
-	apply s l = map (apply s) l
+instance Substitutable [a] | Substitutable a
+where
+	apply s ls = map (apply s) ls
+	ftv t = foldr (union o ftv) [] t
 
-:: Subst :== 'DM'.Map [Char] Type
-composeSubst s1 s2 = 'DM'.union ((apply s1) <$> s2) s1
+instance Substitutable TypeEnv where
+	apply s env = fmap (apply s) env
+	ftv env = ftv $ 'DM'.elems env
 
-:: TypeEnv = TypeEnv ('DM'.Map [Char] Scheme)
-remove :: TypeEnv [Char] -> TypeEnv
-remove (TypeEnv env) var = TypeEnv ('DM'.del var env)
+instance Substitutable Constraint where
+	apply s (t1, t2) = (apply s t1, apply s t2)
+	ftv (t1, t2) = union (ftv t1) (ftv t2)
 
-instance Types TypeEnv where
-	ftv (TypeEnv env) = ftv ('DM'.elems env)
-	apply s (TypeEnv env) = TypeEnv (apply s <$> env)
+instantiate ::  Scheme -> Infer Type
+instantiate (Forall as t) = mapM (const fresh) as
+	>>= \as`->let s = 'DM'.fromList $ zip2 as as` in pure $ apply s t
 
 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->
-			let (TypeEnv env`) = remove env s
-			    env`` = TypeEnv ('DM'.union env` ('DM'.singleton s (Scheme [] tv)))
-			in infer env`` e
-		>>= \(s1, t1)->pure (s1, TFun (apply s1 tv) t1)
-
-instance infer [Function] where
-	infer env [] = pure ('DM'.newMap, TInt)
-	infer env [Function name args body:rest]
-		= infer env (foldr Lambda body args) >>= \(s1, t1)->
-				let (TypeEnv env`) = remove env name
-					t`             = generalize (apply s1 env) t1
-					env``          = TypeEnv ('DM'.put name t` env`)
-				in infer (apply s1 env``) rest >>= \(s2, t2)->pure (composeSubst s1 s2, t2)
-
-typeInference :: ('DM'.Map [Char] Scheme) Expression -> TI Type
-typeInference env e = uncurry apply <$> infer (TypeEnv env) e
+generalize env t = Forall (difference (ftv t) (ftv env)) t
+
+//:: Expression
+//	= Lit Value
+//	| Var [Char]
+//	| App Expression Expression
+//	| Lambda [Char] Expression
+//	| Builtin [Char] [Expression]
+inferExpr :: TypeEnv Expression -> Either [String] Scheme
+inferExpr env ex = case runRWST (infer ex) env {count=0} of
+	Left e = Left e
+	Right (ty, st, cs) = case runStateT solver ('DM'.newMap, cs) of
+		Left e = Left e
+		Right (s, _) = Right (closeOver (apply s ty))
+
+closeOver :: Type -> Scheme
+closeOver t = normalize (generalize 'DM'.newMap t)
+
+normalize :: Scheme -> Scheme
+normalize t = t 
+
+inferAST :: TypeEnv [Function] -> Either [String] TypeEnv
+inferAST env [] = Right env
+inferAST env [Function name args body:rest] = case inferExpr env (foldr Lambda body args) of
+	Left e = Left e
+	Right ty = inferAST ('DM'.put name ty env) rest
+
+inferFunc :: [Function] -> Infer ()
+inferFunc [] = pure () 
+inferFunc [Function name args body:rest]
+	=      ask
+	>>= \en->infer (foldr Lambda body args)
+	>>= \t1->inEnv (name, generalize en t1) (inferFunc rest)
+	>>= \_->pure ()
+
+infer :: Expression -> Infer Type
+infer (Lit v) = case v of
+	Int  _ = pure TInt
+	Bool _ = pure TBool
+	Char _ = pure TChar
+infer (Var s) = asks ('DM'.get s)
+	>>= maybe (liftT $ Left ["Unbound variable " +++ toString s]) instantiate
+infer (App e1 e2)
+	=        infer e1
+	>>= \t1->infer e2
+	>>= \t2->fresh
+	>>= \tv->uni t1 (TFun t2 tv)
+	>>|      pure tv
+infer (Lambda s e)
+	=        fresh
+	>>= \tv->inEnv (s, Forall [] tv) (infer e)
+	>>= \t-> pure (TFun tv t)
+//infer (Let x e1 e2)
+//	=        ask
+//	>>= \en->infer e1
+//	>>= \t1->inEnv (x, generalize en t1) (infer e2)
+
+unifies :: Type Type -> Solve Unifier
+unifies TInt TInt = pure ('DM'.newMap, [])
+unifies TBool TBool = pure ('DM'.newMap, [])
+unifies TChar TChar = pure ('DM'.newMap, [])
+unifies (TVar a) (TVar b) 
+	| a == b = pure ('DM'.newMap, [])
+unifies (TVar v) t = tbind v t
+unifies t (TVar v) = tbind v t
+unifies (TFun t1 t2) (TFun t3 t4) = unifyMany [t1, t2] [t3, t4]
+unifies t1 t2 = liftT $ Left ["Cannot unify " +++ toString t1 +++ " with " +++ toString t2]
+
+unifyMany :: [Type] [Type] -> Solve Unifier
+unifyMany [] [] = pure ('DM'.newMap, [])
+unifyMany [t1:ts1] [t2:ts2] = unifies t1 t2
+	>>= \(su1, cs1)->unifyMany (apply su1 ts1) (apply su1 ts2)
+	>>= \(su2, cs2)->pure (su2 `compose` su1, cs1 ++ cs2)
+unifyMany t1 t2 = liftT $ Left ["Length difference in unifyMany"]
+
+(`compose`) infix 1 :: Subst Subst -> Subst
+(`compose`) s1 s2 = 'DM'.union (apply s1 <$> s2) s1
+
+tbind ::  [Char] Type -> Solve Unifier
+tbind a (TVar b)
+	| a == b = pure ('DM'.newMap, [])
+tbind a t
+	| occursCheck a t = liftT $ Left ["Infinite type " +++ toString a +++ toString t]
+	= pure $ ('DM'.singleton a t, [])
+
+occursCheck ::  [Char] a -> Bool | Substitutable a
+occursCheck a t = isMember a $ ftv t
+
+solver :: Solve Subst
+solver = getState >>= \(su, cs)->case cs of
+	[] = pure su
+	[(t1, t2):cs0] = unifies t1 t2
+		>>= \(su1, cs1)->'MS'.put (su1 `compose` su, cs1 ++ (apply su1 cs0))
+		>>| solver
diff --git a/gen.icl b/gen.icl
index 12877b9..8e96fec 100644
--- a/gen.icl
+++ b/gen.icl
@@ -2,12 +2,31 @@ implementation module gen
 
 import StdEnv
 
-import Control.Applicative
-import Control.Monad
-import Data.Functor
 import Data.Either
+import Text
 
 import ast
 
 gen :: AST -> Either [String] [String]
-gen _ = pure []
+gen (AST fs) = Right (genCode fs [])
+
+class genCode a :: a [String] -> [String]
+instance genCode String where genCode s c = [s:c]
+instance genCode Char where genCode s c = genCode (toString s) c
+instance genCode [a] | genCode a where
+	genCode [] c = c
+	genCode [a:as] c = genCode a (genCode as c)
+instance genCode Function where
+	genCode (Function name args body) c
+		= ["stackval_t ", toString name, "(":genCode (join ", " (map toString args)) [") { return ":genCode body ["; }\n":c]]]
+instance genCode Value where
+	genCode (Int i) c = genCode (toString i) c
+	genCode (Char i) c = genCode ['\'',i,'\''] c
+	genCode (Bool i) c = genCode (if i "true" "false") c
+	genCode (Func _ _ _) c = abort "help"
+instance genCode Expression where
+	genCode (Lit l) c = genCode l c
+	genCode (Var v) c = genCode v c
+	genCode (App a b) c = ["ap(":genCode a [", ":genCode b [")":c]]]
+	genCode (Lambda a b) c = abort "help"
+	genCode (Builtin b args) c = genCode b ["(":genCode args [")":c]]
diff --git a/int.icl b/int.icl
index 495494a..4d2087a 100644
--- a/int.icl
+++ b/int.icl
@@ -64,26 +64,26 @@ 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 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)
+//	_ = 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)
+//		_ = 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"
+//		_ = 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"
+//		_ = 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"
+//		_ = 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"
+//		_ = 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"
+//		_ = err "eq only defined for integers"
diff --git a/main.icl b/main.icl
index ea1825c..d2b5114 100644
--- a/main.icl
+++ b/main.icl
@@ -25,7 +25,7 @@ chars f
 :: Result
 	= Lex [Token]
 	| Parse AST
-	| Type AST
+	| Type [([Char], Scheme)]
 	| Interpret Value
 	| Gen [String]
 
@@ -36,7 +36,7 @@ options =
 	, Option ['p'] ["parse"]     (NoArg (const MParse))     "Up to and including parse"
 	, Option ['t'] ["type"]      (NoArg (const MType))      "Up to and including typing"
 	, Option ['i'] ["interpret"] (NoArg (const MInterpret)) "Up to and including interpretation"
-	, Option ['g'] ["gen"]       (NoArg (const MInterpret)) "Up to and including generation"
+	, Option ['g'] ["gen"]       (NoArg (const MGen))       "Up to and including generation"
 	]
 
 Start :: *World -> Either [String] Result
@@ -52,6 +52,6 @@ Start w
 		MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [options]\n") options]
 		MLex = Lex <$> lex cs
 		MParse = Parse <$> (lex cs >>= parse)
-		MType = Type <$> (lex cs >>= parse >>= check)
-		MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int)
-		MGen = Gen <$> (lex cs >>= parse >>= check >>= gen)
+		MType = Type <$> snd <$> (lex cs >>= parse >>= check)
+		MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int o fst)
+		MGen = Gen <$> (lex cs >>= parse >>= check >>= gen o fst)
diff --git a/parse.icl b/parse.icl
index 05ba36f..355e136 100644
--- a/parse.icl
+++ b/parse.icl
@@ -13,52 +13,52 @@ 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]
+:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTChar Char | TTInt Int | TTIdent [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 ['=':ts] = TTEq <:> lex ts
+lex [';':ts] = TTSemiColon <:> lex ts
+lex ['\\':ts] = TTLambda <:> lex ts
+lex ['.':ts] = TTDot <:> lex ts
+lex [')':ts] = TTBrackClose <:> lex ts
+lex ['(':ts] = TTBrackOpen <:> lex ts
+lex ['True':ts] = TTBool True <:> lex ts
+lex ['False':ts] = TTBool False <:> lex ts
+lex ['\'',c,'\'':ts] = TTChar c <:> lex ts
 lex ['-',t:ts]
 	| isDigit t = lex [t:ts] >>= \v->case v of
-		[TInt i:rest] = Right [TInt (~i):rest]
+		[TTInt i:rest] = Right [TTInt (~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
+		= TTInt (toInt (toString i)) <:> lex ts
 	| isAlpha t
 		# (i, ts) = span isAlpha [t:ts]
-		= TIdent i <:> lex ts
+		= TTIdent i <:> lex ts
 	= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
 
 parse :: ([Token] -> Either [String] AST)
 parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
 where
-	pId = (\(TIdent i)->i) <$> pSatisfy (\t->t=:(TIdent _))
+	pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
 
 	pFunction :: Parser Token Function
 	pFunction
 		=   Function
 		<$> pId
 		<*> many pId
-		<*  pSatisfy (\t->t=:TEq)
+		<*  pSatisfy (\t->t=:TTEq)
 		<*> pExpression
-		<*  pSatisfy (\t->t=:TSemiColon)
+		<*  pSatisfy (\t->t=:TTSemiColon)
 
 	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 _)))
+		     (Lambda <$ pSatisfy (\t->t=:TTLambda) <*> pId <* pSatisfy (\t->t=:TTDot) <*> pExpression)
+		<<|> (pSatisfy (\t->t=:TTBrackOpen) *> pExpression <* pSatisfy (\t->t=:TTBrackClose))
+		<<|> ((\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _)))
+		<<|> ((\(TTChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TTChar _)))
+		<<|> ((\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _)))
 		<<|> (Var <$> pId)
diff --git a/tests/fac.mfp b/tests/fac.mfp
new file mode 100644
index 0000000..ba8b5f6
--- /dev/null
+++ b/tests/fac.mfp
@@ -0,0 +1,2 @@
+fac i = if (eq i 0) 1 (mul i (fac (sub i 1)));
+start = fac 5;