IOR (empty) → 0.1

raw patch · 10 files changed

+506/−0 lines, 10 filesdep +basedep +mtlsetup-changed

Dependencies added: base, mtl

Files

COPYING +25/−0
IOR.cabal +25/−0
README +24/−0
Setup.lhs +3/−0
src/Data/IORRef.hs +57/−0
src/Example.hs +60/−0
src/System/IOR.hs +35/−0
src/System/IOR/Internal.hs +175/−0
src/System/IOR/Resource.hs +58/−0
src/Test.hs +44/−0

+ COPYING view

@@ -0,0 +1,25 @@+Copyright (c) 2008, Ivan Tomac+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.+    * Neither the name of the author nor the names of the contributors may 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.

+ IOR.cabal view

@@ -0,0 +1,25 @@+name:               IOR+version:            0.1+synopsis:           Region based resource management for the IO monad.+description:        IOR monad is a wrapper around IO that allows region based+                    resource management.+category:           System, Monadic Regions+cabal-version:   >= 1.2+license:            BSD3+license-file:       COPYING+author:             Ivan Tomac+maintainer:         tomac `at` pacific `dot` net `dot` au+stability:          experimental+build-type:         Simple+data-files:         README+extra-source-files: src/Example.hs+                    src/Test.hs++library+  build-depends:        base, mtl+  ghc-options:          -Wall+  hs-source-dirs:       src+  exposed-modules:      Data.IORRef+                        System.IOR+                        System.IOR.Resource+  other-modules:        System.IOR.Internal

+ README view

@@ -0,0 +1,24 @@+To build the library type++    runhaskell Setup.lhs configure+    runhaskell Setup.lhs build+    runhaskell Setup.lhs haddock    # optional+    runhaskell Setup.lhs install++There are a few tests and examples in the src directory.++TODOs:+-----++It may be possible (and worthwhile) to write a more general region monad that+is not tied to IO. I've had a brief look into this but right now I can't find+a clean and consistent way to abstract mutable references for different+monads.++It would also be nice to provide all the functions found in System.IO ideally+in such a way so the functions can be used with either Strings, ByteStrings or+something else.+I can't think of a clean way to do this either. Any suggestions would be+welcome.++Ivan Tomac 25/05/2008

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ src/Data/IORRef.hs view

@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable #-}++-------------------------------------------------------------------------------+-- |+-- Module       : Data.IORRef+-- Copyright    : (c) Ivan Tomac 2008+-- License      : BSD3+--+-- Maintainer   : tomac `at` pacific `dot` net `dot` au+-- Stability    : experimental+--+-- Mutable references in the IOR monad.+--+-------------------------------------------------------------------------------++module Data.IORRef (+    IORRef++  , newIORRef+  , readIORRef+  , writeIORRef+  , modifyIORRef+) where++import Control.Monad.Trans++import Data.Generics+import Data.IORef++import System.IOR++-- | A value of type @'IORRef' r a@ is a mutable variable in region @r@,+-- containing a value of type @a@.++newtype IORRef r a+  = IORRef { unIORRef :: IORef a }+    deriving (Data, Eq, Typeable)++-- | Create a new 'IORRef' in region @r@.++newIORRef :: a -> IOR r rs (IORRef r a)+newIORRef = liftIO . fmap IORRef . newIORef++-- | Read the value of an 'IORRef'.++readIORRef :: RElem r' rs => IORRef r' a -> IOR r rs a +readIORRef = liftIO . readIORef . unIORRef++-- | Write a new value into an 'IORRef'.++writeIORRef :: RElem r' rs => IORRef r' a -> a -> IOR r rs ()+writeIORRef = (liftIO .) . writeIORef . unIORRef++-- | Mutate the contents of an 'IORRef'.++modifyIORRef :: RElem r' rs => IORRef r' a -> (a -> a) -> IOR r rs ()+modifyIORRef = (liftIO .) . modifyIORef . unIORRef

+ src/Example.hs view

@@ -0,0 +1,60 @@+module Main where++import Control.Monad.Trans++import System.IOR+import System.IOR.Resource++-------------------------------------------------------------------------------++newtype P+  = P String++openP  :: String -> IO P+closeP :: P -> IO ()+writeP :: P -> String -> IO ()++openP s = do+    putStrLn ("opening " ++ s)+    return   (P s)++closeP (P s) =+    putStrLn ("closing " ++ s)++writeP (P s) msg =+    putStrLn ("writing " ++ msg ++ " to " ++ s)++-------------------------------------------------------------------------------++newtype R r+  = R (Resource r P)++openR  :: String -> IOR r rs (R r)+closeR :: RElem r' rs => R r' -> IOR r rs ()+writeR :: RElem r' rs => R r' -> String -> IOR r rs ()++openR s = do+    p <- liftIO (openP s)+    fmap R (manage p closeP)++closeR (R r) =+    release r++writeR (R r) msg =+    liftIO (writeP (getResource r) msg)++-------------------------------------------------------------------------------++main :: IO ()+main = runIOR $ do+    r     <- getIORTag+    res1a <- openR "res1a"+    res1b <- openR "res1b"+    newIOR $ do+        res2a <- openR "res2a"+        res1c <- withIORTag r $ openR "res1c"+        writeR res1b "msg1"+        closeR res1b+        writeR res1c "msg2"+        writeR res2a "msg3"+    writeR res1a "msg4"

