Simple arithmetic expression language

expressions.hs

module Expressions where

import Data.Maybe
import Text.Printf
import Control.Applicative

data Expr = Term Int | Op Operator Expr Expr | Var String
  deriving (Show, Eq)

data Operator = Sum | Mult | Sub | Div
  deriving (Show, Eq)
  
data Result a = Failure [String] | Success a
  deriving (Show, Eq)
  
newtype Parser a = Parser {runParser :: String -> Maybe (a, String)}

anyCharP :: Parser Char
anyCharP = Parser p
  where
    p []       = Nothing
    p (x : xs) = Just (x, xs)

charP :: Char -> Parser Char
charP c = Parser $ \inp -> case inp of
                             (x:xs) | x == c -> Just (c, xs)
                             _ -> Nothing

combP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
combP f pa pb = f <$> pa <*> pb

instance Functor Parser where
  fmap f (Parser pa) = Parser $ \s -> case pa s of
                                       Nothing -> Nothing
                                       Just (a, s') -> Just (f a, s')

instance Applicative Parser where
  pure x = Parser $ \s -> Just (x, s)
  (Parser pf) <*> (Parser pa) = Parser $ \s -> case pf s of
                                                 Nothing -> Nothing
                                                 Just (f, s') -> case pa s' of
                                                   Nothing -> Nothing
                                                   Just (a, s'') -> Just (f a, s'')

foldExpr :: (Int -> a) -> (Operator -> a -> a -> a) -> (String -> a) -> Expr -> a
foldExpr ft _  _  (Term i)   = ft i
foldExpr ft fo fv (Op o u v) = fo o (foldExpr ft fo fv u) (foldExpr ft fo fv v)
foldExpr ft fo fv (Var id)   = fv id

eval :: [(String, Int)] -> Expr -> Result Int
eval env = foldExpr Success applyOp getV
  where
    getV x = maybe (Failure [x]) Success $ lookup x env

applyOp :: Operator -> Result Int -> Result Int -> Result Int
applyOp o x y = getOp o <$> x <*> y

getOp :: Operator -> Int -> Int -> Int
getOp o = case o of
  Sum  -> (+)
  Mult -> (*)
  Sub  -> (-)
  Div  -> div

printExpr :: Expr -> String
printExpr = foldExpr show (flip (printf "(%s %s %s)") . printOp) id

printOp o = case o of
  Sum  -> "+"
  Mult -> "*"
  Sub  -> "-"
  Div  -> "/"
  
countTerms :: Expr -> Int
countTerms = foldExpr (const 1) (const (+)) (const 1)

sample = Op Mult (Op Sum (Var "x") (Var "y")) (Term 4)

instance Functor Result where
  fmap f (Success a)  = Success (f a)
  fmap _ (Failure es) = Failure es

instance Applicative Result where
  pure v = Success v
  (Success f)  <*> (Success x)  = Success (f x)
  (Failure xs) <*> (Failure ys) = Failure $ xs ++ ys
  (Failure xs) <*> _            = Failure xs
  _            <*> (Failure ys) = Failure ys

I had to change these lines:
26: printExpr = foldExpr show (\o u v -> printf "(%s %s %s)" u (printOp o) v)
35: countTerms = foldExpr (const 1) (_ -> (+))

Oops, that was slack. It seems we didn't actually compile that version in our haste at the end of the session. I've corrected it here now.