withdraw.hs

import Control.Monad.State.Lazy
import Control.Monad.Error
import Data.Char

type BalanceT e s m a = ErrorT e (StateT s m) a
type Balance a = BalanceT BalanceError Double IO a

data BalanceError = AmountIsNegative | NotEnoughBalance | InvalidCommand String | BalanceError String deriving Show

instance Error BalanceError where
  noMsg = BalanceError "Error occurred"
  strMsg s = BalanceError s

runBalanceT :: Balance () -> Double -> IO ()
runBalanceT b s = runStateT (runErrorT b) s >>= handleError

handleError (a,s) = case a of
                    Left err -> liftIO $ print err >> runBalanceT bank s
                    Right () -> return ()
                    Right _ -> runBalanceT bank s

balanceModify :: (Double -> Double -> Double) -> Double -> Balance ()
balanceModify f amt = lift get >>= balMod
  where balMod bal
          | amt < 0 = throwError AmountIsNegative
          | f amt bal < 0 = throwError NotEnoughBalance
          | otherwise = lift $ modify (f amt)

deposit :: Double -> Balance ()
deposit amt = balanceModify (+) amt

withdraw :: Double -> Balance ()
withdraw amt = balanceModify (flip (-)) amt

prompt :: Read a => String -> Balance a
prompt ppt = do
  liftIO $ putStrLn ppt
  liftIO readLn

showBalance :: Balance ()
showBalance = lift get >>= \bal -> liftIO $ putStrLn $ "Current balance: " ++ show bal

bank :: Balance ()
bank = bankLoop
  where bankLoop = do
          showBalance
          cmd <- liftM (map toLower) $ liftIO $ putStrLn "Enter command:" >> getLine
          case cmd of
              "deposit" -> prompt ">>Enter amount: " >>= deposit >> bankLoop
              "withdraw" -> prompt ">>Enter amount: " >>= withdraw >> bankLoop
              "quit" -> liftIO (putStrLn "Bye.") >> return ()
              _ -> throwError $ InvalidCommand "Unknown command. Commands: 'deposit', 'withdraw', 'quit'"

main = runBalanceT bank 0