+ src/System/IOR.hs view

@@ -0,0 +1,35 @@+-------------------------------------------------------------------------------+-- |+-- Module       : System.IOR+-- Copyright    : (c) Ivan Tomac 2008+-- License      : BSD3+--+-- Maintainer   : tomac `at` pacific `dot` net `dot` au+-- Stability    : experimental+--+-- Region based resource management for the IO monad.+-- Based on the ideas and code from+-- <http://okmij.org/ftp/Haskell/regions.html>+--+-------------------------------------------------------------------------------++module System.IOR (+    -- * Type Classes and Auxiliary Data Types+    RElem+  , RCons+  , RNil++    -- * IOR Monad+  , IOR++  , runIOR+  , newIOR++    -- * Region Tags+  , IORTag++  , getIORTag+  , withIORTag+) where++import System.IOR.Internal

+ src/System/IOR/Internal.hs view

@@ -0,0 +1,175 @@+{-# 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

+ src/System/IOR/Resource.hs view

@@ -0,0 +1,58 @@+-------------------------------------------------------------------------------+-- |+-- Module       : System.IOR.Resource+-- Copyright    : (c) Ivan Tomac 2008+-- License      : BSD3+--+-- Maintainer   : tomac `at` pacific `dot` net `dot` au+-- Stability    : experimental+--+-- Resource management in the IOR monad.+--+-------------------------------------------------------------------------------++module System.IOR.Resource (+    Resource+  , getResource++  , manage+  , release+) where++import Control.Arrow+import Control.Monad.Trans++import Data.IORef+import Data.List++import System.IOR.Internal++-- | @'manage' a f@ will create a new 'Resource' wrapper around the+-- value of type @a@ in region @r@, given a finalizer @f@.+-- Each finalizer is guaranteed to automatically be called upon exit from+-- the region.+-- Finalizers are called in the last in, first out fashion. So the finalizer+-- of the very last resource allocated will be the first to get called.+--+-- Note that finalizers must not throw any errors. Failing to ensure that+-- all errors in a finalizer are handled may result in a resource leak.++manage :: a -> (a -> IO ()) -> IOR r rs (Resource r a)+manage a f = IOR (new . unIORTag)+    where+        new ref = do+            (c, rs) <- readIORef ref+            let r = Resource a c ref (f a)+            writeIORef ref (succ c, Resource' r : rs)+            return r++-- | @'release' res@ is used to force the resource @res@ to be+-- released immediately. Finalizer for @res@ will be called and removed+-- from the stack of finalizers in region @r'@.++release :: RElem r' rs => Resource r' a -> IOR r rs ()+release r = liftIO $ do+    readIORef ref >>= writeIORef ref . (id *** delete (Resource' r))+    finalizer r+    where+        ref = tagRef r

+ src/Test.hs view

@@ -0,0 +1,44 @@+module Main where++import Control.Applicative+import Control.Monad++import Data.IORRef++import System.IOR++gpair :: (RElem r0 rs, RElem r1 rs)+      => IORRef r0 a -> IORRef r1 b -> IOR r rs (IORRef r (a, b))++test1 :: IO ()+test2 :: IO ()+test3 :: IO ()+main  :: IO ()++gpair v w = liftA2 (,) (readIORRef v) (readIORRef w) >>= newIORRef++test1 = (print =<<) $ runIOR $ do+    r1 <- getIORTag+    a  <- newIORRef 1+    c  <- newIOR $ do+        v  <- readIORRef a+        b  <- newIORRef 2+        v' <- readIORRef b+        withIORTag r1 (newIORRef $ v + v')+    readIORRef c++test2 = (print =<<) $ runIOR $ do+    v <- newIORRef 1+    newIOR $ do+        w  <- newIORRef 2+        liftA2 (,)+               (gpair v w >>= readIORRef)+               (gpair w v >>= readIORRef)++test3 = (print =<<) $ runIOR $+    newIOR (newIORRef 1 >>= join gpair >>= readIORRef)++main = do+    test1+    test2+    test3