Simple Applicative Parser and Expression Calculator in Haskell

Calc.hs

module Calc
( Expr(..)
, parse
, calculate
) where

import Control.Applicative
import Parser

data Expr = Add Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr
          | Div Expr Expr
          | Lit Integer deriving ( Eq, Show )

eval :: Expr -> Integer
eval (Lit a) = a
eval (Add l r) = eval l + eval r
eval (Sub l r) = eval l - eval r
eval (Mul l r) = eval l * eval r
eval (Div l r) = eval l `div` eval r

spaceChar :: Char -> Parser String Char
spaceChar c = between spaces spaces (char c)

literal :: Parser String Expr
literal = Lit . read <$> (spaces *> many1 digit <* spaces)

add :: Parser String Expr
add = Add <$> term <*> (spaceChar '+' *> expr)

sub :: Parser String Expr
sub = Sub <$> term <*> (spaceChar '-' *> expr)

mul :: Parser String Expr
mul = Mul <$> factor <*> (spaceChar '*' *> term)

divide :: Parser String Expr
divide = Div <$> factor <*> (spaceChar '/' *> term)

parens :: Parser String Expr
parens = between (spaceChar '(') (spaceChar ')') expr

factor :: Parser String Expr
factor = literal <|> parens

term :: Parser String Expr
term = mul <|> divide <|> factor

expr :: Parser String Expr
expr = add <|> sub <|> term

parse :: String -> Maybe Expr
parse = fmap fst . runParser (expr <* eos)

calculate :: String -> Maybe Integer
calculate = fmap eval . parse

Main.hs

module Main where

import System.Environment (getArgs)
import Calc

main :: IO ()
main = do
  args <- getArgs
  case calculate (unwords args) of
    Nothing -> putStrLn "Error"
    Just val -> print val

Parser.hs

module Parser
( Parser (..)
, char
, digit
, Parser.many
, many1
, between
, space
, spaces
, eos
)
where

import Control.Applicative
import Data.Char
import Data.Bifunctor

newtype Parser s a = Parser { runParser :: s -> Maybe (a, s) }

instance Functor (Parser s) where
  fmap f (Parser p) = Parser $ \s -> fmap (first f) (p s)

instance Applicative (Parser s) where
  pure a =  Parser $ \s -> Just (a, s)
  Parser f <*> Parser g =
    Parser $ \s -> case f s of
      Nothing -> Nothing
      Just (a, s') -> fmap (first a) (g s')

instance Alternative (Parser s) where
  empty = Parser $ const Nothing
  (Parser f) <|> (Parser g) = Parser $ \s -> f s <|> g s

predHead :: (a -> Bool) -> Parser [a] a
predHead p = Parser $ \s ->
  if not (null s) && p (head s)
    then Just (head s, tail s)
    else Nothing

char :: Char -> Parser String Char
char c = predHead (== c)

digit :: Parser String Char
digit = predHead isDigit

space :: Parser String Char
space = char ' ' <|> char '\t' <|> char '\n'

eos :: Parser String ()
eos = Parser $ \s -> if null s then Just ((), "") else Nothing

many :: Parser s a -> Parser s [a]
many = Control.Applicative.many

many1 :: Parser s a -> Parser s [a]
many1 = Control.Applicative.some

between :: Parser s a -> Parser s b -> Parser s c -> Parser s c
between lp rp p = lp *> p <* rp

spaces :: Parser String String
spaces = Parser.many space