From 7b0b4bbe170f0e087ca9e7fa5eb426ecfc082c7f Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 21 Feb 2019 13:58:34 +0100 Subject: [PATCH] more --- ast.dcl | 9 +- ast.icl | 19 ++-- check.dcl | 5 +- check.icl | 310 +++++++++++++++++++++++++++----------------------- gen.icl | 27 ++++- int.icl | 16 +-- main.icl | 10 +- parse.icl | 42 +++---- tests/fac.mfp | 2 + 9 files changed, 247 insertions(+), 193 deletions(-) create mode 100644 tests/fac.mfp 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; -- 2.20.1