prepare for infix

[minfp.git] / parse.icl

diff --git a/parse.icl b/parse.icl
index 355e136..c99f600 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -2,19 +2,22 @@ implementation module parse
 
 import Control.Applicative
 import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
 import Data.Either
+import Data.GenEq
 import Data.Functor
 import Data.Func
+import Data.List
 import StdEnv
-import Text.Parsers.Simple.ParserCombinators => qualified parse
 
 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 | TTChar Char | TTInt Int | TTIdent [Char]
-
+:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
+derive gEq Token
 lex :: [Char] -> Either [String] [Token]
 lex [] = pure []
 lex ['=':ts] = TTEq <:> lex ts
@@ -25,7 +28,6 @@ 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
                [TTInt i:rest] = Right [TTInt (~i):rest]
@@ -35,30 +37,69 @@ lex [t:ts]
        | isDigit t
                # (i, ts) = span isDigit [t:ts]
                = TTInt (toInt (toString i)) <:> lex ts
-       | isAlpha t
-               # (i, ts) = span isAlpha [t:ts]
+       | isIdent t
+               # (i, ts) = span isIdent [t:ts]
                = TTIdent i <:> lex ts
        = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
+where
+       isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
+
+:: Parser a :== StateT ParseState (Either [String]) a
+:: ParseState =
+       { tokens :: [Token]
+       , infixs :: [(Bool, [Char], Int)]
+       }
+instance zero ParseState where zero = {tokens=[],infixs=[]}
+
+pTop :: Parser Token
+pTop = getState >>= \s->case s.tokens of
+       [t:ts] = put {s & tokens=ts} >>| pure t
+       [] = liftT (Left ["Fully consumed input"])
+
+pSatisfy :: (Token -> Bool) -> Parser Token
+pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
 
-parse :: ([Token] -> Either [String] AST)
-parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
+pToken :: (Token -> Parser Token)
+pToken = pSatisfy o (===)
+
+pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
+pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
+
+pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
+pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
+
+parse :: [Token] -> Either [String] AST
+parse ts = case runStateT pAST {zero & tokens=ts} of
+       Right (a, {tokens=[]}) = Right a
+       Right (a, _) = Left ["No complete parse result"]
+       Left e = Left e
 where
+       pAST :: Parser AST
+       pAST = AST <$> many pFunction
+
        pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
+       pOp t` = pId >>= \t->if (t == t`) (pure t) empty
 
-       pFunction :: Parser Token Function
+       pFunction :: Parser Function
        pFunction
                =   Function
                <$> pId
                <*> many pId
-               <*  pSatisfy (\t->t=:TTEq)
+               <*  pToken TTEq
                <*> pExpression
-               <*  pSatisfy (\t->t=:TTSemiColon)
+               <*  pToken TTSemiColon
+
+       pExpression :: Parser Expression
+       pExpression = getState >>= \{infixs}->foldr ($) pBasic
+               [ pChainl (pure App)
+               : [ if ifxr pChainr pChainl $ App o App (Var op) <$ pOp op
+                 \\(ifxr, op, _)<-infixs]]
 
-       pExpression :: Parser Token Expression
-       pExpression = flip pChainl1 (pure App) $
-                    (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)
+       pBasic :: Parser Expression
+       pBasic
+               =   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
+               <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
+               <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
+               <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
+               <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
+               <|> Var <$> pId