Reverse polish parser and interpreter

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}

import Control.Applicative
import Control.Arrow
import Data.Foldable
import Data.Function

-- ======================================================================= --
-- ======================================================================= --
-- ======================== Reverse Polish Parser ======================== --
-- ======================================================================= --
-- ======================================================================= --

data Op = Plus | Times | Minus | Div deriving (Eq, Ord)
data Expr = Number Int | Expr Op Expr Expr deriving (Eq, Ord)
instance Show Op where
    show Plus = "+"
    show Times = "*"
    show Minus = "-"
    show Div = "/"
opParse :: Char -> Op -> Parser Op
opParse c o = char c *> pure o
plus, minus, times, divide, op :: Parser Op
plus   = opParse '+' Plus
minus  = opParse '-' Minus
times  = opParse '*' Times
divide = opParse '/' Div
op = oneOf [plus, minus, times, divide]

polish :: Parser Expr
polish = do
    many whitespace
    fst <- Number <$> integer
    rst <- many $ do many whitespace
                     b <- polish
                     many whitespace
                     o <- op
                     pure $ \a -> Expr o a b
    pure $ foldl' (&) fst rst

opToFunc :: Op -> (Int -> Int -> Int)
opToFunc Plus = (+)
opToFunc Minus = (-)
opToFunc Times = (*)
opToFunc Div = quot

interp :: Expr -> Int
interp (Number x) = x
interp (Expr o a b) = (opToFunc o) (interp a) (interp b)

instance Show Expr where
    show (Number x) = show x
    show (Expr op a b) = foldl' (++) empty ["(", show a, show op, show b, ")"]

main :: IO ()
main = do
    input <- getLine
    let tree = runParse polish input
    putStrLn $ case tree of
      [] -> empty
      ((x,_):_) -> show x ++ " = " ++ (show $ interp x)
    main

-- ======================================================================= --
-- ======================================================================= --
-- ===================== From-scratch Parser def ========================= --
-- ======================================================================= --
-- ======================================================================= --

data Parser a = Parser { runParse :: String -> [(a, String)] } deriving (Functor)
instance Applicative Parser where
    pure x = Parser $ \s -> [(x, s)]
    p <*> q = Parser $ \s -> do
        (f, s1) <- runParse p s
        (a, s2) <- runParse q s1
        pure $ (f a, s2)
instance Alternative Parser where
    empty = Parser $ pure []
    f <|> g = Parser $ \s ->
      case runParse f s of []  -> runParse g s
                           res -> res
char :: Char -> Parser Char
char x = Parser $
  \case (c:cs) | x == c -> [(c, cs)]
        _               -> []
oneOf :: [Parser a] -> Parser a
oneOf       = foldr (<|>) empty
oneOfChar   ::  String  -> Parser Char
oneOfChar   = oneOf . fmap char
zeroOrOne :: Parser a -> Parser (Maybe a)
zeroOrOne x = Just <$> x <|> pure Nothing
digit, leading_digit :: Parser Char
digit         = oneOfChar ['0'..'9']
leading_digit = oneOfChar ['1'..'9']
natural :: Parser Int
natural = read <$> do
    lead <- leading_digit
    rest <- many digit
    pure $ lead:rest
zero :: Parser Int
zero = char '0' *> pure 0
integer :: Parser Int
integer = zero <|> do
    minus <- zeroOrOne $ char '-'
    num <- natural
    pure $ case minus of
             Nothing -> num
             _ -> negate num
whitespace :: Parser Char
whitespace = char ' '