diff --git a/Control/Monad/Trans/Region.hs b/Control/Monad/Trans/Region.hs --- a/Control/Monad/Trans/Region.hs +++ b/Control/Monad/Trans/Region.hs @@ -21,19 +21,12 @@ -- * Running regions , runRegionT - , TopRegion - , runTopRegion - - -- ** Forking /top-level/ regions - , forkIOTopRegion - , forkOSTopRegion -#ifdef __GLASGOW_HASKELL__ - , forkOnIOTopRegion -#endif -- * Duplication , Dup(dup) - , module Control.Monad.Trans.Region.ParentOf + -- * Ancestor relation between regions + , AncestorRegion + , RootRegion -- * Handy functions for writing monadic instances , liftCallCC @@ -42,4 +35,4 @@ ) where import Control.Monad.Trans.Region.Internal -import Control.Monad.Trans.Region.ParentOf + diff --git a/Control/Monad/Trans/Region/Concurrent.hs b/Control/Monad/Trans/Region/Concurrent.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Region/Concurrent.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Region.Concurrent +-- Copyright : (c) 2009-2010 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- Concurrently executing regions. +-- +-- This module exports functions with equivalent names from @Control.Concurrent@ +-- and @GHC.Conc@. May I suggest you import this module qualified as in: +-- +-- @import qualified Control.Monad.Trans.Region.Concurrent as Region@ +-- +-------------------------------------------------------------------------------- + +module Control.Monad.Trans.Region.Concurrent + ( forkIO + , forkOS +#ifdef __GLASGOW_HASKELL__ + , forkOnIO +#endif + ) where + +import Control.Monad.Trans.Region.Internal + ( forkIO + , forkOS +#ifdef __GLASGOW_HASKELL__ + , forkOnIO +#endif + ) diff --git a/Control/Monad/Trans/Region/Internal.hs b/Control/Monad/Trans/Region/Internal.hs --- a/Control/Monad/Trans/Region/Internal.hs +++ b/Control/Monad/Trans/Region/Internal.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE CPP - , UnicodeSyntax - , NoImplicitPrelude - , GeneralizedNewtypeDeriving - , RankNTypes - , KindSignatures +{-# LANGUAGE CPP -- For portability. + , UnicodeSyntax -- Makes it look so nice. + , NoImplicitPrelude -- I like to be fully explicit. + , GeneralizedNewtypeDeriving -- I'm lazy. + , RankNTypes -- Provides the essential type-safety. + , KindSignatures -- To help the type-checker. + , EmptyDataDecls -- For the RootRegion type. + , MultiParamTypeClasses -- For the AncestorRegion class. + , UndecidableInstances -- ) + , FlexibleInstances -- ) For the AncestorRegion instances. + , OverlappingInstances -- ) #-} ------------------------------------------------------------------------------- @@ -27,27 +32,28 @@ ( -- * Regions RegionT - -- * Close handles - , CloseAction - , CloseHandle + -- * Registering finalizers + , Finalizer + , FinalizerHandle , onExit -- * Running regions , runRegionT - , TopRegion - , runTopRegion - - -- ** Forking /top-level/ regions - , forkIOTopRegion - , forkOSTopRegion + -- ** Forking regions + , forkIO + , forkOS #ifdef __GLASGOW_HASKELL__ - , forkOnIOTopRegion + , forkOnIO #endif -- * Duplication , Dup(dup) + -- * Ancestor relation between regions + , AncestorRegion + , RootRegion + -- * Handy functions for writing monadic instances , liftCallCC , mapRegionT @@ -60,54 +66,62 @@ -------------------------------------------------------------------------------- -- from base: -import Prelude ( (+), (-), seq, fromInteger ) +import Prelude ( (+), (-), seq ) import Control.Applicative ( Applicative, Alternative ) -import Control.Monad ( Monad, return, (>>=), fail - , (>>), when, forM_ - , MonadPlus - ) +import Control.Monad ( Monad, return, when, forM_ , MonadPlus ) import Control.Monad.Fix ( MonadFix ) import System.IO ( IO ) import Data.Function ( ($) ) import Data.Functor ( Functor ) import Data.Int ( Int ) -import Data.IORef ( IORef, newIORef - , readIORef, modifyIORef, atomicModifyIORef - ) -import Control.Concurrent ( forkIO, forkOS, ThreadId ) +import Data.IORef ( IORef, newIORef, readIORef, modifyIORef, atomicModifyIORef ) +import Control.Concurrent ( ThreadId ) +import qualified Control.Concurrent ( forkIO, forkOS ) #ifdef __GLASGOW_HASKELL__ -import GHC.Conc ( forkOnIO ) +import qualified GHC.Conc ( forkOnIO ) #endif --- from MonadCatchIO-transformers: -import Control.Monad.CatchIO ( MonadCatchIO, block, bracket ) +#if __GLASGOW_HASKELL__ < 701 +import Prelude ( fromInteger ) +import Control.Monad ( (>>=), (>>), fail ) +#endif +-- from monad-peel: +import Control.Monad.IO.Peel ( MonadPeelIO ) +import Control.Exception.Peel ( bracket ) + -- from transformers: import Control.Monad.Trans.Class ( MonadTrans, lift ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import qualified Control.Monad.Trans.Reader as R ( liftCallCC, liftCatch ) -import Control.Monad.Trans.Reader ( ReaderT(ReaderT) - , runReaderT, mapReaderT - ) +import Control.Monad.Trans.Reader ( ReaderT(ReaderT), runReaderT, mapReaderT ) + -- from base-unicode-symbols: import Data.Eq.Unicode ( (≡) ) import Data.Function.Unicode ( (∘) ) +-- Handling the new asynchronous exceptions API in base-4.3: +#if MIN_VERSION_base(4,3,0) +import Control.Exception ( mask_ ) +#else +import Control.Exception ( block ) +mask_ ∷ IO α → IO α +mask_ = block +#endif + -------------------------------------------------------------------------------- -- * Regions -------------------------------------------------------------------------------- -{-| A monad transformer in which scarce resources can be opened -which are automatically closed when the region terminates. - -Note that regions can be nested. @pr@ (for parent region) is a monad which is -usually the region which is running this region. However when you are running a -'TopRegion' the parent region will be 'IO'. +{-| A monad transformer in which scarce resources can be opened. When the region +terminates, all opened resources will be closed automatically. It's a type error +to return an opened resource from the region. The latter ensures no I/O with +closed resources is possible. -} newtype RegionT s (pr ∷ * → *) α = RegionT - { unRegionT ∷ ReaderT (IORef [Handle]) pr α } + { unRegionT ∷ ReaderT (IORef [RefCountedFinalizer]) pr α } deriving ( Functor , Applicative @@ -117,37 +131,59 @@ , MonadFix , MonadTrans , MonadIO - , MonadCatchIO + , MonadPeelIO ) -data Handle = Handle !CloseAction !(IORef RefCnt) +-- | A 'Finalizer' paired with its reference count which defines how many times +-- it has been registered in some region. +data RefCountedFinalizer = RefCountedFinalizer !Finalizer !(IORef RefCnt) -- | An 'IO' computation that closes or finalizes a resource. For example -- @hClose@ or @free@. -type CloseAction = IO () +type Finalizer = IO () type RefCnt = Int -------------------------------------------------------------------------------- --- * Close handles +-- * Registering finalizers -------------------------------------------------------------------------------- --- | A handle to a 'CloseAction' that allows you to duplicate the action to a --- parent region using 'dup'. -newtype CloseHandle (r ∷ * → *) = CloseHandle Handle +-- | A handle to a 'Finalizer' that allows you to duplicate it to a parent +-- region using 'dup'. +-- +-- Duplicating a finalizer means that instead of it being performed when the +-- current region terminates it is performed when the parent region terminates. +newtype FinalizerHandle (r ∷ * → *) = FinalizerHandle RefCountedFinalizer --- | Register the 'CloseAction' in the region. When the region terminates all --- registered close actions will be perfomed if they're not duplicated to a --- parent region. -onExit ∷ MonadIO pr ⇒ CloseAction → RegionT s pr (CloseHandle (RegionT s pr)) -onExit closeAction = RegionT $ ReaderT $ \hsIORef → liftIO $ do - refCntIORef ← newIORef 1 - let h = Handle closeAction refCntIORef - modifyIORef hsIORef (h:) - return $ CloseHandle h +{-| Register the 'Finalizer' in the region. When the region terminates all +registered finalizers will be perfomed if they're not duplicated to a parent +region. +Note that finalizers are run in LIFO order (Last In First Out). So executing the following: +@ +runRegionT $ do + _ <- onExit $ putStrLn \"finalizer 1\" + _ <- onExit $ putStrLn \"finalizer 2\" + return () +@ + +yields: + +@ +finalizer 2 +finalizer 1 +@ +-} +onExit ∷ MonadIO pr ⇒ Finalizer → RegionT s pr (FinalizerHandle (RegionT s pr)) +onExit finalizer = RegionT $ ReaderT $ \hsIORef → liftIO $ do + refCntIORef ← newIORef 1 + let h = RefCountedFinalizer finalizer refCntIORef + modifyIORef hsIORef (h:) + return $ FinalizerHandle h + + -------------------------------------------------------------------------------- -- * Running regions -------------------------------------------------------------------------------- @@ -167,30 +203,32 @@ Note that it is possible to run a region inside another region. -} -runRegionT ∷ MonadCatchIO pr ⇒ (∀ s. RegionT s pr α) → pr α +runRegionT ∷ MonadPeelIO pr ⇒ (∀ s. RegionT s pr α) → pr α runRegionT m = runRegionWith [] m -{-| A region which has 'IO' as its parent region which enables it to be: - - * directly executed in 'IO' by 'runTopRegion', - - * concurrently executed in a new thread by 'forkIOTopRegion'. --} -type TopRegion s = RegionT s IO - -{-| Convenience funtion for running a /top-level/ region in 'IO'. - -Note that: @runTopRegion = 'runRegionT'@ --} -runTopRegion ∷ (∀ s. TopRegion s α) → IO α -runTopRegion = runRegionT +runRegionWith ∷ ∀ s pr α. MonadPeelIO pr + ⇒ [RefCountedFinalizer] → RegionT s pr α → pr α +runRegionWith hs r = bracket (liftIO $ newIORef hs) + (liftIO ∘ after) + (runReaderT $ unRegionT r) + where + after hsIORef = do + hs' ← readIORef hsIORef + forM_ hs' $ \(RefCountedFinalizer finalizer refCntIORef) → do + refCnt ← decrement refCntIORef + when (refCnt ≡ 0) finalizer + where + decrement ∷ IORef RefCnt → IO RefCnt + decrement ioRef = atomicModifyIORef ioRef $ \refCnt → + let refCnt' = refCnt - 1 + in (refCnt', refCnt') -------------------------------------------------------------------------------- --- ** Forking /top-level/ regions +-- ** Forking regions -------------------------------------------------------------------------------- -{-| Return a region which executes the given /top-level/ region in a new thread. +{-| Return a region which executes the given region in a new thread. Note that the forked region has the same type variable @s@ as the resulting region. This means that all values which can be referenced in the resulting @@ -201,7 +239,7 @@ @ 'runRegionT' $ do regionalHndl <- open resource - threadId <- 'forkIOTopRegion' $ doSomethingWith regionalHndl + threadId <- Region.'forkIO' $ doSomethingWith regionalHndl doSomethingElseWith regionalHndl @ @@ -209,56 +247,29 @@ thread are closed only when the current thread or the forked thread terminates whichever comes /last/. -} -forkIOTopRegion ∷ MonadIO pr ⇒ TopRegion s () → RegionT s pr ThreadId -forkIOTopRegion = forkTopRegion forkIO +forkIO ∷ MonadIO pr ⇒ RegionT s IO () → RegionT s pr ThreadId +forkIO = fork Control.Concurrent.forkIO --- | Like 'forkIOTopRegion' but internally uses 'forkOS'. -forkOSTopRegion ∷ MonadIO pr ⇒ TopRegion s () → RegionT s pr ThreadId -forkOSTopRegion = forkTopRegion forkOS +-- | Like 'forkIO' but internally uses @Control.Concurrent.'Control.Concurrent.forkOS'@. +forkOS ∷ MonadIO pr ⇒ RegionT s IO () → RegionT s pr ThreadId +forkOS = fork Control.Concurrent.forkOS #ifdef __GLASGOW_HASKELL__ --- | Like 'forkIOTopRegion' but internally uses 'forkOnIO'. -forkOnIOTopRegion ∷ MonadIO pr ⇒ Int → TopRegion s () → RegionT s pr ThreadId -forkOnIOTopRegion = forkTopRegion ∘ forkOnIO +-- | Like 'forkIO' but internally uses @GHC.Conc.'GHC.Conc.forkOnIO'@. +forkOnIO ∷ MonadIO pr ⇒ Int → RegionT s IO () → RegionT s pr ThreadId +forkOnIO = fork ∘ GHC.Conc.forkOnIO #endif -forkTopRegion ∷ MonadIO pr - ⇒ (IO () → IO ThreadId) - → (TopRegion s () → RegionT s pr ThreadId) -forkTopRegion doFork = \m → +fork ∷ MonadIO pr + ⇒ (IO () → IO ThreadId) + → (RegionT s IO () → RegionT s pr ThreadId) +fork doFork = \m → RegionT $ ReaderT $ \hsIORef → liftIO $ do hs ← readIORef hsIORef - block $ do - forM_ hs $ \(Handle _ refCntIORef) → increment refCntIORef + mask_ $ do + forM_ hs $ \(RefCountedFinalizer _ refCntIORef) → increment refCntIORef doFork $ runRegionWith hs m --------------------------------------------------------------------------------- - --- | Internally used function that actually runs the region on the given list of --- opened resources. -runRegionWith ∷ ∀ s pr α. MonadCatchIO pr - ⇒ [Handle] → RegionT s pr α → pr α -runRegionWith hs r = bracket (liftIO before) - (liftIO ∘ after) - (runReaderT $ unRegionT r) - where - before = newIORef hs - after hsIORef = do - hs' ← readIORef hsIORef - forM_ hs' $ \(Handle closeAction refCntIORef) → do - refCnt ← decrement refCntIORef - when (refCnt ≡ 0) closeAction - --- | Internally used function that atomically decrements the reference count --- that is stored in the given @IORef@. The function returns the decremented --- reference count. -decrement ∷ IORef RefCnt → IO RefCnt -decrement ioRef = do atomicModifyIORef ioRef $ \refCnt → - let refCnt' = refCnt - 1 - in (refCnt', refCnt') - --- | Internally used function that atomically increments the reference count that --- is stored in the given @IORef@. increment ∷ IORef RefCnt → IO () increment ioRef = do refCnt' ← atomicModifyIORef ioRef $ \refCnt → let refCnt' = refCnt + 1 @@ -314,17 +325,72 @@ Back in the parent region you can safely operate on @r1hDup@. -} class Dup α where - dup ∷ MonadCatchIO ppr + dup ∷ MonadIO ppr ⇒ α (RegionT cs (RegionT ps ppr)) → RegionT cs (RegionT ps ppr) (α (RegionT ps ppr)) -instance Dup CloseHandle where - dup (CloseHandle h@(Handle _ refCntIORef)) = - lift $ RegionT $ ReaderT $ \hsIORef → liftIO $ block $ do +instance Dup FinalizerHandle where + dup (FinalizerHandle h@(RefCountedFinalizer _ refCntIORef)) = + lift $ RegionT $ ReaderT $ \hsIORef → liftIO $ mask_ $ do increment refCntIORef modifyIORef hsIORef (h:) - return $ CloseHandle h + return $ FinalizerHandle h + + +-------------------------------------------------------------------------------- +-- * Ancestor relation between regions +-------------------------------------------------------------------------------- + +{-| The @AncestorRegion@ class is used to relate the region in which a resource +was opened to the region in which it is used. Take the following operation from +the @safer-file-handles@ package as an example: + +@hFileSize :: (pr \`AncestorRegion\` cr, MonadIO cr) => RegionalFileHandle ioMode pr -> cr Integer@ + +The @AncestorRegion@ class defines the parent / child relationship between regions. +The constraint + +@ + pr \`AncestorRegion\` cr +@ + +is satisfied if and only if @cr@ is a sequence of zero or more \"@'RegionT' s@\" +(with varying @s@) applied to @pr@, in other words, if @cr@ is an (improper) +nested subregion of @pr@. + +The class constraint @InternalAncestorRegion pr cr@ serves two purposes. First, the +instances of @InternalAncestorRegion@ do the type-level recursion that implements +the relation specified above. Second, since it is not exported, user code cannot +add new instances of 'AncestorRegion' (as these would have to be made instances of +@InternalAncestorRegion@, too), effectively turning it into a /closed class/. +-} + +-- The implementation uses type-level recursion, so it is no surprise we need +-- UndecidableInstances. + +class (InternalAncestorRegion pr cr) ⇒ AncestorRegion pr cr + +instance (InternalAncestorRegion pr cr) ⇒ AncestorRegion pr cr + +class InternalAncestorRegion (pr ∷ * → *) (cr ∷ * → *) + +instance InternalAncestorRegion (RegionT s m) (RegionT s m) +instance (InternalAncestorRegion pr cr) ⇒ InternalAncestorRegion pr (RegionT s cr) + +-------------------------------------------------------------------------------- + +-- | The @RootRegion@ is the ancestor of any region. +-- +-- It's primary purpose is to tag regional handles which don't have an +-- associated finalizer. For example the standard file handles @stdin@, @stdout@ +-- and @stderr@ which are opened on program startup and which shouldn't be +-- closed when a region terminates. Another example is the @nullPtr@ which is a +-- memory pointer which doesn't point to any allocated memory so doesn't need to +-- be freed. +data RootRegion α + +instance InternalAncestorRegion RootRegion (RegionT s m) -------------------------------------------------------------------------------- diff --git a/Control/Monad/Trans/Region/OnExit.hs b/Control/Monad/Trans/Region/OnExit.hs --- a/Control/Monad/Trans/Region/OnExit.hs +++ b/Control/Monad/Trans/Region/OnExit.hs @@ -12,12 +12,12 @@ -- -------------------------------------------------------------------------------- -module Control.Monad.Trans.Region.OnExit ( CloseAction - , CloseHandle +module Control.Monad.Trans.Region.OnExit ( Finalizer + , FinalizerHandle , onExit ) where -import Control.Monad.Trans.Region.Internal ( CloseAction - , CloseHandle +import Control.Monad.Trans.Region.Internal ( Finalizer + , FinalizerHandle , onExit ) diff --git a/Control/Monad/Trans/Region/ParentOf.hs b/Control/Monad/Trans/Region/ParentOf.hs deleted file mode 100644 --- a/Control/Monad/Trans/Region/ParentOf.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE UnicodeSyntax - , NoImplicitPrelude - , KindSignatures - , MultiParamTypeClasses - , FunctionalDependencies - , UndecidableInstances - , FlexibleInstances - , OverlappingInstances - #-} - -------------------------------------------------------------------------------- --- | --- Module : Control.Monad.Trans.Region.ParentOf --- Copyright : (c) 2009-2010 Bas van Dijk --- License : BSD3 (see the file LICENSE) --- Maintainer : Bas van Dijk --- --------------------------------------------------------------------------------- - -module Control.Monad.Trans.Region.ParentOf ( ParentOf ) where - --- from base: -import Control.Monad ( Monad ) - --- from regions: -import Control.Monad.Trans.Region.Internal ( RegionT ) - - -{-| The @ParentOf@ class declares the parent/child relationship between regions. - -A region is the parent of another region if they're either equivalent like: - -@ -RegionT ps pr \`ParentOf\` RegionT ps pr -@ - -or if it is the parent of the parent of the child like: - -@ -RegionT ps ppr \`ParentOf\` RegionT cs - (RegionT pcs - (RegionT ppcs - (RegionT ps ppr))) -@ --} -class (Monad pr, Monad cr) ⇒ pr `ParentOf` cr - -instance Monad r ⇒ ParentOf r r - -instance ( Monad cr - , cr `TypeCast2` RegionT s pcr - , pr `ParentOf` pcr - ) - ⇒ ParentOf pr cr - - --------------------------------------------------------------------------------- --- Type casting --------------------------------------------------------------------------------- - -class TypeCast2 (a ∷ * → *) (b ∷ * → *) | a → b, b → a -class TypeCast2' t (a ∷ * → *) (b ∷ * → *) | t a → b, t b → a -class TypeCast2'' t (a ∷ * → *) (b ∷ * → *) | t a → b, t b → a - -instance TypeCast2' () a b ⇒ TypeCast2 a b -instance TypeCast2'' t a b ⇒ TypeCast2' t a b -instance TypeCast2'' () a a - - --- The End --------------------------------------------------------------------- diff --git a/Data/RegionRef.hs b/Data/RegionRef.hs --- a/Data/RegionRef.hs +++ b/Data/RegionRef.hs @@ -44,7 +44,7 @@ import Control.Monad.IO.Class ( MonadIO, liftIO ) -- from ourselves: -import Control.Monad.Trans.Region ( RegionT, ParentOf ) +import Control.Monad.Trans.Region ( RegionT, AncestorRegion ) -------------------------------------------------------------------------------- @@ -75,18 +75,18 @@ newRegionRef = liftM RegionRef ∘ liftIO ∘ newIORef -- | Read the value of the given regional reference. -readRegionRef ∷ (pr `ParentOf` cr, MonadIO cr) +readRegionRef ∷ (pr `AncestorRegion` cr, MonadIO cr) ⇒ RegionRef pr α → cr α readRegionRef = liftIO ∘ readIORef ∘ unRegionRef -- | Write a new value into the given regional reference. -writeRegionRef ∷ (pr `ParentOf` cr, MonadIO cr) +writeRegionRef ∷ (pr `AncestorRegion` cr, MonadIO cr) ⇒ RegionRef pr α → α → cr () writeRegionRef ref x = liftIO $ writeIORef (unRegionRef ref) x -- | Mutate the contents of the given regional reference using the given -- function. -modifyRegionRef ∷ (pr `ParentOf` cr, MonadIO cr) +modifyRegionRef ∷ (pr `AncestorRegion` cr, MonadIO cr) ⇒ RegionRef pr α → (α → α) → cr () modifyRegionRef ref f = liftIO $ modifyIORef (unRegionRef ref) f @@ -97,7 +97,7 @@ multithreaded program. If you only have one regional reference, then using @atomicModifyRegionRef@ to access and modify it will prevent race conditions. -} -atomicModifyRegionRef ∷ (pr `ParentOf` cr, MonadIO cr) +atomicModifyRegionRef ∷ (pr `AncestorRegion` cr, MonadIO cr) ⇒ RegionRef pr α → (α → (α, β)) → cr β atomicModifyRegionRef ref f = liftIO $ atomicModifyIORef (unRegionRef ref) f diff --git a/regions.cabal b/regions.cabal --- a/regions.cabal +++ b/regions.cabal @@ -1,5 +1,5 @@ name: regions -version: 0.7.0.1 +version: 0.8 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -36,12 +36,12 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , transformers >= 0.2 && < 0.3 - , MonadCatchIO-transformers >= 0.2 && < 0.3 + build-depends: base >= 4 && < 4.4 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , transformers >= 0.2 && < 0.3 + , monad-peel >= 0.1 && < 0.2 exposed-modules: Control.Monad.Trans.Region - Control.Monad.Trans.Region.ParentOf + Control.Monad.Trans.Region.Concurrent Control.Monad.Trans.Region.OnExit Data.RegionRef other-modules: Control.Monad.Trans.Region.Internal