data Token = Add' | Mul' | Number' Integer deriving (Show, Eq)

data Expr = Add Expr Expr | Mul Expr Expr | Number Integer deriving (Eq)

instance Show Expr where
    show (Add x y) = "(" ++ (show x) ++ "+" ++ (show y) ++ ")"
    show (Mul x y) = "(" ++ (show x) ++ "*" ++ (show y) ++ ")"
    show (Number x) = (show x)

eatDigits :: [Char] -> (Integer, [Char])
eatDigits xs = (read (takeWhile digit xs) :: Integer, dropWhile digit xs)
    where digit = (`elem` "0123456789")

scan :: [Char] -> [Token]
scan [] = []
scan (' ':xs) = scan xs
scan ('+':xs) = Add':(scan xs)
scan ('*':xs) = Mul':(scan xs)
scan xs = (Number' n):(scan rest) where (n, rest) = eatDigits xs

-- Ex. 1
-- parse [1 + 2 * 3]   []        []                    Rule 3 (number)
-- parse [+ 2 * 3]     []        [1]                   Rule 4 (empty stack)
-- parse [2 * 3]       [+]       [1]                   Rule 3 (number)
-- parse [* 3]         [+]       [2 1]                 Rule 6 (input > stack)
-- parse [3]           [* +]     [2 1]                 Rule 3 (number)
-- parse []            [* +]     [3 2 1]               Rule 2 (empty input)
-- parse []            [+]       [(2 * 3) 1]           Rule 2 (empty input)
-- parse []            []        [(1 + (2 * 3))]       Rule 1 (done!)

-- Ex. 2
-- parse [1 * 2 + 3]   []        []                    Rule 3 (number)
-- parse [* 2 + 3]     []        [1]                   Rule 4 (empty stack)
-- parse [2 + 3]       [*]       [1]                   Rule 3 (number)
-- parse [+ 3]         [*]       [2 1]                 Rule 5 (input <= stack)
-- parse [+ 3]         []        [(1 * 2)]             Rule 4 (empty stack)
-- parse [3]           [+]       [(1 * 2)]             Rule 3 (number)
-- parse []            [+]       [3 (1 * 2)]           Rule 2 (empty input)
-- parse []            []        [((1 * 2) + 3)]       Rule 1 (done!)

precedence :: (Num t) => Token -> t
precedence Add' = 1
precedence Mul' = 2

reduce Add' (z0:z1:zs) = (Add z1 z0):zs
reduce Mul' (z0:z1:zs) = (Mul z1 z0):zs

-- operator precedence parsing using shunting algorithm
parse :: [Token] -> [Token] -> [Expr] -> Expr
parse [] [] [z] = z                                                               -- Rule 1 (done!)
parse [] (y:ys) output = parse [] ys (reduce y output)                            -- Rule 2 (empty input)
parse ((Number' n):xs) stack output = parse xs stack ((Number n):output)          -- Rule 3 (number)
parse (x:xs) [] output = parse xs [x] output                                      -- Rule 4 (empty stack)
parse tokens@(x:xs) stack@(y:ys) output =
    if (precedence x) <= (precedence y)
    then parse tokens ys (reduce y output)                                        -- Rule 5 (input <= stack)
    else parse xs (x:stack) output                                                -- Rule 6 (input > stack)

demo1 str = parse (scan str) [] []

eval :: Expr -> Integer
eval (Number x) = x
eval (Add x y) = (eval x) + (eval y)
eval (Mul x y) = (eval x) * (eval y)

demo2 str = eval $ parse (scan str) [] []