content: {-# LANGUAGE LambdaCase #-}
  import Control.Applicative
  import Control.Lens
  import Control.Monad
  import Control.Monad.Error
  import Control.Monad.State
  import System.Console.Readline
  
  data InToken = InOp Op | InVal Int | LParen | RParen deriving (Show)
  data OutToken = OutOp Op | OutVal Int
  data StackElem = StOp Op | Paren deriving (Show)
  data Op = Pow | Mul | Div | Add | Sub deriving (Show)
  data Assoc = L | R deriving (Eq)
  
  type Env = ([OutToken], [StackElem])
  type RPNComp = StateT Env (Either String)
  
  instance Show OutToken where
      show (OutOp x) = snd $ opInfo x
      show (OutVal v) = show v
  
  opInfo = \case
      Pow -> (4, "^")
      Mul -> (3, "*")
      Div -> (3, "/")
      Add -> (2, "+")
      Sub -> (2, "-")
  
  prec = fst . opInfo
  leftAssoc Pow = False
  leftAssoc _   = True
  
  --Stateful actions
  processToken :: InToken -> RPNComp ()
  processToken = \case
      (InVal z) -> pushVal z
      (InOp op) -> pushOp op
      LParen    -> pushParen
      RParen    -> pushTillParen
  
  pushTillParen :: RPNComp ()
  pushTillParen = use _2 >>= \case
      []     -> throwError "Unmatched right parenthesis"
      (s:st) -> case s of
           StOp o -> _1 %= (OutOp o:) >> _2 %= tail >> pushTillParen
           Paren  -> _2 %= tail
  
  pushOp :: Op -> RPNComp ()
  pushOp o = use _2 >>= \case
      [] -> _2 .= [StOp o]
      (s:st) -> case s of
          (StOp o2) -> if leftAssoc o && prec o == prec o2
                       || prec o < prec o2
                       then _1 %= (OutOp o2:) >> _2 %= tail >> pushOp o
                       else _2 %= (StOp o:)
          Paren     -> _2 %= (StOp o:)
  
  pushVal :: Int -> RPNComp ()
  pushVal n = _1 %= (OutVal n:)
  
  pushParen :: RPNComp ()
  pushParen = _2 %= (Paren:)
  
  --Run StateT
  toRPN :: [InToken] -> Either String [OutToken]
  toRPN xs = evalStateT process ([],[])
      where process = mapM_ processToken xs
                        >> get >>= \(a,b) -> (reverse a++) <$> (mapM toOut b)
            toOut :: StackElem -> RPNComp OutToken
            toOut (StOp o) = return $ OutOp o
            toOut Paren    = throwError "Unmatched left parenthesis"
  
  --Parsing
  readTokens :: String -> Either String [InToken]
  readTokens = mapM f . words
      where f = let g = return . InOp in \case {
              "^" -> g Pow; "*" -> g Mul; "/" -> g Div;
              "+" -> g Add; "-" -> g Sub; "(" -> return LParen;
              ")" -> return RParen;
              a   -> case reads a of
                  [] -> throwError $ "Invalid token `" ++ a ++ "`"
                  [(_,x:[])] -> throwError $ "Invalid token `" ++ a ++ "`"
                  [(v,[])]    -> return $ InVal v }
  
  --Showing
  showOutput (Left msg) = msg
  showOutput (Right xs) = unwords $ map show xs
  
  main = do
      a <- readline "Enter expression: "
      case a of
          Nothing -> putStrLn "Please enter a line" >> main
          Just "exit" -> return ()
          Just l      -> addHistory l >> case readTokens l of
              Left msg -> putStrLn msg >> main
              Right ts -> putStrLn (showOutput (toRPN ts)) >> main
  