1 implementation module parse
3 import Control.Applicative
5 import Control.Monad.State
6 import Control.Monad.Trans
17 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
18 (<:>) l r = (\xs->[l:xs]) <$> r
20 :: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
22 lex :: [Char] -> Either [String] [Token]
24 lex [';':ts] = TTSemiColon <:> lex ts
25 lex [')':ts] = TTBrackClose <:> lex ts
26 lex ['(':ts] = TTBrackOpen <:> lex ts
27 lex ['True':ts] = TTBool True <:> lex ts
28 lex ['False':ts] = TTBool False <:> lex ts
30 | isDigit t = lex [t:ts] >>= \v->case v of
31 [TTInt i:rest] = Right [TTInt (~i):rest]
36 # (i, ts) = span isDigit [t:ts]
37 = TTInt (toInt (toString i)) <:> lex ts
39 # (i, ts) = span isIdent [t:ts]
40 | i =: ['='] = TTEq <:> lex ts
41 | i =: ['.'] = TTDot <:> lex ts
42 | i =: ['\\'] = TTLambda <:> lex ts
43 = TTIdent i <:> lex ts
44 = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
46 isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
48 :: Parser a :== StateT ParseState (Either [String]) a
51 , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
53 instance zero ParseState where zero = {tokens=[],ifxs=[]}
56 pTop = getState >>= \s->case s.tokens of
57 [t:ts] = put {s & tokens=ts} >>| pure t
58 [] = liftT (Left ["Fully consumed input"])
61 pEof = getState >>= \s->case s.tokens of
63 [t:ts] = liftT (Left ["Expected EOF"])
65 pSatisfy :: (Token -> Bool) -> Parser Token
66 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
68 pToken :: (Token -> Parser Token)
69 pToken = pSatisfy o (===)
71 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
72 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
74 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
75 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
77 parse :: [Token] -> Either [String] [Function]
78 parse ts = case runStateT (pAST <* pEof) {zero & tokens=ts} of
79 Right (a, _) = Right a
82 pAST :: Parser [Function]
83 pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
84 modify (\t->{t&tokens=body}) <*> pExpression <* pEof
86 pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
87 pCId a = pId >>= \b->if (a == b) (pure a) empty
89 pFunction :: Parser ([Char], [[Char]], [Token])
95 <*> many (pSatisfy ((=!=)TTSemiColon))
98 pFunId :: Parser [Char]
100 >>= \i->pChainr <$ pCId ['ifxr'] <|> pChainl <$ pCId ['ifxl']
101 >>= \p->(\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
102 >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pCId i), s):t.ifxs]})
105 pExpression :: Parser Expression
106 pExpression = getState >>= \{ifxs}->flip (foldr ($))
107 [pChainl (pure App):map fst $ sortBy (on (<) snd) ifxs]
108 $ Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
109 <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
110 <|> Lit o Int <$> (\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
111 <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))