infix operators

diff --git a/parse.icl b/parse.icl
index c99f600..1a99e90 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -9,6 +9,7 @@ import Data.GenEq
 import Data.Functor
 import Data.Func
 import Data.List
+import Data.Tuple
 import StdEnv
 
 import ast
@@ -47,15 +48,20 @@ where
 :: Parser a :== StateT ParseState (Either [String]) a
 :: ParseState =
        { tokens :: [Token]
-       , infixs :: [(Bool, [Char], Int)]
+       , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
        }
-instance zero ParseState where zero = {tokens=[],infixs=[]}
+instance zero ParseState where zero = {tokens=[],ifxs=[]}
 
 pTop :: Parser Token
 pTop = getState >>= \s->case s.tokens of
        [t:ts] = put {s & tokens=ts} >>| pure t
        [] = liftT (Left ["Fully consumed input"])
 
+pEof :: Parser ()
+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
 
@@ -69,37 +75,38 @@ 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"]
+parse ts = case runStateT (AST<$> pAST <* pEof) {zero & tokens=ts} of
+       Right (a, _) = Right a
        Left e = Left e
 where
-       pAST :: Parser AST
-       pAST = AST <$> many pFunction
+       pAST :: Parser [Function]
+       pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
+               modify (\t->{t&tokens=body}) <*> pExpression <* pEof
 
        pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
-       pOp t` = pId >>= \t->if (t == t`) (pure t) empty
+       pCId a = pId >>= \b->if (a == b) (pure a) empty
 
-       pFunction :: Parser Function
+       pFunction :: Parser ([Char], [[Char]], [Token])
        pFunction
-               =   Function
-               <$> pId
+               =   tuple3
+               <$> (pFunId <|> pId)
                <*> many pId
                <*  pToken TTEq
-               <*> pExpression
+               <*> many (pSatisfy ((=!=)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]})
+               >>| pure i
 
        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]]
-
-       pBasic :: Parser Expression
-       pBasic
-               =   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
+       pExpression = getState >>= \{ifxs}->flip (foldr ($))
+                       [pChainl (pure App):map fst $ sortBy (on (<) snd) ifxs]
+               $   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 _))
+               <|> Lit o Int <$> (\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
                <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
                <|> Var <$> pId