1 implementation module parse
3 import Control.Applicative
5 import Control.Monad.State
6 import Control.Monad.Trans
16 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
17 (<:>) l r = (\xs->[l:xs]) <$> r
19 :: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
21 lex :: [Char] -> Either [String] [Token]
23 lex ['=':ts] = TTEq <:> lex ts
24 lex [';':ts] = TTSemiColon <:> lex ts
25 lex ['\\':ts] = TTLambda <:> lex ts
26 lex ['.':ts] = TTDot <:> lex ts
27 lex [')':ts] = TTBrackClose <:> lex ts
28 lex ['(':ts] = TTBrackOpen <:> lex ts
29 lex ['True':ts] = TTBool True <:> lex ts
30 lex ['False':ts] = TTBool False <:> lex ts
32 | isDigit t = lex [t:ts] >>= \v->case v of
33 [TTInt i:rest] = Right [TTInt (~i):rest]
38 # (i, ts) = span isDigit [t:ts]
39 = TTInt (toInt (toString i)) <:> lex ts
41 # (i, ts) = span isIdent [t:ts]
42 = TTIdent i <:> lex ts
43 = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
45 isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
47 :: Parser a :== StateT ParseState (Either [String]) a
50 , infixs :: [(Bool, [Char], Int)]
52 instance zero ParseState where zero = {tokens=[],infixs=[]}
55 pTop = getState >>= \s->case s.tokens of
56 [t:ts] = put {s & tokens=ts} >>| pure t
57 [] = liftT (Left ["Fully consumed input"])
59 pSatisfy :: (Token -> Bool) -> Parser Token
60 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
62 pToken :: (Token -> Parser Token)
63 pToken = pSatisfy o (===)
65 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
66 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
68 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
69 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
71 parse :: [Token] -> Either [String] AST
72 parse ts = case runStateT pAST {zero & tokens=ts} of
73 Right (a, {tokens=[]}) = Right a
74 Right (a, _) = Left ["No complete parse result"]
78 pAST = AST <$> many pFunction
80 pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
81 pOp t` = pId >>= \t->if (t == t`) (pure t) empty
83 pFunction :: Parser Function
92 pExpression :: Parser Expression
93 pExpression = getState >>= \{infixs}->foldr ($) pBasic
95 : [ if ifxr pChainr pChainl $ App o App (Var op) <$ pOp op
96 \\(ifxr, op, _)<-infixs]]
98 pBasic :: Parser Expression
100 = Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
101 <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
102 <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
103 <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
104 <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))