content: {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
  
  module NanoParsec where
  
  import Data.Char
  import Control.Monad
  import Control.Applicative
  
  newtype Parser a = Parser { parse :: String -> [(a,String)] }
  
  runParser :: Parser a -> String -> a
  runParser m s =
    case parse m s of
      [(res, [])] -> res
      [(_, _)]   -> error "Parser did not consume entire stream."
      _           -> error "Parser error."
  
  item :: Parser Char
  item = Parser $ \s ->
    case s of
     []     -> []
     (c:cs) -> [(c,cs)]
  
  bind :: Parser a -> (a -> Parser b) -> Parser b
  bind p f = Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s
  
  unit :: a -> Parser a
  unit a = Parser (\s -> [(a,s)])
  
  instance Functor Parser where
    fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s])
  
  instance Applicative Parser where
    pure = return
    (Parser cs1) <*> (Parser cs2) = Parser (\s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1])
  
  instance Monad Parser where
    return = unit
    (>>=)  = bind
  
  instance MonadPlus Parser where
    mzero = failure
    mplus = combine
  
  instance Alternative Parser where
    empty = mzero
    (<|>) = option
  
  combine :: Parser a -> Parser a -> Parser a
  combine p q = Parser (\s -> parse p s ++ parse q s)
  
  failure :: Parser a
  failure = Parser (\cs -> [])
  
  option :: Parser a -> Parser a -> Parser a
  option  p q = Parser $ \s ->
    case parse p s of
      []     -> parse q s
      res    -> res
  
  satisfy :: (Char -> Bool) -> Parser Char
  satisfy p = item `bind` \c ->
    if p c
    then unit c
    else failure
  
  -------------------------------------------------------------------------------
  -- Combinators
  -------------------------------------------------------------------------------
  
  oneOf :: [Char] -> Parser Char
  oneOf s = satisfy (flip elem s)
  
  chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
  chainl p op a = (p `chainl1` op) <|> return a
  
  chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
  p `chainl1` op = do {a <- p; rest a}
    where rest a = (do f <- op
                       b <- p
                       rest (f a b))
                   <|> return a
  
  char :: Char -> Parser Char
  char c = satisfy (c ==)
  
  natural :: Parser Integer
  natural = read <$> some (satisfy isDigit)
  
  string :: String -> Parser String
  string [] = return []
  string (c:cs) = do { char c; string cs; return (c:cs)}
  
  token :: Parser a -> Parser a
  token p = do { a <- p; spaces ; return a}
  
  reserved :: String -> Parser String
  reserved s = token (string s)
  
  spaces :: Parser String
  spaces = many $ oneOf " \n\r"
  
  digit :: Parser Char
  digit = satisfy isDigit
  
  number :: Parser Int
  number = do
    s <- string "-" <|> return []
    cs <- some digit
    return $ read (s ++ cs)
  
  parens :: Parser a -> Parser a
  parens m = do
    reserved "("
    n <- m
    reserved ")"
    return n
  
  -------------------------------------------------------------------------------
  -- Calulator parser
  -------------------------------------------------------------------------------
  
  -- number = [ "-" ] digit { digit }.
  -- digit = "0" | "1" | ... | "8" | "9".
  -- expr = term { addop term }.
  -- term = factor { mulop factor }.
  -- factor = "(" expr ")" | number.
  -- addop = "+" | "-".
  -- mulop = "*".
  
  data Expr
    = Add Expr Expr
    | Mul Expr Expr
    | Sub Expr Expr
    | Lit Int
    deriving Show
  
  eval :: Expr -> Int
  eval ex = case ex of
    Add a b -> eval a + eval b
    Mul a b -> eval a * eval b
    Sub a b -> eval a - eval b
    Lit n   -> n
  
  int :: Parser Expr
  int = do
    n <- number
    return (Lit n)
  
  expr :: Parser Expr
  expr = term `chainl1` addop
  
  term :: Parser Expr
  term = factor `chainl1` mulop
  
  factor :: Parser Expr
  factor =
        int
    <|> parens expr
  
  infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
  infixOp x f = reserved x >> return f
  
  addop :: Parser (Expr -> Expr -> Expr)
  addop = (infixOp "+" Add) <|> (infixOp "-" Sub)
  
  mulop :: Parser (Expr -> Expr -> Expr)
  mulop = infixOp "*" Mul
  
  run :: String -> Expr
  run = runParser expr
  
  main :: IO ()
  main = forever $ do
    putStr "> "
    a <- getLine
    print $ eval $ run a
  