Haskell module example

EvalMath.hs

import ShuntingYard

data Result = I Int | B Bool deriving (Eq)

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

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 Result]
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

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"

ShuntingYard.hs

module ShuntingYard ( Associativity(AssocL, AssocR)
                    , Token(Operand, Operator, ParenL, ParenR)
                    , shuntingYard
                    , rpn) where 

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

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

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

shuntingYard :: (Eq a) => [Token a] -> [Token a]
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 a] -> a
rpn = head . foldl rpn' []
  where rpn' (x:y:ys) (Operator _ f _ _) = (f x y):ys
        rpn' xs (Operand x) = x:xs