parsing cleaner

[minfp.git] / parse.icl

diff --git a/parse.icl b/parse.icl
index c35f78a..99f0246 100644 (file)
--- 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