packages feed

resource-effect (empty) → 0.1.0

raw patch · 5 files changed

+242/−0 lines, 5 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, containers, extensible-effects, mtl, resource-effect, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Clark Gaebel++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 Clark Gaebel nor the names of other+      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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resource-effect.cabal view
@@ -0,0 +1,51 @@+-- Initial resource-effect.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                resource-effect+version:             0.1.0+synopsis:            A port of the package 'resourcet' for extensible effects.+description:         +homepage:            https://github.com/wowus/resource-effect/+license:             BSD3+license-file:        LICENSE+author:              Clark Gaebel+maintainer:          cgaebel@uwaterloo.ca+category:            Effect, Control+build-type:          Simple+cabal-version:       >=1.10++library+  ghc-options:         -Wall+  exposed-modules:     Control.Eff.Resource++  build-depends:       base == 4.6.*+                     , containers == 0.5.*+                     , extensible-effects == 1.2.*++  hs-source-dirs:      src/+  default-language:    Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Test.hs+  hs-source-dirs: test/++  ghc-options: -rtsopts=all -threaded++  build-depends:+      base == 4.6.*+    , QuickCheck == 2.*+    , HUnit == 1.2.*+    , test-framework == 0.8.*+    , test-framework-hunit == 0.3.*+    , test-framework-quickcheck2 == 0.3.*+    , containers == 0.5.*+    , extensible-effects == 1.2.*+    , mtl == 2.1.*+    , resource-effect++  default-language:    Haskell2010++source-repository head+  type: git+  location: https://github.com/wowus/resource-effect/
+ src/Control/Eff/Resource.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Trustworthy #-}+-- | Allocate resources which are guaranteed to be released.+--+--   For more information, see the @resourcet@ package.+module Control.Eff.Resource ( Resource+                            , ResourceState+                            , ReleaseKey+                            , runResource+                            , allocate+                            , register+                            , release+                            , unprotect+                            ) where++import Control.Eff+import Control.Eff.Lift+import Control.Eff.State.Strict++import Data.IntMap.Strict ( IntMap )+import qualified Data.IntMap.Strict as M+import Data.Typeable++-- | A resource's state. Type parameter @m@ is the Monad the resource+--   deallocation will run in.+data ResourceState m =+        ResourceState+          {-# UNPACK #-} !Int  -- ^ The 'next' int to insert.+          !(IntMap m) -- ^ A map of cleanup handlers.+  deriving Typeable++-- | The Resource effect. This effect keeps track of all registered actions,+--   and calls them upon exit (via 'runResource'). Actions may be registered+--   via register, or resources may be allocated atomically via allocate.+--   allocate corresponds closely to bracket.+--+--   Releasing may be performed before exit via the release function. This+--   is a highly recommended optimization, as it will ensure that scarce+--   resources are freed early. Note that calling release will deregister+--   the action, so that a release action will only ever be called once. +type Resource m = State (ResourceState m)++-- | A lookup key for a specific release action. This value+--   is returned by @register@ and @allocate@, and is passed to @release@.+newtype ReleaseKey = K Int+    deriving Typeable++withState :: (Typeable s, Member (State s) r)+          => (s -> Eff r (s, a))+          -> Eff r a+withState f = do+  oldState <- get+  (newState, ret) <- f oldState+  put newState+  return ret+{-# INLINE withState #-}++-- | Call a release action early, and deregister it from the list of+--   cleanup actions to be performed.+release :: (Typeable1 m, SetMember Lift (Lift m) r, Member (Resource (m ())) r)+        => ReleaseKey+        -> Eff r ()+release (K k) = withState $ \old@(ResourceState cnt m) ->+  case M.lookup k m of+    Nothing      -> return (old, ())+    Just cleanup -> do+      () <- lift cleanup+      return (ResourceState cnt (M.delete k m), ())+{-# INLINE release #-}++-- | Register some action that will be called precisely once, either when+--   'runResource' is called or when the 'ReleaseKey' is passed to 'release'.+register :: (Typeable1 m, Member (Resource (m ())) r)+         => m ()+         -> Eff r ReleaseKey+register cleanup =+  withState $ \(ResourceState cnt oldMap) ->+    return (ResourceState (cnt+1) (M.insert cnt cleanup oldMap), K cnt)+{-# INLINE register #-}++-- | Perform some allocation, and automatically register a cleanup action.+allocate :: (Typeable1 m, Monad m, Member (Resource (m ())) r, SetMember Lift (Lift m) r)+         => m a         -- ^ allocate+         -> (a -> m ()) -- ^ free resource+         -> Eff r (ReleaseKey, a)+allocate alloc dealloc = do+  res <- lift alloc -- TODO: Protect against asynchronous exceptions. Patches welcome!+  k   <- register (dealloc res)+  return (k, res)+{-# INLINE allocate #-}++-- | Unprotect resource from cleanup actions, this allowes you to send+--   resource into another resourcet process and reregister it there.+--+--   It returns an release action that should be run in order to clean+--   resource or Nothing in case if resource is already freed. +unprotect :: (Typeable1 m, Member (Resource (m ())) r)+          => ReleaseKey+          -> Eff r (Maybe (m ()))+unprotect (K k) =+  withState $ \old@(ResourceState cnt oldMap) ->+    case M.lookup k oldMap of+      Nothing    -> return (old, Nothing)+      v@(Just _) -> return (ResourceState cnt (M.delete k oldMap), v)+{-# INLINE unprotect #-}++-- | Unwrap a 'Resource' effect, and call all registered release actions. +runResource :: (Typeable1 m, Monad m, SetMember Lift (Lift m) r)+            => Eff (Resource (m ()) :> r) a+            -> Eff r a+runResource eff = do+  (ResourceState _ toClean, res) <- runState (ResourceState 0 M.empty) eff+  lift $ mapM_ snd (M.toDescList toClean)+  return res+{-# INLINE runResource #-}
+ test/Test.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Main ( main ) where++import Control.Concurrent.MVar+import Control.Exception (Exception, ErrorCall, catch)+import Control.Monad (void)+import Data.Functor+import Data.Typeable++import Test.Framework ( defaultMain, testGroup, Test )+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++import Test.HUnit hiding ( Test, State )+import Test.QuickCheck+import Test.QuickCheck.Property++import Control.Eff+import Control.Eff.Lift+import Control.Eff.Resource++main :: IO ()+main = defaultMain tests++statefulResourceTest :: Integer -> Property+statefulResourceTest x = morallyDubiousIOProperty $ do+  m <- newMVar True+  v <- runLift $ runResource $ do+                let alloc = swapMVar m False+                    dealloc old = () <$ swapMVar m old+                (k, v) <- allocate alloc dealloc+                return v+  mv <- takeMVar m+  return $ v && mv++tests :: [Test]+tests = [+    testProperty "stateful resource" statefulResourceTest+  ]