Shunting yard algorithm/foo.hs

{- Reference implementation of shunting yard algorithm. Requires: Data.Char, Data.List.
This implementation is not error-tolerant; an exception will occur on any incorrect input.
Note: Unary + and - have precedence higher than * and / but lower than ^. -}
data (Num a) => Token a =
    Plus | Minus |
    Add | Subtract | Multiply | Divide | Exp |
    LeftParen | RightParen |
    Operand a
 
isLeftParen LeftParen = True; isLeftParen _ = False
 
instance (Num a) => Show (Token a) where {
    show Plus = "+"; show Minus = "-";
    show Add = "+"; show Subtract = "-"; show Multiply = "*"; show Divide = "/"; show Exp = "^";
    show LeftParen = "("; show RightParen = ")";
    show (Operand x) = show x
}
 
prec Add = 1; prec Subtract = 1;
prec Multiply = 2; prec Divide = 2;
prec Plus = 3; prec Minus = 3;
prec Exp = 4;
prec _ = 0
 
tokenize s = reverse $ f s [] where
    f [] l = l
    f ('(':s') l = f s' (LeftParen:l)
    f (')':s') l = f s' (RightParen:l)
    f ('/':s') l = f s' (Divide:l)
    f ('^':s') l = f s' (Exp:l)
    f ('+':s') l = f s' (op:l) where
        op = if null l || precedesUnary (head l) then Plus else Add
    f ('-':s') l = f s' (op:l) where
        op = if null l || precedesUnary (head l) then Minus else Subtract
    f ('*':s') l = if "*" `isPrefixOf` s' then f (tail s') (Exp:l) else f s' (Multiply:l)
    f s@(c:s') l
        | isSpace c = f (dropWhile isSpace s) l
        | otherwise =
            let (number, rest) = break (\x -> not (isDigit x || x == '.')) s
            in f rest ((Operand (read number)):l)
    precedesUnary LeftParen = True
    precedesUnary RightParen = False
    precedesUnary (Operand _) = False
    precedesUnary _ = True
 
data (Num a) => AST a =
    Leaf (Token a) |
    Unary (Token a) (AST a) |
    Binary (Token a) (AST a) (AST a)
 
instance (Num a) => Show (AST a) where
    show (Leaf t) = show t
    show (Unary t a) = "(" ++ show t ++ " " ++ show a ++ ")"
    show (Binary t a1 a2) = "(" ++ show t ++ " " ++ show a1 ++ " " ++ show a2 ++ ")"
 
shuntingYard l = f ([LeftParen] ++ l ++ [RightParen]) [] [] where
    f [] st os = head os
    f (Operand x : ts) st os = f ts st (Leaf (Operand x) : os)
    f (LeftParen:ts) st os = f ts (LeftParen:st) os
    f (RightParen:ts) st os = f ts (tail after) (helper before os) where
        (before, after) = break isLeftParen st
    f (Exp:ts) st os = f ts (Exp:st) os
    f (Plus:ts) st os = f ts (Plus:st) os
    f (Minus:ts) st os = f ts (Minus:st) os
    f (op:ts) st os = f ts (op:after) (helper before os) where
        (before, after) = break ((>) (prec op) . prec) st
    helper [] os = os
    helper (Plus:st') (o:os) = helper st' (Unary Plus o : os)
    helper (Minus: st') (o:os) = helper st' (Unary Minus o : os)
    helper (o':st') (o2:o1:os) = helper st' (Binary o' o1 o2 : os)