resource-effectful (empty) → 0.1.0.0

raw patch · 5 files changed

+289/−0 lines, 5 filesdep +basedep +effectful-coredep +stm

Dependencies added: base, effectful-core, stm

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +5/−0
resource-effectful.cabal +33/−0
src/Effectful/Resource.hs +216/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for resource-effectful
+
+## 0.1.0.0 -- 2023-05-12
+
+* Initial release.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2023, Michael Szvetits
+
+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 Michael Szvetits 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.

+ README.md view

@@ -0,0 +1,5 @@+# resource-effectful
+
+[![Hackage](https://img.shields.io/hackage/v/resource-effectful.svg?logo=haskell&label=resource-effectful)](https://hackage.haskell.org/package/resource-effectful)
+
+`resource-effectful` is a Haskell library that provides a region-based resource effect for the [effectful](https://hackage.haskell.org/package/effectful-core) ecosystem. The documentation can be found on [Hackage](https://hackage.haskell.org/package/resource-effectful).

+ resource-effectful.cabal view

@@ -0,0 +1,33 @@+cabal-version:   3.0
+name:            resource-effectful
+version:         0.1.0.0
+synopsis:        A region-based resource effect for the effectful ecosystem.
+description:     Please see the README on GitHub at <https://github.com/typedbyte/resource-effectful#readme>
+homepage:        https://github.com/typedbyte/resource-effectful
+bug-reports:     https://github.com/typedbyte/resource-effectful/issues
+license:         BSD-3-Clause
+license-file:    LICENSE
+author:          Michael Szvetits
+maintainer:      typedbyte@qualified.name
+copyright:       2023 Michael Szvetits
+category:        Control
+build-type:      Simple
+extra-doc-files:
+  CHANGELOG.md
+  README.md
+
+common shared-properties
+  default-language: GHC2021
+  build-depends:
+      base >= 4.16.0 && < 5
+  ghc-options:
+      -Wall
+
+library
+  import: shared-properties
+  hs-source-dirs: src
+  build-depends:
+      effectful-core >= 2.0 && < 2.3
+    , stm            >= 2.5 && < 2.6
+  exposed-modules:
+      Effectful.Resource

+ src/Effectful/Resource.hs view

@@ -0,0 +1,216 @@+{-# LANGUAGE DataKinds    #-}
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Effectful.Resource
+-- Copyright   : (c) Michael Szvetits, 2023
+-- License     : BSD-3-Clause (see the file LICENSE)
+-- Maintainer  : typedbyte@qualified.name
+-- Stability   : stable
+-- Portability : portable
+--
+-- A region-based resource effect for the effectful ecosystem.
+-----------------------------------------------------------------------------
+module Effectful.Resource
+  ( -- * Resource Effect
+    Resource
+  , runResource
+  -- * Manage Regions
+  , Region
+  , withRegion
+  , currentRegion
+  -- * Manage Resources
+  , Key
+  , InvalidKey(..)
+  , manage
+  , allocate
+  , free
+  , freeAll
+  , move
+  , move_
+  , defer
+  ) where
+
+-- base
+import Control.Exception (Exception, bracket, finally, mask_, uninterruptibleMask_)
+import Control.Monad     (join)
+import Data.Functor      (void)
+
+-- effectful-core
+import Effectful                 (Dispatch(..), DispatchOf, Eff, Effect, IOE, (:>))
+import Effectful.Dispatch.Static (SideEffects(..), StaticRep, evalStaticRep,
+                                  getStaticRep, localStaticRep, unsafeEff_,
+                                  unsafeSeqUnliftIO)
+
+-- stm
+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar,
+                               stateTVar, throwSTM, writeTVar)
+
+-- | A region owns resources and frees them on close.
+data Region = Region
+  { resources :: TVar [(Key, IO ())]
+  , nextID    :: TVar Int
+  }
+  deriving Eq
+
+-- | Each resource is identified by a unique key.
+data Key = Key
+  { _keyID    :: Int
+  , keyRegion :: Region
+  }
+  deriving Eq
+
+open :: IO Region
+open =
+  Region
+    <$> newTVarIO []
+    <*> newTVarIO 0
+
+close :: Region -> IO ()
+close region = uninterruptibleMask_ $ do
+  rs <-
+    atomically $
+      stateTVar
+        ( resources region )
+        ( \r -> (r, []) )
+  freeList rs
+    where
+      freeList []         = pure ()
+      freeList ((_,m):ms) = m `finally` freeList ms
+
+manageIO
+  :: Region
+  -> IO a
+  -> (a -> IO ())
+  -> IO (a, Key)
+manageIO region create destroy = mask_ $ do
+  a <- create
+  atomically $ do
+    next <- readTVar idTVar
+    let key = Key next region
+    modifyTVar' idTVar succ
+    modifyTVar' rsTVar ((key, destroy a) :)
+    pure (a, key)
+  where
+    idTVar = nextID region
+    rsTVar = resources region
+
+-- | An error which occurs if a key is freed\/moved that has already been freed\/moved.
+data InvalidKey = InvalidKey
+  deriving (Eq, Ord, Show)
+
+instance Exception InvalidKey
+
+extract :: Eq k => k -> [(k,v)] -> Maybe (v, [(k,v)])
+extract k = extract' id
+  where
+    extract' _ [] = Nothing
+    extract' f (x@(k',v):xs)
+      | k == k'   = Just (v, f xs)
+      | otherwise = extract' (f . (x:)) xs
+
+moveIO :: Key -> Region -> IO Key
+moveIO key region = atomically $ do
+  rs <- readTVar keyRsTVar
+  case extract key rs of
+    Nothing -> throwSTM InvalidKey
+    Just (m, rs') -> do
+      writeTVar keyRsTVar rs'
+      next <- readTVar idTVar
+      modifyTVar' idTVar succ
+      let newKey = Key next region
+      modifyTVar' rsTVar ((newKey, m) :)
+      pure newKey
+  where
+    keyRsTVar = resources $ keyRegion key
+    idTVar    = nextID region
+    rsTVar    = resources region
+
+-- | The region-based resource effect.
+data Resource :: Effect
+
+type instance DispatchOf Resource = Static WithSideEffects
+
+newtype instance StaticRep Resource = Resource Region
+
+-- | Runs the resource effect.
+runResource :: IOE :> es => Eff (Resource : es) a -> Eff es a
+runResource m =
+  unsafeSeqUnliftIO $ \run ->
+    bracket open close $ \emptyRegion ->
+      run $
+        evalStaticRep (Resource emptyRegion) m
+
+-- | Runs a computation in a new region.
+withRegion :: Resource :> es => Eff es a -> Eff es a
+withRegion m =
+  unsafeSeqUnliftIO $ \run ->
+    bracket open close $ \emptyRegion ->
+      run $
+        localStaticRep (\_ -> Resource emptyRegion) m
+
+-- | Gets the current region.
+currentRegion :: Resource :> es => Eff es Region
+currentRegion = do
+  Resource region <- getStaticRep
+  pure region
+
+-- | Allocates a resource in the current region which can be moved and freed
+-- manually using its key.
+allocate
+  :: Resource :> es
+  => IO a            -- ^ The computation which acquires the resource.
+  -> (a -> IO b)     -- ^ The computation which releases the resource.
+  -> Eff es (a, Key) -- ^ The acquired resource and its corresponding key.
+allocate create destroy = do
+  Resource region <- getStaticRep
+  unsafeEff_ $ manageIO region create (void . destroy)
+
+-- | Allocates a resource in the current region which is automatically freed at
+-- the end of the region.
+manage
+  :: Resource :> es
+  => IO a        -- ^ The computation which acquires the resource.
+  -> (a -> IO b) -- ^ The computation which releases the resource.
+  -> Eff es a    -- ^ The acquired resource.
+manage create destroy =
+  fmap fst $ allocate create destroy
+
+-- | Moves a resource to the specified region, yielding a new key for the resource.
+-- The old key is invalid after the movement.
+move :: Resource :> es => Key -> Region -> Eff es Key
+move key region = 
+  unsafeEff_ $ moveIO key region
+
+-- | Moves a resource to the specified region. It is freed at the end of this region.
+-- The key of the moved resource is invalid after the movement.
+move_ :: Resource :> es => Key -> Region -> Eff es ()
+move_ key region =
+  void $ move key region
+
+freeIO :: Key -> IO ()
+freeIO key =
+  join . atomically $ do
+    rs <- readTVar keyRsTVar
+    case extract key rs of
+      Nothing -> throwSTM InvalidKey
+      Just (m, rs') -> do
+        writeTVar keyRsTVar rs'
+        pure m
+  where
+    keyRsTVar = resources $ keyRegion key
+{-# INLINE freeIO #-}
+
+-- | Frees a resource manually.
+free :: Key -> Eff es ()
+free = unsafeEff_ . uninterruptibleMask_ . freeIO
+
+-- | Frees a collection of resources manually.
+freeAll :: Foldable t => t Key -> Eff es ()
+freeAll = unsafeEff_ . uninterruptibleMask_ . mapM_ freeIO
+
+-- | Associats a cleanup action with the current region which is executed when the
+-- region is closed.
+defer :: Resource :> es => IO a -> Eff es ()
+defer action =
+  manage (pure ()) (const action)