Saturday, October 13, 2007

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