-----------------------------------------------------------------------------
-- |
-- Module: Control.Monad.Trans.InterleavableIO
-- Copyright: (c) 2008 Marco Túlio Gontijo e Silva <marcot@riseup.net>
-- License: X11 license (see LICENSE)
--
-- Maintainer: Marco Túlio Gontijo e Silva <marcot@riseup.net>
-- Stability: unstable
-- Portability: unportable
--
-- This module provides utilities to use functions that are not in the 'IO'
-- 'Monad' as a callback in functions that expects an 'IO' 'Monad'.
-----------------------------------------------------------------------------

module Control.Monad.Trans.InterleavableIO
  ( InterleavableIO (..)
  , embedCallback
  , embedInner
  , promoteState
  , promoteReader
  , promoteWriter
  , InterleaveErrorTException (..)
  )
  where

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Error
import Control.Exception
import Data.IORef
import Data.Typeable

-- | 'MonadIO' types that instanciate this class can interleave an 'IO'
-- function, and be used as a callback in a function that asks for an 'IO'
-- monad.
class MonadIO inner => InterleavableIO inner trans buffer | trans -> inner buffer where
  embed :: (buffer -> inner result) -> trans result
  callback :: buffer -> trans result -> inner result

instance InterleavableIO IO IO () where
  embed readBuffer = readBuffer ()
  callback = flip const

-- | This is an utilitary function to the most simple use-case of this module.
-- It makes it possible to use the function @caller@, that needs an 'IO'
-- as input, with any 'Monad' that instanciates 'InterleavableIO'.
embedCallback
  :: (InterleavableIO innerCaller caller buffer, InterleavableIO innerFunction function buffer)
  => (innerFunction resultFunction -> innerCaller resultCaller) -- ^ @caller@
  -> function resultFunction -- ^ @callback@
  -> caller resultCaller
embedCallback caller function = embed $ \buffer -> caller $ callback buffer function

-- | This is a utilitary function to construct new instances of
-- 'InterleavableIO', in 'Monad's that contain 'InterleavableIO' 'Monad's.  It
-- simply calls embed with an inner buffer that will be used by the inner
-- instance of 'InterleavableIO'.
embedInner :: (InterleavableIO inner trans innerBuffer)
  => ((buffer, innerBuffer) -> inner result) -- ^ @readBuffer@: Usually the first parameter of embed.
  -> buffer -- ^ @buffer@: What should be the first parameter of readBuffer in cases without nested 'Monad's.
  -> trans result
embedInner readBuffer buffer = embed $ \innerBuffer -> readBuffer (buffer, innerBuffer)

instance
  (MonadIO inner, InterleavableIO deepInner inner buffer) =>
  InterleavableIO deepInner (StateT state inner) (IORef state, buffer)
  where
  embed readBuffer
    = do
      state <- get >>= (liftIO . newIORef)
      result <- lift $ embedInner readBuffer state
      liftIO (readIORef state) >>= put
      return result
  callback (buffer, innerBuffer) function
    = do
      (result, newState) <- liftIO (readIORef buffer) >>= callback innerBuffer . runStateT function
      liftIO $ writeIORef buffer newState
      return result

instance
  (MonadIO inner, InterleavableIO deepInner inner buffer)
  => InterleavableIO deepInner (ReaderT reader inner) (reader, buffer)
  where
  embed readBuffer = ask >>= (lift . embedInner readBuffer)
  callback (buffer, innerBuffer) function = callback innerBuffer $ runReaderT function buffer

instance
  (MonadIO inner, InterleavableIO deepInner inner buffer, Monoid writer) =>
  InterleavableIO deepInner (WriterT writer inner) (IORef writer, buffer)
  where
  embed readBuffer
    = do
      writer <- liftIO $ newIORef mempty
      result <- lift $ embedInner readBuffer writer
      liftIO (readIORef writer) >>= tell
      return result
  callback (buffer, innerBuffer) function
    = do
      (result, writer) <- callback innerBuffer $ runWriterT function
      liftIO $ modifyIORef buffer $ mappend writer
      return result

-- | Function useful to convert a pure 'State' monad in a 'StateT' 'IO', to be
-- used with the instance of 'InterleavableIO' 'StateT'.
promoteState :: MonadState state monad => State state result -> monad result
promoteState function
  = do
    (result, state) <- runState function `liftM` get
    put state
    return result

-- | Function useful to convert a pure 'Reader' monad in a 'ReaderT' 'IO', to be
-- used with the instance of 'InterleavableIO' 'ReaderT'.
promoteReader :: MonadReader reader monad => Reader reader result -> monad result
promoteReader function = runReader function `liftM` ask

-- | Function useful to convert a pure 'Writer' monad in a 'WriterT' 'IO', to be
-- used with the instance of 'InterleavableIO' 'WriterT'.
promoteWriter :: MonadWriter writer monad => Writer writer result -> monad result
promoteWriter function
  = tell writer >> return result
  where (result, writer) = runWriter function

-- | Error data type used in 'ErrorT' instance.
data InterleaveErrorTException error = InterleaveErrorTException error deriving (Typeable)

instance
  ( MonadIO inner
  , InterleavableIO deepInner inner buffer
  , InterleavableIO IO inner buffer
  , InterleavableIO IO deepInner buffer
  , Error error
  , Typeable error)
  => InterleavableIO deepInner (ErrorT error inner) ((), buffer)
  where
  embed readBuffer
    = do
      eError
        <- lift $ embed $ \buffer -> catchDyn (Right `fmap` callback buffer (readBuffer ((), buffer)))
        $ \(InterleaveErrorTException error_) -> return $ Left error_
      case eError of
        Right result -> return result
        Left error_ -> throwError error_
  callback ((), buffer) function
    = do
      eError <- callback buffer $ runErrorT function
      case eError of
        Right result -> return result
        Left error_ -> liftIO $ throwDyn $ InterleaveErrorTException error_