A simple infix calculator in Haskell

I saw this on reddit and knew that my infix calculator was hanging around, so I decided to post it for some contrast.

There are a few problems, mainly that I had this desire to "not cheat" when I wrote it so I didn't use nearly as many Parsec functions as I could have. Also it's not very user-friendly, the only way to quit is Ctrl-C or EOF and EOF causes an error to be displayed. That said, here it is in all it's "glory". Compile with ghc --make Main.hs (or whatever you named the file, if you bothered).

module Main where
import Text.ParserCombinators.Parsec
import Control.Monad
import Control.Monad.Error
import System.IO

data Expr a = Number a
            | Add (Expr a) (Expr a)
            | Mul (Expr a) (Expr a)
            | Sub (Expr a) (Expr a)
            | Div (Expr a) (Expr a)
            | Negate (Expr a)
            deriving (Show, Eq)

data AddOp = Plus | Minus
data MulOp = Times | Over

evaluate :: (Fractional a, Monad m) => Expr a -> m a
evaluate (Negate x) = liftM negate (evaluate x)
evaluate (Div x y)  = do x' <- (evaluate x)
                         y' <- (evaluate y)
                         if y' == 0 then fail "Division by zero"
                                    else return $ x' / y'
evaluate (Sub x y)  = liftM2 (-) (evaluate x) (evaluate y)
evaluate (Mul x y)  = liftM2 (*) (evaluate x) (evaluate y)
evaluate (Add x y)  = liftM2 (+) (evaluate x) (evaluate y)
evaluate (Number x) = return x



pDigit = oneOf ['0'..'9']
pSign = option '+' $ oneOf "-+"
pDigits = many1 pDigit
pDecimalPoint = char '.'
pFracPart = option "0" (pDecimalPoint >> pDigits)

number = do sign <- pSign
            integerPart <- pDigits
            fracPart <- pFracPart
            expPart <- pExp
            let i = read integerPart
            let f = read fracPart
            let e = expPart
            let value = (i + (f / 10^(length fracPart))) * 10 ^^ e
            return $ Number $ case sign of
                 '+' -> value
                 '-' -> negate value
         where pExp = option 0 $ do
                             oneOf "eE"
                             sign <- pSign
                             num <- pDigits
                             let n = read num
                             return $ if sign == '-' then negate n else n

whitespace = many $ oneOf "\n\t\r\v "

term = do t <- term'
          whitespace
          return t
       where term' = (try number) <|> negTerm <|> parenExpr

negTerm = do
             char '-'
             whitespace
             e <- term
             return $ Negate e

expr = do
          first <- mulTerm
          ops <- addOps
          return $ foldl buildExpr first ops
       where buildExpr acc (Plus, x) = Add acc x
             buildExpr acc (Minus, x) = Sub acc x

addOp = do operator <- oneOf "+-"
           whitespace
           t        <- mulTerm
           return $ case operator of
                         '-' -> (Minus, t)
                         '+' -> (Plus, t)

addOps = many addOp


parenExpr = do char '('
               e <- expr
               char ')'
               return e

mulTerm = do first <- term
             ops <- mulOps
             return $ foldl buildExpr first ops
          where buildExpr acc (Times, x) = Mul acc x
                buildExpr acc (Over, x) = Div acc x

mulOp = do operator <- oneOf "*/"
           whitespace
           t        <- term
           return $ case operator of
                         '*' -> (Times, t)
                         '/' -> (Over, t)

mulOps = many mulOp
calculation = do whitespace
                 e <- expr
                 eof
                 return e

evalPrint s = case (parse calculation "" s) of
                   Right x -> case evaluate x of
                                   Right v -> print v
                                   Left err -> putStrLn $ "Error: " ++ err
                   Left err -> putStr "parse error at " >> print err

main =  getLine >>= evalPrint >> main