derive consName Token, Value
:: Expression | DelayedParse [Token]
-
:: Token
= IntToken Int | BoolToken Bool | CharToken Char | IdentToken String
| InfixrToken | InfixlToken | SemiColonToken | OpenBraceToken
- | CloseBraceToken | EqualsToken
+ | CloseBraceToken | EqualsToken | CodeToken | LambdaToken
+ | 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` ['=':cs] = [EqualsToken:lex` cs]
- lex` ['(':cs] = [OpenBraceToken:lex` cs]
- lex` [')':cs] = [CloseBraceToken:lex` cs]
- lex` ['\'',c,'\'':cs] = [CharToken c:lex` cs]
- lex` ['T','r','u','e':cs] = [BoolToken True: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
| isIdent c
# (i, cs) = span (\c->isIdent c || isDigit c) cs
= [IdentToken $ toString [c:i]:lex` cs]
- where
- isIdent c = isAlpha c || isMember c ['!@#$%^&*\|+?/_-\'<>.:~`=']
-
-:: ParseState =
- { tokens :: [Token]
- , infixers :: [Infix]
- }
-:: Infix = Infix String Fixity Int
-instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
-:: Fixity = InfixL | InfixR
+ | 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)
-:: Parser a :== StateT ParseState (Either [String]) a
+whiteOrEnd [] = True
+whiteOrEnd [c:cs] = isSpace c
-instance zero ParseState where zero = {tokens=[],infixers=[]}
+isIdent c = isAlpha c || elem c ['\'`']
+isFunny = flip elem ['!@#$%^&*\|+-?/\'<>.:~=']
(<?>) 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
parseIf :: (a -> Bool) (Parser a) -> Parser a
parseIf pred p = p >>= \a->if (pred a) (pure a) empty
-satisfy p :== parseIf p top
-token t :== satisfy ((=+?=)t)
+token t :== parseIf ((=+?=)t) top
(until) infix 5 :: (Parser a) (Parser b) -> Parser ([a], b)
(until) p grd = (tuple [] <$> grd) <|> (appFst o 'SS'._cons <$> p <*> p until grd)
-parse :: [Token] ParseState -> Either [String] AST
-parse ts st = runStateT parseAST {st & tokens=ts} >>= uncurry parse2
+parse :: ParseState [Token] -> Either [String] AST
+parse st ts = runStateT parseAST {st & tokens=ts} >>= uncurry parse2
parse2 :: AST ParseState -> Either [String] AST
parse2 (AST fs) ps = AST <$> mapM pfun fs
Function s a <$> evalStateT parseExpr {ps & tokens=ts}
pfun x = pure x
+cons x xs = [x:xs]
+
parseExpr :: Parser Expression
-parseExpr = gets (\s->sort s.infixers) >>= foldr ($) parseApp o map op2parser
+parseExpr = gets (\s->sort s.infixers)
+ >>= 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 = parseLOP (const o Apply) (pure ()) parseBasic
+ parseApp :: ((Parser Expression) -> Parser Expression)
+ parseApp = parseLOP (const o Apply) (pure ())
- parseLOP comb ops prev = prev
- >>= \e1->many (tuple <$> ops <*> prev)
- >>= foldM (\e->pure o uncurry (comb e)) e1
+ 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)
- parseROP comb ops prev = prev
- >>= \e1->optional (tuple <$> ops <*> parseROP comb ops prev)
- >>= pure o maybe e1 (\(op,e2)->comb e1 op e2)//uncurry (comb e1))
+ 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
+ parseBasic :: Parser Expression
parseBasic
- = (token OpenBraceToken *> parseExpr <* token CloseBraceToken)
+ //Bracketed
+ = token OpenBraceToken *> parseBracketed <* token CloseBraceToken
+ <|> Let <$> (token LetToken *> parseIdent <* token EqualsToken) <*> (parseExpr <* token InToken) <*> parseExpr
<|> 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
+ = (\op->Lambda "_v" o Apply (Apply op (Variable "v"))) <$> parseIfx <*> parseExpr
+ //Regular Prefix infix
+ <|> parseIfx
+ //Curried flipped prefix infix
+ <|> (\e op->Lambda "_v" (Apply (Apply op e) (Variable "v"))) <$> parseExpr <*> parseIfx
+ //Parse regular expression
+ <|> parseExpr
+
+ 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
parseInt :: Parser Int
parseInt = (\(IntToken i)->i) <$> token (IntToken 0)
-
-Start = toString <$> parse (lex ['$ infixr 0 a b = -42; ap a b = a $ b $ c; ap a b = a b c;']) zero
repositories / fp.git / blobdiff