1 implementation module parse
3 import Control.Applicative
5 import Control.Monad.State
6 import Control.Monad.Trans
20 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
21 (<:>) l r = cons l <$> r
23 :: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int
24 | TTOp [Char] | TTIdent [Char]
29 instance toString Token where toString t = printToString t
31 lex :: [Char] -> Either [String] [Token]
33 lex ['//\n':ts] = lex ts
34 lex ['//',t:ts] = lex ['/','/':ts]
35 lex ['/**/':ts] = lex $ dropWhile ((<>)'\n') ts
36 lex ['/*',t:ts] = lex ['/','*':ts]
37 lex [';':ts] = TTSemiColon <:> lex ts
38 lex [')':ts] = TTBrackClose <:> lex ts
39 lex ['(':ts] = TTBrackOpen <:> lex ts
40 lex ['True':ts] = TTBool True <:> lex ts
41 lex ['False':ts] = TTBool False <:> lex ts
43 | isDigit t = lex [t:ts] >>= \v->case v of
44 [TTInt i:rest] = Right [TTInt (~i):rest]
49 # (d, ts) = span isDigit [t:ts]
50 = TTInt (toInt (toString d)) <:> lex ts
52 # (d, ts) = span isAlpha [t:ts]
53 = TTIdent d <:> lex ts
55 # (d, ts) = span isOp [t:ts]
57 = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
59 isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
61 :: Parser a :== StateT ParseState (Either [String]) a
64 , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
68 pTop = getState >>= \s->case s.tokens of
69 [t:ts] = put {s & tokens=ts} >>| pure t
70 [] = liftT (Left ["Fully consumed input"])
73 pEof = getState >>= \s->case s.tokens of
75 [t:ts] = liftT (Left ["Expected EOF but got ":map toString [t:ts]])
77 (?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
78 (?) p f = p >>= \v->if (f v) (pure v) empty
80 pToken :: (Token -> Parser Token)
81 pToken = (?) pTop o (===)
83 pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
84 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
86 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
87 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
89 parse :: [Token] -> Either [String] [Either TypeDef Function]
90 parse ts = fst <$> runStateT (reverse <$> pAST <* pEof) {tokens=ts, ifxs=[]}
92 pAST :: Parser [Either TypeDef Function]
93 pAST = many (Right <$> pFunction <|> Left <$> pTypeDef)
94 >>= mapM (either (pure o Left) \(id, args, body)->Right o
95 Function id args <$ modify (\t->{t & tokens=body}) <*> pExpression <* pEof)
97 pTypeDef :: Parser TypeDef
99 <$ pToken (TTOp ['::'])
102 <* pToken (TTOp ['='])
103 <*> (cons <$> pCons <*> many (pToken (TTOp ['|']) *> pCons))
104 <* pToken TTSemiColon
106 pCons = tuple <$> pId <*> many pType
109 = TInt <$ pTop ? (\t->t=:(TTIdent ['Int']))
110 <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
114 pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
115 pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
116 pInt = (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
117 pBrack p = pToken TTBrackOpen *> p <* pToken TTBrackClose
119 pFunction :: Parser ([Char], [[Char]], [Token])
124 <* pToken (TTOp ['='])
125 <*> many (pTop ? ((=!=)TTSemiColon))
126 <* pToken TTSemiColon
128 pFunId :: Parser [Char]
130 >>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
132 >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
135 pExpression :: Parser Expression
136 pExpression = getState >>= \{ifxs}->flip (foldr ($))
137 (map fst $ sortBy (on (<) snd) ifxs)
139 $ Lambda <$ pToken (TTOp ['\\']) <*> pId <* pToken (TTOp ['.']) <*> pExpression
140 <|> pBrack ( Tuple <$> pExpression <* pToken (TTOp [',']) <*> pExpression
143 <|> Lit o Int <$> pInt
144 <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
145 <|> (\x->Var ['_':x]) <$ pToken (TTIdent ['code']) <*> pId