Simple and Incredibly Naive Calculator

calc.hs

module Main where
import System.Environment
import Text.ParserCombinators.Parsec
import Control.Monad
import Data.Char

main :: IO ()
main = do putStrLn "What would you like to calculate:"
          input <- getLine
          putStrLn $ readExpr input

readExpr :: String -> String
readExpr input = case parse parseExpr "calc" input of
                 Left err -> "Whoops, looks like you made a syntax error: " ++ show err
                 Right answer -> show $ reduceExpr answer

reduceExpr :: Expr -> Integer
reduceExpr expression = case expression of
                        Addition left right -> (reduceExpr left) + (reduceExpr right)
                        Subtraction left right -> (reduceExpr left) - (reduceExpr right)
                        Multiplication left right -> (reduceExpr left) * (reduceExpr right)
                        Division left right -> (reduceExpr left) `div` (reduceExpr right)
                        Value v -> v

data Expr = Value Integer
          | Addition Expr Expr
          | Subtraction Expr Expr
          | Multiplication Expr Expr
          | Division Expr Expr
          deriving (Show)

parseExpr :: Parser Expr
parseExpr =   (try parseAddition)
          <|> (try parseSubtraction)
          <|> (try parseMultiplication)
          <|> (try parseDivision)
          <|> parseValue

parseBinaryExpr :: Char -> (Expr -> Expr -> Expr) -> Parser Expr
parseBinaryExpr operator constructor = do spaces
                                          left <- many1 digit
                                          spaces
                                          char operator
                                          spaces
                                          right <- many1 digit
                                          return $ constructor ((Value . read) left) ((Value . read) right)
parseAddition :: Parser Expr
parseAddition = parseBinaryExpr '+' Addition

parseSubtraction :: Parser Expr
parseSubtraction = parseBinaryExpr '-' Subtraction

parseMultiplication :: Parser Expr
parseMultiplication = parseBinaryExpr '*' Multiplication

parseDivision :: Parser Expr
parseDivision = parseBinaryExpr '/' Division

parseValue :: Parser Expr
parseValue = do val <- many1 digit
                return $ Value . read $ val

Pretty cool. Still, it can be further simplified:

• Use applicative style
• Function application has highest precedence, so all those parentheses are redundant
• Using x and y instead of left and right is more idiomatic Haskell
• Having an IsString instance for Parser allows for further simplifications (this should actually be provided by parsec...)

{-# LANGUAGE OverloadedStrings, FlexibleInstances, GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Control.Applicative
import Text.ParserCombinators.Parsec hiding ((<|>))
import Data.String

instance (a ~ String) => IsString (Parser a) where
  fromString = string

main :: IO ()
main = do
  putStrLn "What would you like to calculate:"
  parseAndEval <$> getLine >>= putStrLn

parseAndEval :: String -> String
parseAndEval = either err (show . eval) . parse expr ""
  where
    err e = "Whoops, looks like you made a syntax error: " ++ show e

eval :: Expr -> Integer
eval e = case e of
  Addition x y -> eval x + eval y
  Subtraction x y -> eval x - eval y
  Multiplication x y -> eval x * eval y
  Division x y -> eval x `div` eval y
  Value x -> x

data Expr = Value Integer
          | Addition Expr Expr
          | Subtraction Expr Expr
          | Multiplication Expr Expr
          | Division Expr Expr
          deriving (Show)

expr :: Parser Expr
expr =  try addition
    <|> try subtraction
    <|> try multiplication
    <|> try division
    <|> value

addition :: Parser Expr
addition = Addition <$> value <*> ("+" *> value)

subtraction :: Parser Expr
subtraction = Subtraction <$> value <*> ("-" *> value)

multiplication :: Parser Expr
multiplication = Multiplication <$> value <*> ("+" *> value)

division :: Parser Expr
division = Division <$> value <*> ("-" *> value)

value :: Parser Expr
value = Value . read <$> (spaces *> many1 digit <* spaces)