import Data.Char (isDigit)
import Control.Arrow (first, second)

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]

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

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

parse = fmap fst . parse' . takeWhile (not . null) . map fst . 
	tail . iterate (head . lex . snd) . (,) "" . (++ ")") where
	(opg, ff) = (Operator $ Prinfix (id, (1, True)), fmap . first)
	add i t = ff (t :) . parse'' i
	parse' = ff Statement . add 0 opg
	parse'' pos (l:ls)
		| isDigit (head l) = ifp (<= 2) $ add 3 (Operand $ read l) ls
		| l == "(" = ifp (<= 2) $ uncurry (add 3) =<< parse' ls
		| l == ")" = ifp (>= 3) $ Just ([Operator $ Infix (undefined, (1, True))], ls)
		| pos <= 1 = choose 1
		| pos <= 4 = choose 4 where
		ifp g x = if g pos then x else Nothing
		choose i = flip (uncurry add) ls =<< case (toOp i l, ifp (< i) $ toOp (i - 1) l) of
			(Just t, Nothing) -> Just ((i + 1) `rem` 5, t)
			(Nothing, Just t) -> Just (i, t)
			_ -> Nothing

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

calc = fmap eval . 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"
	, "2 + -3 * 5"
	]