YAY MTL!!!

Mtl.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

module Main where

import Control.Monad
import Control.Monad.Trans.State (runState, runStateT)
import Control.Monad.Trans.Except (runExceptT, runExcept)
import Control.Monad.Error.Class
import Control.Monad.State.Class

type App a = forall m. (MonadState Int m, MonadError String m) => m a

incrementUnlessFive :: App ()
incrementUnlessFive = do
  s <- get
  when (s == 5) $ throwError "Oh no! 5"
  modify (+ 1)

one :: App Int
one = incrementUnlessFive *> get

lots :: App [Int]
lots = replicateM 6 one

decorateAppError :: String -> App ()
decorateAppError e = do
  s <- get
  throwError $ "A bad thing happened: " <> e <> " when we were in state: " <> show s

-- This one loses the current state, can only refer it's _first_ value.
runAppOne :: App a -> Int -> Either String (a, Int)
runAppOne app s = runExcept (runStateT app s)

-- This one keeps it.
runAppTwo :: App a -> Int -> (Either String a, Int)
runAppTwo app = runState (runExceptT app)

-- >>> main
-- Right (1,1)
-- (Right 1,1)
-- Left "Oh no! 5"
-- (Left "Oh no! 5",5)
-- Left "A bad thing happened: Oh no! 5 when we were in state: 0"
-- (Left "A bad thing happened: Oh no! 5 when we were in state: 5",5)

main :: IO ()
main =  do
  print $ runAppOne one 0
  print $ runAppTwo one 0
  print $ runAppOne lots 0
  print $ runAppTwo lots 0
  print $ runAppOne (void lots `catchError` decorateAppError) 0
  print $ runAppTwo (void lots `catchError` decorateAppError) 0