From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 4 Mar 2019 15:08:41 +0000 (+0100)
Subject: parsing cleaner
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=49620a23e5fa1bc5f862a4fa191163ebdd1b1de3;p=minfp.git

parsing cleaner
---

diff --git a/ast.dcl b/ast.dcl
index 9e733b2..6987c5b 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -23,4 +23,4 @@ from StdOverloaded import class toString
 	| TBool
 	| TFun Type Type
 
-instance toString Expression, Value, Type
+instance toString Function, Expression, Value, Type
diff --git a/check.icl b/check.icl
index 93f579d..e332b59 100644
--- a/check.icl
+++ b/check.icl
@@ -16,8 +16,6 @@ check fs
 		([], _) = Left ["No start function defined"]
 		([Function _ [] e], fs) = Right (foldr (\(Function i a e)->Let i a e) e fs)
 		([Function _ _ _], _) = Left ["Start cannot have arguments"]
-where
-	funs = [i\\(Function i _ _)<-fs]
 
 //import qualified Data.Map as DM
 //from Data.Map import instance Functor (Map k)
diff --git a/int.icl b/int.icl
index be7e595..4cf6b78 100644
--- a/int.icl
+++ b/int.icl
@@ -14,17 +14,11 @@ import Control.Monad.Trans
 import ast
 
 int :: Expression -> Either [String] Value
