parser, succinct

diff --git a/parse.icl b/parse.icl
index 521b355..17524d1 100644 (file)
--- 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