9 import Control.Applicative
12 :: Parser m a = Parser (ParseState -> m (a, ParseState))
15 , infixers :: [Infixer]
17 :: Infixer = Infxer Bool Int [Char]
19 runParser :: (Parser m a) -> (ParseState -> m (a, ParseState))
20 runParser (Parser a) = a
22 instance Functor (Parser m) | Monad m where fmap a b = liftM a b
23 instance pure (Parser m) | Monad m where pure a = Parser (pure o tuple a)
24 instance <*> (Parser m) | Monad m where (<*>) a b = ap a b
25 instance <* (Parser m) | Monad m
26 instance *> (Parser m) | Monad m
27 instance Monad (Parser m) | Monad m where
28 bind ma a2mb = Parser \c->runParser ma c >>= uncurry (runParser o a2mb)
29 instance Alternative (Parser m) | Alternative m where
30 empty = Parser (pure empty)
31 (<|>) l r = Parser \c->runParser l c <|> runParser r c
33 get :: Parser m ParseState | Alternative, Monad m
34 get = Parser \c->pure (c, c)
36 set :: ParseState -> Parser m () | Alternative, Monad m
37 set c = Parser \_->pure ((), c)
39 upd :: (ParseState -> ParseState) -> Parser m () | Alternative, Monad m
40 upd f = f <$> get >>= set
42 pTop :: Parser m Char | Alternative, Monad m
43 pTop = get >>= \c->case c.tokens of
45 [t:ts] = set {c & tokens=ts} *> pure t
47 pSatisfy :: (Char -> Bool) -> Parser m Char | Alternative, Monad m
48 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
50 pToken :: Char -> Parser m Char | Alternative, Monad m
51 pToken c = pSatisfy ((==)c)
54 (<:>) l r :== (\x xs->[x:xs]) <$> l <*> r
56 pTokens :: [Char] -> Parser m [Char] | Alternative, Monad m
57 pTokens ts = foldr (<:>) (pure []) (map pToken ts)
59 pChainL :: (Parser m (a a -> a)) (Parser m a) -> Parser m a | Alternative, Monad m
60 pChainL op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
62 :: Program :== [([Char], Expr)]
66 | BinOp [Char] Expr Expr
68 pProgram :: Parser m Program | Alternative, Monad m
71 pDecl :: Parser m ([Char], Expr) | Alternative, Monad m
72 pDecl = tuple <$> many (pSatisfy isAlpha) <* pToken '=' <*> pExpr <* pToken '\n'
74 pInfixer :: Parser m Program | Alternative, Monad m
75 pInfixer = Infxer o (==) 'r' <$ pTokens ['ifx'] <*> (pToken 'r' <|> pToken 'l') <*> pLit <*> many (pSatisfy isOpChar)
78 pExpr :: Parser m Expr | Alternative, Monad m
79 pExpr = pChainL (BinOp <$> pTokens ['+']) $
81 <|> Var <$> many (pSatisfy isAlpha)
82 <|> pToken '(' *> pExpr <* pToken ')'
84 pLit :: Parser m Int | Alternative, Monad m
85 pLit = ((~) <$ pToken '-' <|> pure id) <*>
86 (toInt <$> toString <$> some (pSatisfy isDigit))
88 isOpChar :: Char -> Bool
89 isOpChar c = isMember c ['-+*/%@#$^&=|\'']
91 printProgram :: [([Char], Expr)] -> String
92 printProgram p = foldr (+++) ""
93 [toString c +++ "=" +++ printExpr e\\(c, e)<-p]
95 printExpr :: Expr -> String
96 printExpr (Var i) = toString i
97 printExpr (Lit i) = toString i
98 printExpr (BinOp o l r) = "(" +++ printExpr l +++ toString o +++ printExpr r +++ ")"
100 Start :: Maybe (String, ParseState)
101 Start = appFst printProgram <$> runParser pProgram {tokens=['y=x+4\n'],infixers=[]}