gistfile1.hs

import Data.Maybe
import Control.Monad.State
import Data.Functor ((<$>))

data Env = Env { stack :: [Int]
               , input :: [String]
               , result :: Result }
type Eval = State Env

data Op = Push Int | Disp | Add | Sub | Mul | Div deriving Show

data Result = Value Int
            | InvalidOp
            | Empty
            | NoInput
            | None
              deriving Show

readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
  ((a, []):_) -> Just a
  otherwise -> Nothing

readOp :: String -> Maybe Op
readOp "=" = Just Disp
readOp "+" = Just Add
readOp "-" = Just Sub
readOp "*" = Just Mul
readOp "/" = Just Div
readOp n = Push <$> readMaybe n

top :: Eval (Maybe Int)
top = get >>= return . listToMaybe . stack

pop :: Eval (Maybe Int)
pop = do
  env <- get
  case stack env of
    [] -> return Nothing
    (x:xs) -> put env { stack = xs } >> return (Just x)

push :: Int -> Eval ()
push n = modify $ \env -> env { stack = n:stack env }

apply :: (Int -> Int -> Int) -> Eval ()
apply f = (liftM2 . liftM2) f pop pop >>= maybe (answer Empty) (good . push)

good :: Eval a -> Eval a
good a = a >>= (\r -> answer None >> return r)

answer :: Result -> Eval ()
answer r = modify $ \env -> env { result = r }

evalOp :: Maybe Op -> Eval ()
evalOp (Just op) = evalOp' op
    where
      evalOp' (Push n) = good $ push n
      evalOp' Disp = top >>= answer . maybe Empty Value
      evalOp' Add = apply (+)
      evalOp' Sub = apply (-)
      evalOp' Mul = apply (*)
      evalOp' Div = apply div
evalOp Nothing = answer InvalidOp

evalStep :: Eval ()
evalStep = do
  env <- get
  case input env of
    [] -> answer NoInput
    (x:xs) -> put env { input = xs } >> evalOp (readOp x)

main = interact (unlines . evalLoop . makeEnv)
       where
         evalLoop env = let env' = execState evalStep env
                        in case result env' of
                             Value n -> (show n):evalLoop env'
                             InvalidOp -> "Invalid operator":evalLoop env'
                             Empty -> "Empty stack":evalLoop env'
                             NoInput -> []
                             None -> evalLoop env'
         makeEnv s = Env { stack = [], input = lines s, result = None }