From 571fe71ca22f9cc1b24ef504d202ce44c616047f Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 9 Jul 2018 09:26:37 +0200
Subject: [PATCH] add infix and preamble

---
 ast.dcl   |  2 ++
 ast.icl   |  2 ++
 parse.icl | 72 +++++++++++++++++++++++++++++++++++++++++++++----------
 3 files changed, 64 insertions(+), 12 deletions(-)

diff --git a/ast.dcl b/ast.dcl
index 510434c..a24b2df 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -8,6 +8,8 @@ definition module ast
 	= Literal Value
 	| Variable String
 	| Apply Expression Expression
+	| Lambda String Expression
+	| Code String
 	| ..
 
 :: Value
diff --git a/ast.icl b/ast.icl
index 419c3e9..3f52921 100644
--- a/ast.icl
+++ b/ast.icl
@@ -15,6 +15,8 @@ where
 	pretty (Literal v) = pretty v
 	pretty (Variable v) = string v
 	pretty (Apply a b) = parens (pretty a <+> pretty b)
+	pretty (Lambda a b) = string "\\" <-> string a <-> string "->" <-> pretty b
+	pretty (Code b) = string "code" <+> string b
 
 instance Pretty Function
 where
diff --git a/parse.icl b/parse.icl
index 17524d1..e5927bd 100644
--- a/parse.icl
+++ b/parse.icl
@@ -26,7 +26,8 @@ derive consName Token, Value
 :: Token
 	= IntToken Int    | BoolToken Bool | CharToken Char | IdentToken String
 	| InfixrToken     | InfixlToken    | SemiColonToken | OpenBraceToken
-	| CloseBraceToken | EqualsToken
+	| CloseBraceToken | EqualsToken    | CodeToken      | LambdaToken
+	| ArrowToken
 
 lex :: [Char] -> [Token]
 lex cs = lex` cs
@@ -40,8 +41,11 @@ where
 		| not (isIdent c) = [EqualsToken:lex` [c:cs]]
 	lex` ['(':cs] = [OpenBraceToken:lex` cs]
 	lex` [')':cs] = [CloseBraceToken:lex` cs]
+	lex` ['-','>':cs] = [ArrowToken:lex` cs]
+	lex` ['\\':cs] = [LambdaToken:lex` cs]
 	lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs]
 	lex` ['T','r','u','e':cs] = [BoolToken True:lex` cs]
+	lex` ['c','o','d','e':cs] = [CodeToken:lex` cs]
 	lex` ['F','a','l','s','e':cs] = [BoolToken True:lex` cs]
 	lex` ['i','n','f','i','x','r':cs] = [InfixrToken:lex` cs]
 	lex` ['i','n','f','i','x','l':cs] = [InfixlToken:lex` cs]
@@ -57,8 +61,13 @@ where
 		| isIdent c
 			# (i, cs) = span (\c->isIdent c || isDigit c) cs
 			= [IdentToken $ toString [c:i]:lex` cs]
+		| isFunny c
+			# (i, cs) = span (\c->isFunny c || isDigit c) cs
+			= [IdentToken $ toString [c:i]:lex` cs]
+		= abort $ "Huh lexer failed on: " +++ toString (toInt c)
 
-isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`=']
+isIdent c = isAlpha c || elem c ['\'`']
+isFunny = flip elem ['!@#$%^&*\|+-?/\'<>.:~=']
 
 :: ParseState =
 	{ tokens   :: [Token]
@@ -103,26 +112,49 @@ cons x xs = [x:xs]
 
 parseExpr :: Parser Expression
 parseExpr = gets (\s->sort s.infixers)
-	>>= flip seq parseBasic o cons parseApp o reverse o map op2parser
+	>>= foldr ($) parseBasic o (\x xs->[x:xs]) parseApp o map op2parser
 where
+	op2parser :: Infix -> ((Parser Expression) -> Parser Expression)
 	op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP
-		(\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent)
+		(\l op->Apply (Apply op l)) $ Variable <$> parseIf ((==)sym) parseIdent
 
+	parseApp :: ((Parser Expression) -> Parser Expression)
 	parseApp = parseLOP (const o Apply) (pure ())
 
 	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)
+	parseLOP comb ops prev = foldl (uncurry o comb) <$> prev <*> many (tuple <$> ops <*> prev)
 
 	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
+	parseROP comb ops prev = prev >>= \e1->comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1
 
+	parseBasic :: Parser Expression
 	parseBasic
-		=   (token OpenBraceToken *> parseExpr <* token CloseBraceToken)
+		//Bracketed
+		=   token OpenBraceToken *> parseBracketed <* token CloseBraceToken
 		<|> Literal <$> Int <$> parseInt
-		<|> (gets (\s->[i\\Infix i _ _<-s.infixers])
-			>>= \ifs->Variable <$> parseIf (not o flip elem ifs) parseIdent)
+		<|> Code <$> (token CodeToken *> parseIdent)
+		<|> flip (foldr Lambda) <$> (token LambdaToken *> some parseIdent <* token ArrowToken) <*> parseExpr
+		<|> Variable <$> parseWithIfx ((o) not o flip elem)
+
+	parseBracketed :: Parser Expression
+	parseBracketed
+		//Curried prefix infix
+		= (\e op->Apply (Apply fpflip op) e) <$> parseIfx <*> parseExpr
+		//Regular Prefix infix
+		<|> parseIfx
+		//Curried flipped prefix infix
+		<|> Apply <$> parseExpr <*> parseIfx
+		//Parse regular expression
+		<|> parseExpr
+
+	fpflip :: Expression
+	fpflip = Lambda "x" $ Lambda "y" $ Lambda "z" $ Apply (Apply (Variable "x") (Variable "z")) (Variable "y")
+
+	parseWithIfx :: ([String] String -> Bool) -> Parser String
+	parseWithIfx f = gets (\s->[i\\Infix i _ _<-s.infixers]) >>= flip parseIf parseIdent o f
+
+	parseIfx :: Parser Expression
+	parseIfx = Variable <$> parseWithIfx (flip elem)
 
 parseAST :: Parser AST
 parseAST = AST <$> many parseFunction
@@ -145,4 +177,20 @@ parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "")
 parseInt :: Parser Int
 parseInt = (\(IntToken i)->i) <$> token (IntToken 0)
 
-Start = toString <$> parse (lex ['+ infixr 6 a b = 0; * infixr 7 a b = 0; ap = a + b * c + d;']) zero
+Start =
+	toString <$> parse (
+	lex $
+	['id x = x;'] ++
+	['const x y = x;'] ++
+	['flip x y z = x z y;'] ++
+	['. infixr 9 f g x = f $ g x;'] ++
+	['$ infixr 0 = id;'] ++
+	['& infixr 0 = flip $;'] ++
+	['+ infixr 6 = code add;'] ++
+	['- infixr 6 = code sub;'] ++
+	['* infixr 7 = code mul;'] ++
+	['/ infixr 7 = code div;'] ++
+	['&& infixl 3 = code and;'] ++
+	['|| infixl 2 = code or;'] ++
+	['ap = f . g $ x;']
+	) zero
-- 
2.20.1