import Data.Char
import Data.Maybe
import Control.Monad
import Control.Arrow

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }

instance (Monad m) => Monad (StateT s m) where
    return a = StateT $ \s -> return (a, s)
    m >>= k  = StateT $ \s -> do
        ~(a, s') <- runStateT m s
        runStateT (k a) s'

instance (MonadPlus m) => MonadPlus (StateT s m) where
    mzero = StateT $ \_ -> mzero
    m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s

evalStateT m s = do
    ~(a, _) <- runStateT m s
    return a
--------------------------------------------------------------------------------------------------------------------
type Order = (Int, Bool)
type D = Double
type DD = D -> D
type DDD = D -> D -> D

data Oper = Prinfix (DD, Order) | Prefix DD | Postfix DD | Infix (DDD, Order)
data Expr = Operand D | Operator Oper | Statement [Expr]

(leftass, rightass) = (True, False)
makeGuard d g = Operator $ d (g, (1, True))

toOp' d xs l = lookup l xs >>= Just . Operator . d

toOp 0 = toOp' Prinfix [("-", (negate, (5, leftass)))]
toOp 1 = toOp' Prefix [("sqr", (^2))]
toOp 3 = toOp' Postfix [("!", \x -> product [1..x])]
toOp 4 = toOp' Infix [("+", ((+), (5, leftass))), ("-", ((-), (5, leftass))), 
	("*", ((*), (6, leftass))), ("/", ((/), (6, leftass))), ("^", ((**), (7, rightass)))]

modifyVal g s = s >>= return . g

parse = modifyVal (Statement . (makeGuard Prinfix id :)) $ parse' 0 where
	add i t = modifyVal (t :) $ parse' i
	parse' i = StateT (listToMaybe . lex) >>= parse'' i
	parse'' pos l
		| l == "" || l == ")" = guard (pos >= 3) >> return [makeGuard Infix undefined]
		| isDigit $ head l = guard (pos <= 2) >> add 3 (Operand $ read l)
		| l == "(" = guard (pos <= 2) >> parse >>= add 3
		| pos <= 1 = choose 1
		| pos <= 4 = choose 4
		where choose i = uncurry add =<< case (toOp i l, guard (pos < i) >> toOp (i - 1) l) of
				(Just t, Nothing) -> return (i `rem` 2 + 1, t)
				(Nothing, Just t) -> return (i, t)
				_ -> mzero

eval (Operand t) = t
eval (Statement t) = fst . snd $ eval' (0, True) (undefined, t) where
	cond (pr1, as1) (pr2, as2) = pr1 > pr2 || pr1 == pr2 && if as1 == as2 then as1
		else error "cannot mix two operators"
	eval' op (n, ots@(Operator o : ts)) = case o of
		Prefix g -> h g $ uncurry eval'
		Postfix g -> eval' op (g n, ts)
		Prinfix (g, opt) -> h g $ until (cond opt . fst) (eval' opt . snd)
		Infix (g, opt) -> (,) opt . (,) n $ if cond op opt then ots else Operator (Prinfix (g n, opt)) : ts
		where h g f = second (first g) $ f ((10, undefined), (undefined, ts))
	eval' op (n, t : ts) = eval' op (eval t, ts)

calc = fmap eval . evalStateT parse

main = mapM_ (print . calc)
	[ "2 + 3"
	, "4 - 3"
	, "2 + (-3)"
	, "4 * 5"
	, "6/4"
	, "1.2 + 1/2"
	, "1/(-3)"
	, "0.5 + 0.2"
	, "3 ^ 2 ^ 2"
	, "17654/342"
	, "2/3 ^ 2"
	, "(2/3) ^ 2"
	, "(2 + 3) / (2 - 2)"
	, "2 + 345 + + + + 6"
	, " - sqr 5! +(-sqr(1 - 2^ 3) ^sqr 2 *9 !) "
	, "5 + 9 3"
	, "sqr sqr 3"
	]