From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 1 Mar 2019 08:40:22 +0000 (+0100)
Subject: infix operators
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=475f52ac2129d11252ed627cea84fd7e815e2286;p=minfp.git

infix operators
---

diff --git a/parse.icl b/parse.icl
index c99f600..1a99e90 100644
--- 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