--- /dev/null
+a.out
+Clean System Files
+main
--- /dev/null
+CLM?=clm
+CLMFLAGS?=
+CLMLIBS?=-IL Platform
+
+all: main
+
+%: %.icl
+ $(CLM) $(CLMLIBS) $(CLMFLAGS) $* $(OUTPUT_OPTION)
+
+clean:
+ $(RM) -r "Clean System Files" main
--- /dev/null
+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
--- /dev/null
+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)
--- /dev/null
+definition module check
+
+from Data.Either import :: Either
+from ast import :: AST
+
+check :: AST -> Either [String] AST
--- /dev/null
+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)
--- /dev/null
+definition module gen
+
+from Data.Either import :: Either
+from ast import :: AST
+
+gen :: AST -> Either [String] [String]
--- /dev/null
+implementation module gen
+
+import StdEnv
+
+import ast
+
+gen :: AST -> Either [String] [String]
--- /dev/null
+definition module int
+
+from Data.Either import :: Either
+from ast import :: AST, :: Value
+
+int :: AST -> Either [String] Value
--- /dev/null
+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"
--- /dev/null
+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
--- /dev/null
+definition module parse
+
+from Data.Either import :: Either
+from ast import :: AST
+
+parse :: [Char] -> Either [String] AST
--- /dev/null
+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)
repositories / minfp.git / commitdiff