-int _ = Left ["intbork"]
-/*int (AST fs) = evalStateT (mapM evalFun fs >>| getStart fs >>= eval >>= printer) preamble
+int e = evalStateT (eval e >>= 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 =
@@ -36,24 +30,10 @@ preamble =
 	,(['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 (Let v a b rest)
+	= Let v a (if (isMember ident a) b (sub ident subst b))
+		(if (v == ident) rest (sub ident subst rest))
 sub ident subst (Var v)
 	| ident == v = subst
 sub ident subst (App e1 e2) = App (sub ident subst e1) (sub ident subst e2)
@@ -61,13 +41,21 @@ sub ident subst (Lambda v b)
 	| ident <> v = Lambda v (sub ident b subst)
 sub _ _ x = x
 
+printer :: Value -> Eval Value
+printer (Func 0 args body) = eval (body args) >>= printer
+printer a = pure a
+
 eval :: Expression -> Eval Value
+eval (Let ident as body rest)
+	=   modify (\vs->[(ident, Func (length as) [] \e->zipSt sub as e body):vs])
+	>>| eval rest
 eval (Lit v) = pure v
-eval (Var v) = getEnv v
+eval (Var v) = gets (lookup v)
+	>>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
 eval (App e1 e2) = eval e1 >>= \v->case v of
-//	(Func 0 a b) = err "Saturated function"
+	(Func 0 a b) = err ("Saturated function: : " +++ toString e1)
 	(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
@@ -88,4 +76,3 @@ eval (Builtin i as) = case (i, as) of
 	(['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
index 910de46..30f7d9f 100644
--- a/main.icl
+++ b/main.icl
@@ -4,7 +4,8 @@ import StdEnv
 import Data.Either
 import Data.Functor
 import Data.Func
-import Control.Monad
+import Text
+import Control.Monad => qualified join
 import System.GetOpt
 import System.CommandLine
 
@@ -24,7 +25,7 @@ chars f
 :: Mode = MHelp | MLex | MParse | MType | MInterpret | MGen
 :: Result
 	= Lex [Token]
-	| Parse [Function]
+	| Parse String
 	| Type Expression
 	| Interpret Value
 	| Gen [String]
@@ -51,7 +52,7 @@ Start w
 	= case mode of
 		MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [options]\n") options]
 		MLex = Lex <$> lex cs
-		MParse = Parse <$> (lex cs >>= parse)
+		MParse = Parse <$> join "\n" <$> map toString <$> (lex cs >>= parse)
 		MType = Type <$> (lex cs >>= parse >>= check)
 		MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int)
 		MGen = Gen <$> (lex cs >>= parse >>= check >>= gen)
diff --git a/parse.icl b/parse.icl
index c35f78a..99f0246 100644
--- a/parse.icl
+++ b/parse.icl
@@ -17,7 +17,7 @@ import ast
 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
 (<:>) l r = (\xs->[l:xs]) <$> r
 
-:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
+:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
 derive gEq Token
 lex :: [Char] -> Either [String] [Token]
 lex [] = pure []
@@ -35,22 +35,24 @@ lex [t:ts]
 	| isDigit t
 		# (i, ts) = span isDigit [t:ts]
 		= TTInt (toInt (toString i)) <:> lex ts
-	| isIdent t
-		# (i, ts) = span isIdent [t:ts]
+	| isAlpha t
+		# (i, ts) = span isAlpha [t:ts]
+		= TTIdent i <:> lex ts
+	| isOp t
+		# (i, ts) = span isOp [t:ts]
 		| i =: ['='] = TTEq <:> lex ts
 		| i =: ['.'] = TTDot <:> lex ts
 		| i =: ['\\'] = TTLambda <:> lex ts
-		= TTIdent i <:> lex ts
+		= TTOp i <:> lex ts
 	= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
 where
-	isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
+	isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
 
 :: Parser a :== StateT ParseState (Either [String]) a
 :: ParseState =
 	{ tokens :: [Token]
-	, ifxs :: [((Parser Expression) -> Parser Expression, Int)]
+	, ifxs   :: [((Parser Expression) -> Parser Expression, Int)]
 	}
-instance zero ParseState where zero = {tokens=[],ifxs=[]}
 
 pTop :: Parser Token
 pTop = getState >>= \s->case s.tokens of
@@ -62,11 +64,11 @@ pEof = getState >>= \s->case s.tokens of
 	[] = pure ()
 	[t:ts] = liftT (Left ["Expected EOF"])
 
-pSatisfy :: (Token -> Bool) -> Parser Token
-pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
+(?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
+(?) p f = p >>= \v->if (f v) (pure v) empty
 
 pToken :: (Token -> Parser Token)
-pToken = pSatisfy o (===)
+pToken = (?) pTop o (===)
 
 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
@@ -75,16 +77,14 @@ pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
 
 parse :: [Token] -> Either [String] [Function]
-parse ts = case runStateT (pAST <* pEof) {zero & tokens=ts} of
-	Right (a, _) = Right a
-	Left e = Left e
+parse ts = fst <$> runStateT (pAST <* pEof) {tokens=ts, ifxs=[]}
 where
 	pAST :: Parser [Function]
 	pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
-		modify (\t->{t&tokens=body}) <*> pExpression <* pEof
+		modify (\t->{t & tokens=body}) <*> pExpression <* pEof
 
-	pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
-	pCId a = pId >>= \b->if (a == b) (pure a) empty
+	pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
+	pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
 
 	pFunction :: Parser ([Char], [[Char]], [Token])
 	pFunction
@@ -92,21 +92,22 @@ where
 		<$> (pFunId <|> pId)
 		<*> many pId
 		<*  pToken TTEq
-		<*> many (pSatisfy ((=!=)TTSemiColon))
+		<*> many (pTop ? ((=!=)TTSemiColon))
 		<*  pToken TTSemiColon
 	
 	pFunId :: Parser [Char]
-	pFunId = pId
-		>>= \i->pChainr <$ pCId ['ifxr'] <|> pChainl <$ pCId ['ifxl']
-		>>= \p->(\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
-		>>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pCId i), s):t.ifxs]})
+	pFunId = pOp
+		>>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
+		>>= \p->(\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+		>>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
 		>>| pure i
 
 	pExpression :: Parser Expression
 	pExpression = getState >>= \{ifxs}->flip (foldr ($))
-			[pChainl (pure App):map fst $ sortBy (on (<) snd) ifxs]
+			(map fst $ sortBy (on (<) snd) ifxs)
+		$   pChainl (pure App)
 		$   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
 		<|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
-		<|> Lit o Int <$> (\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
-		<|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
+		<|> Lit o Int <$> (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+		<|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
 		<|> Var <$> pId
diff --git a/tests/preamble.mfp b/tests/preamble.mfp
index d89ffff..be7ee13 100644
--- a/tests/preamble.mfp
+++ b/tests/preamble.mfp
@@ -4,4 +4,5 @@ $ ifxr 0 x y = x y;
 * ifxl 7 x y = mul x y;
 - ifxl 6 x y = sub x y;
 + ifxl 6 x y = add x y;
-start = 3 - 2 - 1;
+fac i = if (i == 0) 1 (i * fac (i - 1));
+start = fac 5;