infer

[fp.git] / parse.icl

diff --git a/parse.icl b/parse.icl
index e5927bd..4359629 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -22,33 +22,39 @@ import Data.Tuple
 derive consName Token, Value
 
 :: Expression | DelayedParse [Token]
-
 :: Token
        = IntToken Int    | BoolToken Bool | CharToken Char | IdentToken String
        | InfixrToken     | InfixlToken    | SemiColonToken | OpenBraceToken
        | CloseBraceToken | EqualsToken    | CodeToken      | LambdaToken
-       | ArrowToken
+       | ArrowToken      | LetToken       | InToken
+:: ParseState = {tokens :: [Token], infixers :: [Infix]}
+:: Infix = Infix String Fixity Int
+:: Fixity = InfixL | InfixR
+:: Parser a :== StateT ParseState (Either [String]) a
+
+instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
+instance zero ParseState where zero = {tokens=[],infixers=[]}
 
 lex :: [Char] -> [Token]
 lex cs = lex` cs
 where
-       lex` [] = []
-       lex` ['\n':cs] = lex` cs
-       lex` [c:cs]
-               | isSpace c = lex` cs
-       lex` [';':cs] = [SemiColonToken:lex` cs]
-       lex` ['=',c:cs]
-               | 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]
+       lex` []                            = []
+       lex` ['\n':cs]                     = lex` cs
+       lex` [c:cs] | isSpace c            = lex` cs
+       lex` [';':cs]                      = [SemiColonToken:lex` cs]
+       lex` ['=',c:cs] | 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` ['let':cs]    | whiteOrEnd cs = [LetToken:lex` cs]
+       lex` ['in':cs]     | whiteOrEnd cs = [InToken:lex` cs]
+       lex` ['code':cs]   | whiteOrEnd cs = [CodeToken:lex` cs]
+       lex` ['False':cs]  | whiteOrEnd cs = [BoolToken True:lex` cs]
+       lex` ['True':cs]   | whiteOrEnd cs = [BoolToken True:lex` cs]
+       lex` ['infixr':cs] | whiteOrEnd cs = [InfixrToken:lex` cs]
+       lex` ['infixl':cs] | whiteOrEnd cs = [InfixlToken:lex` cs]
        lex` ['-',c:cs]
                | isDigit c
                        = case lex` [c:cs] of
@@ -66,21 +72,12 @@ where
                        = [IdentToken $ toString [c:i]:lex` cs]
                = abort $ "Huh lexer failed on: " +++ toString (toInt c)
 
+whiteOrEnd [] = True
+whiteOrEnd [c:cs] = isSpace c
+
 isIdent c = isAlpha c || elem c ['\'`']
 isFunny = flip elem ['!@#$%^&*\|+-?/\'<>.:~=']
 
-:: ParseState =
-       { tokens   :: [Token]
-       , infixers :: [Infix]
-       }
-:: Infix = Infix String Fixity Int
-instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
-:: Fixity = InfixL | InfixR
-
-:: Parser a :== StateT ParseState (Either [String]) a
-
-instance zero ParseState where zero = {tokens=[],infixers=[]}
-
 (<?>) infixl 1 :: a (StateT b (Either (c a)) d) -> StateT b (Either (c a)) d | Semigroup (c a) & Applicative c
 (<?>) err p = StateT $ first (flip mappend (pure err)) o runStateT p
 
@@ -131,6 +128,7 @@ where
        parseBasic
                //Bracketed
                =   token OpenBraceToken *> parseBracketed <* token CloseBraceToken
+               <|> Let <$> (token LetToken *> parseIdent <* token EqualsToken) <*> (parseExpr <* token InToken) <*> parseExpr
                <|> Literal <$> Int <$> parseInt
                <|> Code <$> (token CodeToken *> parseIdent)
                <|> flip (foldr Lambda) <$> (token LambdaToken *> some parseIdent <* token ArrowToken) <*> parseExpr
@@ -139,17 +137,14 @@ where
        parseBracketed :: Parser Expression
        parseBracketed
                //Curried prefix infix
-               = (\e op->Apply (Apply fpflip op) e) <$> parseIfx <*> parseExpr
+               = (\op->Lambda "_v" o Apply (Apply op (Variable "v"))) <$> parseIfx <*> parseExpr
                //Regular Prefix infix
                <|> parseIfx
                //Curried flipped prefix infix
-               <|> Apply <$> parseExpr <*> parseIfx
+               <|> (\e op->Lambda "_v" (Apply (Apply op e) (Variable "v"))) <$> 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
 
@@ -183,6 +178,8 @@ Start =
        ['id x = x;'] ++
        ['const x y = x;'] ++
        ['flip x y z = x z y;'] ++
+       ['twice f = f . f;'] ++
+       ['fix f x = let x = f x in x;'] ++
        ['. infixr 9 f g x = f $ g x;'] ++
        ['$ infixr 0 = id;'] ++
        ['& infixr 0 = flip $;'] ++
@@ -192,5 +189,6 @@ Start =
        ['/ infixr 7 = code div;'] ++
        ['&& infixl 3 = code and;'] ++
        ['|| infixl 2 = code or;'] ++
-       ['ap = f . g $ x;']
+       ['ap = (1 +);'] ++
+       ['ap = (+ 1);']
        ) zero