A basic math evaluator in Haskell

ShuntingYard.hs

type Precedence = Int
data Associativity = AssocL | AssocR
data Token = Operand Int | Operator String (Int -> Int -> Int) Associativity Precedence | ParenL | ParenR

instance Show Token where
  show (Operator s _ _ _) = s
  show (Operand x)        = show x
  show ParenL             = "("
  show ParenR             = ")"

instance Eq Token where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

evalMath :: String -> Int
evalMath = rpn . shuntingYard . tokenize

tokenize :: String -> [Token]
tokenize = map token . words
  where token s@"+" = Operator s (+) AssocL 2
        token s@"-" = Operator s (-) AssocL 2
        token s@"*" = Operator s (*) AssocL 3
        token s@"/" = Operator s div AssocL 3
        token s@"^" = Operator s (^) AssocR 4
        token "("   = ParenL
        token ")"   = ParenR
        token x     = Operand $ read x

shuntingYard :: [Token] -> [Token]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token] -> Int
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs

main = do 
  putStrLn $ "Tokens: " ++ (unwords $ (map show) $                      tokenize exp)
  putStrLn $ "RPN:    " ++ (unwords $ (map show) $       shuntingYard $ tokenize exp)
  putStrLn $ "Result: " ++ (show                 $ rpn $ shuntingYard $ tokenize exp)
  where exp = "2 ^ 3 ^ 4 + ( 1 + 1 ) * 2"

ShuntingYard2.hs

type Precedence = Int
data Associativity = AssocL | AssocR
data Result = I Int | B Bool deriving (Eq)
data Token = Operand Result | Operator String (Result -> Result -> Result) Associativity Precedence | ParenL | ParenR

instance Show Result where
  show (I x) = show x
  show (B x) = show x

instance Show Token where
  show (Operator s _ _ _) = s
  show (Operand x)        = show x
  show ParenL             = "("
  show ParenR             = ")"

instance Eq Token where
  Operator s1 _ _ _ == Operator s2 _ _ _  = s1 == s2
  Operand  x1       == Operand  x2        = x1 == x2
  ParenL            == ParenL             = True
  ParenR            == ParenR             = True
  _                 == _                  = False

evalMath :: String -> Result
evalMath = rpn . shuntingYard . tokenize

liftIII f (I x) (I y) = I $ f x y
liftIIB f (I x) (I y) = B $ f x y
liftBBB f (B x) (B y) = B $ f x y

tokenize :: String -> [Token]
tokenize = map token . words
  where token s@"&&" = Operator s (liftBBB (&&)) AssocL 0
        token s@"||" = Operator s (liftBBB (||)) AssocL 0
        token s@"="  = Operator s (liftIIB (==)) AssocL 1
        token s@"!=" = Operator s (liftIIB (/=)) AssocL 1
        token s@">"  = Operator s (liftIIB (<))  AssocL 1
        token s@"<"  = Operator s (liftIIB (>))  AssocL 1
        token s@"<=" = Operator s (liftIIB (>=)) AssocL 1
        token s@">=" = Operator s (liftIIB (<=)) AssocL 1
        token s@"+"  = Operator s (liftIII (+))  AssocL 2
        token s@"-"  = Operator s (liftIII (-))  AssocL 2
        token s@"*"  = Operator s (liftIII (*))  AssocL 3
        token s@"/"  = Operator s (liftIII div)  AssocL 3
        token s@"^"  = Operator s (liftIII (^))  AssocR 4
        token "("    = ParenL
        token ")"    = ParenR
        token "f"    = Operand $ B False
        token "t"    = Operand $ B True
        token x      = Operand $ I $ read x

shuntingYard :: [Token] -> [Token]
shuntingYard = finish . foldl shunt ([], [])
  where finish (tokens, ops) = (reverse tokens) ++ ops
        shunt (tokens, ops) token@(Operand _)        = (token:tokens, ops)
        shunt (tokens, ops) token@(Operator _ _ _ _) = ((reverse higher) ++ tokens, token:lower)
          where (higher, lower) = span (higherPrecedence token) ops
                higherPrecedence (Operator _ _ AssocL prec1) (Operator _ _ _ prec2) = prec1 <= prec2
                higherPrecedence (Operator _ _ AssocR prec1) (Operator _ _ _ prec2) = prec1 < prec2
                higherPrecedence (Operator _ _ _ _)          ParenL                 = False
        shunt (tokens, ops) ParenL = (tokens, ParenL:ops)
        shunt (tokens, ops) ParenR = ((reverse afterParen) ++ tokens, tail beforeParen)
          where (afterParen, beforeParen) = break (== ParenL) ops

rpn :: [Token] -> Result
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs

main = do 
  putStrLn $ "Tokens: " ++ (unwords $ (map show) $                      tokenize exp)
  putStrLn $ "RPN:    " ++ (unwords $ (map show) $       shuntingYard $ tokenize exp)
  putStrLn $ "Result: " ++ (show                 $ rpn $ shuntingYard $ tokenize exp)
  where exp = "2 ^ 3 ^ 4 + ( 1 + 1 ) * 2 > 4000 && 1 + 1 = 2 || f"

Unfortunately, the Ruby version I wrote is entangled with a Treetop grammar, so it isn't a very good comparison. You can see parts of it on my blog.

The instance of Eq for Token (lines 11-16) are only necessary for the (== ParenL) on line 43. Everything else uses pattern matching. I tried to use pattern matching on line 43, but it resulting in two more lines of code which seemed like way too much for the situation. It's hard to argue that six lines are better than two, but the two seemed really inexpressive in context. I can't derive Eq for Token because there is no Eq instance for (Int -> Int -> Int), obviously.

If someone knows a better way to handle that kind of situation, I'd be thrilled to hear about it.

The second version adds comparisons and boolean operators & literals. It took me a while to figure out how to do this. In the end, it didn't require any change to the algorithm at all (except for the return type of rpn and evalMath). Overall, I'm really impressed with the way Haskell allows you to reuse an algorithm just by tweaking the types to be a little more general.

Obviously, a malformed input will fail pattern matching and blow up. This was actually the case before, but the opportunities for error are more numerous now. Error handling would be a good next step. Hopefully it won't be too invasive.