Calc.hs

import MParserCore
import Parser
import Data.Char

data Expr = Lit Int | Add Expr Expr | Mul Expr Expr  deriving (Read, Show)
           
expr :: Parser Expr
expr = liftP Add term (char '+' +++ expr) ||| term

term :: Parser Expr
term = do f <- factor
          char '*'
          t <- term
          return (Mul f t)
       ||| factor

factor :: Parser Expr
factor = mapP Lit nat
         ||| char '(' +++ expr ++> \e -> char ')' +++ yield e

nat :: Parser Int
nat = mapP (foldl (\n d -> 10 * n + d) 0) (many1 (mapP digitToInt digit))

eval :: Expr -> Int
eval (Lit n)     = n
eval (Add e1 e2) = eval e1 + eval e2
eval (Mul e1 e2) = eval e1 * eval e2

calc :: String -> Int
calc s = eval (parse expr s)

MParserCore.hs

module MParserCore (Parser, parse, item, (|||), failure, (++>), yield) where

import qualified ParserCore
import Control.Applicative

newtype Parser a = P {unP :: ParserCore.Parser a}

parse :: Parser a -> String -> a
parse = ParserCore.parse . unP

item :: Parser Char
item = P ParserCore.item

infixr 3 |||

(|||) :: Parser a -> Parser a -> Parser a
(P p) ||| (P q) = P (p ParserCore.||| q)

failure :: Parser a
failure = P ParserCore.failure

infixr 4 ++>

(++>) :: Parser a -> (a -> Parser b) -> Parser b
(P p) ++> f = P (p ParserCore.++> (unP . f))

yield :: a -> Parser a
yield = P . ParserCore.yield

instance Functor Parser where
  fmap f p = p ++> \x -> yield (f x)

instance Applicative Parser where
  pure = yield
  p <*> q = p ++> \x -> fmap x q

instance Monad Parser where
  return = yield
  (>>=)  = (++>)
  fail _ = failure

Parser.hs

module Parser where

import MParserCore
import Data.Char

mapP :: (a -> b) -> Parser a -> Parser b
mapP = fmap

liftP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
liftP f p q = p ++> \x -> q ++> \y -> yield (f x y) 

infixr 4 +++ 

(+++) :: Parser a -> Parser b -> Parser b
p +++ q = p ++> const q

sat :: (Char -> Bool) -> Parser Char
sat p = item ++> \x -> if p x then yield x else failure

digit :: Parser Char
digit = sat isDigit

lower :: Parser Char
lower = sat isLower

upper :: Parser Char
upper = sat isUpper

letter :: Parser Char
letter = sat isAlpha

alphanum :: Parser Char
alphanum = sat isAlphaNum

char :: Char -> Parser ()
char x = sat (== x) +++ yield ()

many :: Parser a -> Parser [a]
many p = many1 p ||| yield []

many1 :: Parser a -> Parser [a]
many1 p = liftP (:) p (many p)