Internal.hs

{-# LANGUAGE DeriveDataTypeable
           , EmptyDataDecls
           , ExistentialQuantification
           , FlexibleInstances
           , IncoherentInstances
           , MultiParamTypeClasses
           , PolymorphicComponents
           , TypeSynonymInstances
  #-}

-------------------------------------------------------------------------------
-- |
-- Module       : System.IOR.Internal
-- Copyright    : (c) Ivan Tomac 2008
-- License      : BSD3
--
-- Maintainer   : tomac `at` pacific `dot` net `dot` au
-- Stability    : experimental
--
-- IOR monad internals.
--
-------------------------------------------------------------------------------

module System.IOR.Internal (
    RElem
  , RCons
  , RNil

  , IOR (..)

  , runIOR
  , newIOR

  , IORTag (..)

  , getIORTag
  , withIORTag

  , Resource  (..)
  , Resource' (..)
) where

import Control.Applicative
import Control.Monad.Error
import Control.Monad.Trans

import Data.Generics
import Data.IORef

import System.IO.Error

class RElem r rs

data RCons r rs
data RNil

instance               RElem r (RCons r  rs)
instance RElem r rs => RElem r (RCons r' rs)

-- | 'IO' monad with support for region based resource allocation.
-- A computation of type @'IOR' r rs a@ wraps an action of type @'IO' a@
-- where @r@ is an unconstrained type variable indicating the current region
-- and @rs@ is a collection of all accessible regions within the computation.
--
-- 'IO' actions can be lifted into the 'IOR' monad using 'liftIO'.
-- It is safe to throw 'IOError'-s inside an 'IOR' computation.
-- Allocated resources will be released on exit automatically.

data IOR r rs a
  = IOR { unIOR :: IORTag r -> IO a }
    deriving (Data, Typeable)

instance Monad (IOR r rs) where
    return  = IOR . const . return
    m >>  n = IOR $ liftA2 (>>)  (unIOR m) (unIOR n)
    m >>= f = IOR $ liftA2 (>>=) (unIOR m) (flip $ unIOR . f)

    {-# INLINE return #-}
    {-# INLINE (>>)   #-}
    {-# INLINE (>>=)  #-}

instance Functor (IOR r rs) where
    fmap f m = IOR $ fmap f . unIOR m
    {-# INLINE fmap #-}

instance Applicative (IOR r rs) where
    pure  = return
    (<*>) = ap

instance MonadIO (IOR r rs) where
    liftIO = IOR . const
    {-# INLINE liftIO #-}

instance MonadFix (IOR r rs) where
    mfix f = IOR $ mfix . flip (unIOR . f)
    {-# INLINE mfix #-}

instance MonadError IOError (IOR r rs) where
    throwError = liftIO . throwError

    catchError m handler = IOR catchError'
        where
            catchError' = liftA2 catchError (unIOR m) handler'
            handler'    = flip (unIOR . handler)

run :: IOR r rs a -> IO a
run m = do
    ref <- newIORef (0, [])
    e   <- try $ unIOR m $ IORTag ref
    readIORef ref >>= mapM_ finalizeRes . snd
    either throwError return e
    where
        finalizeRes (Resource' r) = finalizer r

-- | Create the initial region, @r@, and run the computation returning a
-- value of type @'IO' a@.

runIOR :: IOR r (RCons r RNil) a -> IO a
runIOR = run

-- | Create a new region @r'@ inside @r@. All resources allocated in
-- @r'@ are only accessible from @r'@ and any of it's child regions.
-- On exit from the region, all allocated resources are automatically
-- released.

newIOR :: IOR r' (RCons r' rs) a -> IOR r rs a
newIOR = liftIO . run

type IdTag = Integer

-- | A region tag @'IORTag' r@ captures state of the region @r@ including all
-- currently allocated resources in @r@.

newtype IORTag r
  = IORTag { unIORTag :: IORef (IdTag, [Resource' r]) }
    deriving (Data, Eq, Typeable)

-- | Get the current region's tag.

getIORTag :: IOR r rs (IORTag r)
getIORTag = IOR return

-- | Temporarily change the current region from @r@ to @r'@. This allows
-- allocation of resources in @r'@.
--
-- @r'@ has to be one of the parent regions of @r@.

withIORTag :: RElem r' rs => IORTag r' -> IOR r' rs a -> IOR r rs a
withIORTag = (liftIO .) . flip unIOR

-- | @'Resource' r a@ wraps a resource of type @a@ so it can be managed
-- inside region @r@ and automatically released upon exit from @r@.

data Resource r a
  = Resource {
      -- | Extract @a@ from the 'Resource' wrapper.
        getResource :: a
      -- | Tag that uniquely identifies the resource in the current region.
      , idTag       :: IdTag
      -- | Reference to region state.
      , tagRef      :: IORef (IdTag, [Resource' r])
      -- | Finalizer for the resource.
      , finalizer   :: IO ()
    }
    deriving (Data, Typeable)

instance Eq (Resource r a) where
    r1 == r2 = idTag r1 == idTag r2

data Resource' r
  = forall a. Resource' {-# UNPACK #-} !(Resource r a)
    deriving Typeable

instance Eq (Resource' r) where
    Resource' r1 == Resource' r2 = idTag r1 == idTag r2