diff --git a/Control/Monad/Trans/Region.hs b/Control/Monad/Trans/Region.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Region.hs @@ -0,0 +1,37 @@ + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Region +-- Copyright : (c) 2009 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This modules implements a technique called /"Lightweight monadic regions"/ +-- invented by Oleg Kiselyov and Chung-chieh Shan +-- +-- See: +-- +-------------------------------------------------------------------------------- + +module Control.Monad.Trans.Region + ( -- * Regions + RegionT + + -- * Running regions + , runRegionT + + , TopRegion + , runTopRegion + , forkTopRegion + + -- * Opening resources + , RegionalHandle + , open + + , with + + -- * Duplication + , dup + ) where + +import Control.Monad.Trans.Region.Internal diff --git a/Control/Monad/Trans/Region/Internal.hs b/Control/Monad/Trans/Region/Internal.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Region/Internal.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Region.Internal +-- Copyright : (c) 2009 Bas van Dijk +-- License : BSD3 (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- This modules implements a technique called /"Lightweight monadic regions"/ +-- invented by Oleg Kiselyov and Chung-chieh Shan +-- +-- See: +-- +-- This module should only be used by library authors wishing to allow their +-- users to open their type of resources in a region. It should not be used by +-- end-users directly! +-- +-- To create a module or library that allows your users to open your type of +-- resources in a region is to define an instance for 'Resource' for your type +-- of resource. +-- +-- Make sure not to re-export anything from this module. Either re-export things +-- from @Control.Monad.Trans.Region@ or tell your users to import that module +-- directly. +-- +-------------------------------------------------------------------------------- + +module Control.Monad.Trans.Region.Internal + ( -- * Scarce resources + Resource + , Handle + , openResource + , closeResource + + -- * Regions + , RegionT + + -- * Running regions + , runRegionT + + , TopRegion + , runTopRegion + , forkTopRegion + + -- * Opening resources + , RegionalHandle + , internalHandle + , open + + , with + + -- * Duplication + , Dup + , dup + + -- * Handy functions for writing monadic instances + , mapRegionT + , liftCatch + -- | /TODO: define and export: /@liftCallCC@ + + -- * Parent/child relationship between regions. + , ParentOf + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Control.Concurrent ( forkIO, ThreadId ) +import Control.Applicative ( Applicative, Alternative ) +import Control.Monad ( when, liftM2, MonadPlus ) +import Control.Monad.Fix ( MonadFix ) +import Data.IORef ( IORef, newIORef + , readIORef, modifyIORef, atomicModifyIORef + ) +-- from MonadCatchIO-transformers: +import Control.Monad.CatchIO ( MonadCatchIO, block, bracket ) + +-- from transformers: +import Control.Monad.Trans ( MonadTrans, lift, MonadIO, liftIO ) + +import qualified Control.Monad.Trans.Reader as Reader ( liftCatch ) +import Control.Monad.Trans.Reader ( ReaderT + , ask + , runReaderT, mapReaderT + ) +-- from unicode-symbols: +import Prelude.Unicode ( (∘), (≡) ) + + +-------------------------------------------------------------------------------- +-- * Scarce resources +-------------------------------------------------------------------------------- + +{-| Class of /scarce/ resources. A scarce resource is a resource that only one +user can use at a time. (like a file, memory pointer or USB device for +example). + +Because of the scarcity, these resources need to be /opened/ to grant temporary +sole access to the resource. When the resource is no longer needed it should be +/closed/ a.s.a.p to grant others access to the resource. +-} +class Resource resource where + data Handle resource ∷ * + + openResource ∷ resource → IO (Handle resource) + closeResource ∷ Handle resource → IO () + + +-------------------------------------------------------------------------------- +-- * Regions +-------------------------------------------------------------------------------- + +{-| A monad transformer in which resources of type @resource@ 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'. +-} +newtype RegionT resource s (pr ∷ * → *) α = RegionT + { unRegionT :: ReaderT (IORef [Opened resource]) pr α } + + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadTrans + , MonadIO + , MonadCatchIO + ) + +data Opened resource = Opened { openedHandle ∷ Handle resource + , refCntIORef ∷ IORef Int + } + +decrement ∷ IORef Int → IO Int +decrement ioRef = atomicModifyIORef ioRef $ \refCnt → + let predRefCnt = pred refCnt + in (predRefCnt, predRefCnt) + +increment ∷ IORef Int → IO () +increment ioRef = atomicModifyIORef ioRef $ \refCnt → + (succ refCnt, ()) + + +-------------------------------------------------------------------------------- +-- * Running regions +-------------------------------------------------------------------------------- + +{-| Execute a region inside its parent region @pr@. + +All resources which have been opened in the given region using 'open', and which +haven't been duplicated using 'dup', will be closed on exit from this function +wether by normal termination or by raising an exception. + +Also all resources which have been duplicated to this region from a child region +are closed on exit if they haven't been duplicated themselves. + +Note the type variable @s@ of the region wich is only quantified over the region +itself. This ensures that /all/ values, having a type containing @s@, can /not/ +be returned from this function. (Note the similarity with the @ST@ monad.) + +An example of such a value is a 'RegionalHandle'. Regional handles are created by +opening a resource in a region using 'open'. Regional handles are parameterized by +the region in which they were created. So regional handles have this @s@ in their +type. This ensures that these regional handles, which may have been closed on exit +from this function, can't be returned from this function. This ensures you can +never do any IO with a closed regional handle. + +Note that it is possible to run a region inside another region. +-} +runRegionT ∷ (Resource resource, MonadCatchIO pr) + ⇒ (∀ s. RegionT resource s pr α) -- ^ Region you wish to execute. + → pr α -- ^ Computation in the parent region which executes the given + -- region. +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 'forkTopRegion'. +-} +type TopRegion resource s = RegionT resource s IO + +{-| Convenience funtion for running a /top-level/ region in 'IO'. + +Note that: @runTopRegion = 'runRegionT'@ +-} +runTopRegion ∷ Resource resource + ⇒ (∀ s. TopRegion resource s α) + -- ^ /Top-level/ region you wish to execute. + → IO α -- ^ An @IO@ computation which executes the given region. +runTopRegion = runRegionT + +{-| Return a region which executes the given /top-level/ 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 +region (like 'RegionalHandle's for example) can also be referenced in the forked +region. + +For example the following is allowed: + +@ +runRegionT $ do + regionalHndl <- open resource + threadId <- forkTopRegion $ doSomethingWith regionalHndl + doSomethingElseWith regionalHndl +@ + +Note that the @regionalHndl@ and all other resources opened in the current +thread are closed only when the current thread or the forked thread terminates +whichever comes /last/. +-} +forkTopRegion ∷ (Resource resource, MonadIO pr) + ⇒ TopRegion resource s () -- ^ /Top-level/ region you wish to + -- execute in a new thread. + → RegionT resource s pr ThreadId + -- ^ A regional computation that executes the given region in a + -- new thread and returns the @ThreadId@ of this new thread. +forkTopRegion m = RegionT $ do + openedResourcesIORef ← ask + liftIO $ do openedResources ← readIORef openedResourcesIORef + block $ do mapM_ (increment ∘ refCntIORef) openedResources + forkIO $ runRegionWith openedResources m + +runRegionWith ∷ ∀ resource s pr α. + (MonadCatchIO pr, Resource resource) + ⇒ [Opened resource] + → RegionT resource s pr α + → pr α +runRegionWith openedResources m = + bracket (liftIO $ newIORef openedResources) + (\openedResourcesIORef → liftIO $ readIORef openedResourcesIORef >>= + mapM_ closeOpenedResource) + (runReaderT $ unRegionT m) + where + closeOpenedResource ∷ Opened resource → IO () + closeOpenedResource openedResource = do + refCnt ← decrement $ refCntIORef openedResource + when (refCnt ≡ 0) $ closeResource $ openedHandle $ openedResource + + +-------------------------------------------------------------------------------- +-- * Opening resources +-------------------------------------------------------------------------------- + +-- | A handle to an opened resource parameterized by the @resource@ and the +-- region @r@ in which it was created. +newtype RegionalHandle resource (r ∷ * → *) = RegionalHandle + { unRegionalHandle ∷ Opened resource } + +{-| Get the internal handle from the regional handle. + +This function should not be exported to end-users because it allows them to +close the handle manually! +-} +internalHandle ∷ RegionalHandle resource r → Handle resource +internalHandle = openedHandle ∘ unRegionalHandle + +{-| Open the given resource in a region yielding a regional handle to it. + +Note that the returned regional handle is parameterized by the region in which +it was created. This ensures that regional handles can never escape their +region. And it also allows operations on regional handles to be executed in a +child region of the region in which the regional handle was created. + +Note that if you wish to return a regional handle from the region in which it +was created you have to duplicate the handle by applying 'dup' to it. +-} +open ∷ (Resource resource, MonadCatchIO pr) + ⇒ resource -- ^ The resource you wish to open. + → RegionT resource s pr + (RegionalHandle resource (RegionT resource s pr)) + -- ^ A regional computation that returns a regional handle to the given + -- opened resource parameterized by the region itself. +open resource = + RegionT $ block $ do + openedResource ← liftIO $ liftM2 Opened (openResource resource) + (newIORef 1) + registerOpenedResource openedResource + return $ RegionalHandle openedResource + +{-| A convenience function which opens the given resource, applies the given +continuation function to the resulting regional handle and runs the resulting +region. + +Note that: @with dev f = @'runRegionT'@ (@'open'@ dev @'>>='@ f)@ +-} +with ∷ (Resource resource, MonadCatchIO pr) + ⇒ resource -- ^ The resource you wish to open. + → (∀ s. RegionalHandle resource (RegionT resource s pr) + → RegionT resource s pr α + ) -- ^ Continuation function. + → pr α -- ^ A computation which runs a child region which opens the given + -- resource and applies the given continuation function to the + -- resulting regional handle. +with resource f = runRegionT $ open resource >>= f + +registerOpenedResource ∷ (Resource resource, MonadIO pr1) + ⇒ Opened resource + → ReaderT (IORef [Opened resource]) pr1 () +registerOpenedResource openedResource = do + openedResourcesIORef ← ask + liftIO $ modifyIORef openedResourcesIORef (openedResource:) + + +-------------------------------------------------------------------------------- +-- * Duplication +-------------------------------------------------------------------------------- + +{-| Duplicate an @α@ in the parent region. This @α@ will usually be a +@(@'RegionalHandle'@ resource)@ but it can be any value \"derived\" from this +regional handle. + +For example, suppose you run the following region: + +@ +runRegionT $ do +@ + +Inside this region you run a nested /child/ region like: + +@ + r1hDup <- runRegionT $ do +@ + +Now in this child region you open the resource @r1@: + +@ + r1h <- open r1 +@ + +...yielding the regional handle @r1h@. Note that: + +@r1h :: RegionalHandle resource (RegionT resource cs (RegionT resource ps ppr))@ + +where @cs@ is bound by the inner (child) @runRegionT@ and @ps@ is +bound by the outer (parent) @runRegionT@. + +Suppose you want to use the resulting regional handle @r1h@ in the /parent/ device +region. You can't simply @return r1h@ because then the type variable @cs@, +escapes the inner region. + +However, if you duplicate the regional handle you can safely return it. + +@ + r1hDup <- dup r1h + return r1hDup +@ + +Note that @r1hDup :: RegionalHandle resource (RegionT resource ps ppr)@ + +Back in the parent region you can safely operate on @r1hDup@. +-} +class Resource resource ⇒ Dup α resource where + dup ∷ (MonadCatchIO ppr) + ⇒ α (RegionT resource cs (RegionT resource ps ppr)) -- ^ Something created in a child region. + → RegionT resource cs (RegionT resource ps ppr) + (α (RegionT resource ps ppr))-- ^ The child region which returns the thing which can now be used in the parent region. + +instance Resource resource ⇒ Dup (RegionalHandle resource) resource where + dup (RegionalHandle openedResource) = RegionT $ + block $ do liftIO $ increment $ refCntIORef openedResource + lift $ RegionT $ registerOpenedResource openedResource + return $ RegionalHandle openedResource + + +-------------------------------------------------------------------------------- +-- * Handy functions for writing monadic instances +-------------------------------------------------------------------------------- + +-- TODO: +-- -- | Lift a @callCC@ operation to the new monad. +-- liftCallCC ∷ (((α → pr β) → pr α) → pr α) -- ^ @callCC@ on the argument monad. +-- → ((α → RegionT s pr β) → RegionT s pr α) +-- → RegionT s pr α +-- liftCallCC callCC f = RegionT $ ??? + +-- | Transform the computation inside a region. +mapRegionT ∷ (m α → n β) → RegionT resource s m α → RegionT resource s n β +mapRegionT f = RegionT ∘ mapReaderT f ∘ unRegionT + +-- | Lift a 'catchError' operation to the new monad. +liftCatch ∷ (pr α → (e → pr α) → pr α) -- ^ @catch@ on the argument monad. + → RegionT resource s pr α -- ^ Computation to attempt. + → (e → RegionT resource s pr α) -- ^ Exception handler. + → RegionT resource s pr α +liftCatch f m h = RegionT $ Reader.liftCatch f (unRegionT m) (unRegionT ∘ h) + + +-------------------------------------------------------------------------------- +-- * Parent/child relationship between regions. +-------------------------------------------------------------------------------- + +{-| 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 resource ps pr \`ParentOf\` RegionT resource ps pr +@ + +or if it is the parent of the parent of the child like: + +@ +RegionT resource ps ppr \`ParentOf\` RegionT resource cs + (RegionT resource pcs + (RegionT resource ppcs + (RegionT resource ps ppr))) +@ +-} +class (Monad pr, Monad cr) ⇒ pr `ParentOf` cr + +instance Monad r ⇒ ParentOf r r + +instance ( Monad cr + , cr `TypeCast2` RegionT resource 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009 Bas van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The name of Bas van Dijk and the names of contributors may NOT + be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/regions.cabal b/regions.cabal new file mode 100644 --- /dev/null +++ b/regions.cabal @@ -0,0 +1,67 @@ +name: regions +version: 0.1 +cabal-version: >=1.6 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2009 Bas van Dijk +author: Bas van Dijk +maintainer: Bas van Dijk +stability: experimental +category: Control +synopsis: Provides the region monad for safely opening and working with + scarce resources. +description: + + This package provides the region monad transformer. Scarce resources like + files, memory pointers or USB devices for example can be opened in a + region. When the region terminates, all opened resources will be automatically + closed. The main advantage of regions is that the opened resources can not be + returned from the region which ensures no I/O with closed resources is + possible. + + . + + The primary technique used in this package is called \"Lightweight monadic + regions\" which was invented by Oleg Kiselyov and Chung-chieh Shan. See: + + . + + + + . + + This package provides two modules: + + . + + * @Control.Monad.Trans.Region.Internal@ should only be used by library authors + wishing to allow their users to open their type of resources in a region. It + should not be used by end-users directly! + + . + + * @Control.Monad.Trans.Region@ provides the public and safe interface to + regions which can be used by end-users. + + . + + Also see the @regions-monadsfd@ and @regions-monadstf@ packages which provide + instances for the classes in the respected monads packages. + + . + + For an example of how to use this library see the @usb-safe@ package. + +source-repository head + Type: darcs + Location: http://code.haskell.org/~basvandijk/code/regions + +Library + GHC-Options: -O2 -Wall + build-depends: base >= 4 && < 4.2 + , unicode-symbols == 0.1.* + , transformers >= 0.1.4 && < 0.2 + , MonadCatchIO-transformers == 0.0.2.* + exposed-modules: Control.Monad.Trans.Region + , Control.Monad.Trans.Region.Internal