{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Prelude hiding (catch)
import Control.Exception
import Control.Monad.State
import Control.Monad.Wrap
import Control.Monad.Writer
import Data.Typeable


type OuterMonad = WriterT String IO

type MyState = Int
type InnerMonad = StateT MyState OuterMonad

data Trap = Trap deriving (Typeable, Show)
instance Exception Trap

handler :: String -> IO a -> Trap -> IO a
handler place a e = do
  putStrLn $ "caught " ++ show e ++ " in " ++ place
  a

inner :: InnerMonad ()
inner = do
  liftIO $ putStrLn "running inner"
  liftIO $ throwIO Trap

middle :: InnerMonad ()
middle = do
  put 1                         -- Can do StateT operations
  liftIO $ putStrLn "running middle"
  -- x <- result ()
  -- y <- lift $ result x
  -- wrap (wrap (handle $ handler "middle" $ return y)) inner
  f1 <- resultF
  f2 <- liftM (. f1) $ lift resultF
  wrap (wrap (handle $ handler "middle" $ return $ f2 ())) inner
  wrap (wrap do_finally) inner
    where
      do_finally = flip finally $ putStrLn "middle finally!"

outer :: OuterMonad ()
outer = do
  tell "This is outer"          -- Can do WriteT operations
  liftIO $ putStrLn "About to run middle"
  x <- result ()
  wrap (handle $ handler "outer" $ return x) (evalStateT middle 0)
  liftIO $ putStrLn "Just ran middle"
  wrap do_finally (evalStateT middle 0)
  liftIO $ putStrLn "This line won't be reached"
    where
      do_finally = flip finally $ putStrLn "outer finally!"

main :: IO ((), String)
main = runWriterT outer