From bf0a8cdfbb4374263553259d2c1bf92508feb760 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Sun, 8 Jul 2018 13:59:54 +0200
Subject: [PATCH] parser, succinct

---
 parse.icl | 31 +++++++++++++++++--------------
 1 file changed, 17 insertions(+), 14 deletions(-)

diff --git a/parse.icl b/parse.icl
index 521b355..17524d1 100644
--- a/parse.icl
+++ b/parse.icl
@@ -36,7 +36,8 @@ where
 	lex` [c:cs]
 		| isSpace c = lex` cs
 	lex` [';':cs] = [SemiColonToken:lex` cs]
-	lex` ['=':cs] = [EqualsToken:lex` cs]
+	lex` ['=',c:cs]
+		| not (isIdent c) = [EqualsToken:lex` [c:cs]]
 	lex` ['(':cs] = [OpenBraceToken:lex` cs]
 	lex` [')':cs] = [CloseBraceToken:lex` cs]
 	lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs]
@@ -56,8 +57,8 @@ where
 		| isIdent c
 			# (i, cs) = span (\c->isIdent c || isDigit c) cs
 			= [IdentToken $ toString [c:i]:lex` cs]
-	where
-		isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`=']
+
+isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`=']
 
 :: ParseState =
 	{ tokens   :: [Token]
@@ -82,8 +83,7 @@ top = getState >>= \st=:{tokens}->case tokens of
 parseIf :: (a -> Bool) (Parser a) -> Parser a
 parseIf pred p = p >>= \a->if (pred a) (pure a) empty
 
-satisfy p :== parseIf p top
-token t :== satisfy ((=+?=)t)
+token t :== parseIf ((=+?=)t) top
 
 (until) infix 5 :: (Parser a) (Parser b) -> Parser ([a], b)
 (until) p grd = (tuple [] <$> grd) <|> (appFst o 'SS'._cons <$> p <*> p until grd)
@@ -99,21 +99,24 @@ where
 		Function s a <$> evalStateT parseExpr {ps & tokens=ts}
 	pfun x = pure x
 
+cons x xs = [x:xs]
+
 parseExpr :: Parser Expression
-parseExpr = gets (\s->sort s.infixers) >>= foldr ($) parseApp o map op2parser
+parseExpr = gets (\s->sort s.infixers)
+	>>= flip seq parseBasic o cons parseApp o reverse o map op2parser
 where
 	op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP
 		(\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent)
 
-	parseApp = parseLOP (const o Apply) (pure ()) parseBasic
+	parseApp = parseLOP (const o Apply) (pure ())
 
-	parseLOP comb ops prev = prev
-		>>= \e1->many (tuple <$> ops <*> prev)
-		>>=      foldM (\e->pure o uncurry (comb e)) e1
+	parseLOP :: (a b a -> a) (c b) (c a) -> c a | Alternative c
+	parseLOP comb ops prev = foldl (uncurry o comb)
+		<$> prev <*> many (tuple <$> ops <*> prev)
 
-	parseROP comb ops prev = prev
-		>>= \e1->optional (tuple <$> ops <*> parseROP comb ops prev)
-		>>=      pure o maybe e1 (\(op,e2)->comb e1 op e2)//uncurry (comb e1))
+	parseROP :: (a b a -> a) (c b) (c a) -> c a | Monad c & Alternative c
+	parseROP comb ops prev = prev >>= \e1->
+		comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1
 
 	parseBasic
 		=   (token OpenBraceToken *> parseExpr <* token CloseBraceToken)
@@ -142,4 +145,4 @@ parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "")
 parseInt :: Parser Int
 parseInt = (\(IntToken i)->i) <$> token (IntToken 0)
 
-Start = toString <$> parse (lex ['$ infixr 0 a b = -42; ap a b = a $ b $ c; ap a b = a b c;']) zero
+Start = toString <$> parse (lex ['+ infixr 6 a b = 0; * infixr 7 a b = 0; ap = a + b * c + d;']) zero
-- 
2.20.1