add infix and preamble

diff --git a/ast.dcl b/ast.dcl
index 510434c..a24b2df 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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