packages feed

lifetimes (empty) → 0.1.0.0

raw patch · 9 files changed

+908/−0 lines, 9 filesdep +basedep +containersdep +hspec

Dependencies added: base, containers, hspec, lifetimes, monad-stm, safe-exceptions, stm, transformers, zenhack-prelude

Files

+ .gitignore view
@@ -0,0 +1,17 @@+dist+dist-newstyle+.ghc.environment.*+cabal.project.local++# Profiler outputs and formatted reports:+*.prof+*.hp+*.aux+*.ps++.hspec+.hspec-failures++# Code coverage:+.hpc+*.tix
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++First release.
+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright [yyyy] [name of copyright owner]++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ README.md view
@@ -0,0 +1,9 @@+Haskell library for flexible RAII-style resource management.++This package provides a superset of the functionality supported by+[resourcet][1]; in addition to allowing for early early release,+it also provides move semantics: lifetimes are first class values+and hierarchical, and resources can be moved between them after+allocation.++[1]: https://hackage.haskell.org/package/resourcet
+ lifetimes.cabal view
@@ -0,0 +1,80 @@+cabal-version:       2.2+name:                lifetimes+version:             0.1.0.0+synopsis:            Flexible manual resource management+description:+  The lifetimes package provides support for manual resource management,+  in a way that is more flexible than what is provided by @resourcet@ or+  @bracket@.+  .+  Like @resourcet@, this package allows releasing acquired resources early.+  In addition, it also provides move semantics: resources can be moved to+  a different lifetime after they are acquired. Lifetimes are first class+  values, which can themselves be acquired as resources, allowing for+  heirarchical management as well.+homepage:            https://github.com/zenhack/haskell-lifetimes+license:             Apache-2.0++license-file:        LICENSE+author:              Ian Denhardt+maintainer:          ian@zenhack.net+copyright:           2021 Ian Denhardt+-- category:+  -- Codec+  -- Concurrency+  -- Control+  -- Data+  -- Database+  -- Development+  -- Distribution+  -- Game+  -- Graphics+  -- Language+  -- Math+  -- Network+  -- Sound+  -- System+  -- Testing+  -- Text+  -- Web++build-type:          Simple+extra-source-files:+    CHANGELOG.md+  , README.md+  , .gitignore++source-repository head+  type:     git+  branch:   main+  location: https://github.com/zenhack/haskell-lifetimes++common shared-opts+  default-extensions:+      NoImplicitPrelude+    , OverloadedStrings+  build-depends:+      base >=4.12 && <5+    , containers ^>=0.6.2+    , stm ^>=2.5+    , monad-stm ^>=0.1+    , transformers ^>=0.5.6+    , zenhack-prelude ^>=0.1+  default-language:    Haskell2010++library+  import: shared-opts+  hs-source-dirs:      src+  exposed-modules:+      Lifetimes+    , Lifetimes.Rc+    , Lifetimes.Gc+test-suite tests+  import: shared-opts+  build-depends:+      lifetimes+    , hspec ^>=2.7.6+    , safe-exceptions ^>=0.1.7+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Main.hs
+ src/Lifetimes.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+-- | Module: Lifetimes+-- Description: Flexible resource management using first class lifetimes.+--+-- This package is centered around a couple types:+--+-- * 'Acquire' is a monadic context in which resources can be acquired.+--   These can be executed using 'acquire', or for simpler cases 'withAcquire'+--   or 'acquireValue'.+-- * 'Resource' is a handle to a resource. The value for the resource can+--   be read from this, and the 'Resource' can also be used to manipulate+--   the resource's lifetime.+-- * 'Liftime' is the type of first-class liftimes; resources are attached+--   to these and can be moved between them.+module Lifetimes+    (+    -- * Lifetimes+      Lifetime+    , newLifetime+    , withLifetime++    -- * Acquiring resources+    , Acquire+    , mkAcquire+    , withAcquire+    , acquire+    , acquireValue+    , currentLifetime++    -- * Using resources+    , Resource+    , getResource+    , mustGetResource++    -- * Releasing resources+    , releaseEarly+    , detach++    -- * Move semantics+    , moveTo++    -- * Errors+    , ResourceExpired(..)+    ) where++import           Control.Concurrent.STM+import           Control.Exception          (Exception, bracket, finally)+import           Control.Monad.STM.Class+import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import           Data.Foldable              (fold)+import qualified Data.Map.Strict            as M+import           Data.Maybe                 (fromJust)+import           Zhp++-- | Error thrown when an attempt is made to use an expired+-- resource or lifetime.+data ResourceExpired = ResourceExpired+    deriving(Show, Read, Ord, Eq)+instance Exception ResourceExpired++newtype ReleaseKey = ReleaseKey Word64+    deriving(Show, Read, Ord, Eq, Bounded)++instance Enum ReleaseKey where+    toEnum n = ReleaseKey (toEnum n)+    fromEnum (ReleaseKey n) = fromEnum n++newtype Cleanup = Cleanup { runCleanup :: IO () }++instance Semigroup Cleanup where+    -- We want resources to be released in the opposite order from their+    -- acquisition, so x <> y releases y and then x.+    Cleanup x <> Cleanup y = Cleanup $ y `finally` x++instance Monoid Cleanup where+    mempty = Cleanup $ pure ()++-- | A 'Lifetime' is a represents the scope in which a 'Resource' is valid;+-- resources are attached to a lifetime when they are acquired, and will+-- be released when the lifetime ends.+data Lifetime = Lifetime+    { resources      :: TVar (Maybe (M.Map ReleaseKey Cleanup))+    , nextReleaseKey :: TVar ReleaseKey+    }++-- | Represents a resource with type @a@, which has a lifetime and an+-- associated cleanup handler.+data Resource a = Resource+    { releaseKey :: TVar ReleaseKey+    , lifetime   :: TVar Lifetime+    , valueCell  :: TVar (Maybe a)+    }++-- | An 'Acquire' is a monadic action that acquires some number of resources,+-- and registers cleanup handlers to be executed when their lifetime expires.+newtype Acquire a = Acquire (ReaderT Lifetime IO a)+    deriving(Functor, Applicative, Monad, MonadIO)++newReleaseKey :: Lifetime -> STM ReleaseKey+newReleaseKey Lifetime{nextReleaseKey} = do+    key <- readTVar nextReleaseKey+    writeTVar nextReleaseKey $! succ key+    pure key++addCleanup :: Lifetime -> Cleanup -> STM ReleaseKey+addCleanup lt clean = do+    key <- newReleaseKey lt+    modifyMaybeTVar (resources lt) $ M.insert key clean+    pure key++acquire1 :: Lifetime -> IO a -> (a -> IO ()) -> IO (a, Resource a)+acquire1 lt get clean = do+    bracket+        (get >>= newTVarIO . Just)+        (\var -> atomically (readTVar var) >>= traverse_ clean)+        (\var -> atomically $ do+            value <- fromJust <$> readTVar var+            key <- addCleanup lt $ Cleanup (clean value)+            writeTVar var Nothing+            lifetime <- newTVar lt+            releaseKey <- newTVar key+            valueCell <- newTVar $ Just value+            pure+                ( value+                , Resource+                    { releaseKey+                    , lifetime+                    , valueCell+                    }+                )+        )++-- | Get the lifetime for the resources being acquired.+currentLifetime :: Acquire Lifetime+currentLifetime = Acquire ask++-- | @'mkAcquire' get cleanup@ acquires a resource with @get@, which will+-- be released by calling @cleanup@ when its lifetime ends.+mkAcquire :: IO a -> (a -> IO ()) -> Acquire a+mkAcquire get cleanup = Acquire $ do+    lt <- ask+    fst <$> liftIO (acquire1 lt get cleanup)++-- | Acquire a new lifetime, as its own resource. This allows creating+-- sub-groups of resources, which can be later moved as a unit.+newLifetime :: Acquire Lifetime+newLifetime = mkAcquire createLifetime destroyLifetime++createLifetime :: IO Lifetime+createLifetime = Lifetime+    <$> newTVarIO (Just M.empty)+    <*> newTVarIO minBound++modifyMaybeTVar :: TVar (Maybe a) -> (a -> a) -> STM ()+modifyMaybeTVar tvar f = do+    content <- readTVar tvar+    case content of+        Just v  -> writeTVar tvar $ Just $! f v+        Nothing -> throwSTM ResourceExpired++getResourceMap :: Lifetime -> STM (M.Map ReleaseKey Cleanup)+getResourceMap lt =+    readTVar (resources lt) >>= \case+        Just m  -> pure m+        Nothing -> throwSTM ResourceExpired++destroyLifetime :: Lifetime -> IO ()+destroyLifetime lt =+    join $ atomically $ do+        clean <- fold <$> getResourceMap lt+        writeTVar (resources lt) Nothing+        pure $ runCleanup clean++-- | 'withAcquire' acuires a resource, uses it, and then releases it.+-- @'withAcquire' ('mkAcquire' get cleanup)@ is equivalent to+-- @'bracket' get cleanup@.+withAcquire :: Acquire a -> (a -> IO b) -> IO b+withAcquire acq use = withLifetime $ \lt -> do+    res <- acquire lt acq+    value <- fromJust <$> atomically (getResource res)+    use value++-- | Execute an IO action within the scope of a newly allocated lifetime,+-- which ends when the IO action completes.+withLifetime :: (Lifetime -> IO a) -> IO a+withLifetime = bracket createLifetime destroyLifetime++-- | Acquire a resource, attaching it to the supplied lifetime.+acquire :: Lifetime -> Acquire a -> IO (Resource a)+acquire lt (Acquire acq) = do+    (lt', res) <- acquire1 lt createLifetime destroyLifetime+    value' <- runReaderT acq lt'+    valueCell <- atomically $ newTVar $ Just value'+    pure res { valueCell }++-- | Like 'acquire', but returns the value, rather than a 'Resource' wrapper.+-- conveinent when you don't need to move the resource or release it before+-- the lifetime expires.+acquireValue :: Lifetime -> Acquire a -> IO a+acquireValue lt acq = do+    res <- acquire lt acq+    fromJust <$> atomically (getResource res)++-- | Move a resource to another lifetime. The resource will be detached from+-- its existing lifetime, and so may live past it, but will be released when+-- the new lifetime expires.+moveTo :: MonadSTM m => Resource a -> Lifetime -> m ()+moveTo r newLt = liftSTM $ do+    oldKey <- readTVar $ releaseKey r+    oldLt <- readTVar $ lifetime r+    oldMap <- getResourceMap oldLt+    case M.lookup oldKey oldMap of+        Nothing -> pure () -- already freed.+        Just clean -> do+            modifyMaybeTVar (resources oldLt) $ M.delete oldKey+            newKey <- newReleaseKey newLt+            writeTVar (releaseKey r) $! newKey+            modifyMaybeTVar (resources newLt) $ M.insert newKey clean++-- | Release a resource early, before its lifetime would otherwise end.+releaseEarly :: Resource a -> IO ()+releaseEarly r =+    bracket+        (atomically takeValue)+        releaseValue+        (\_ -> pure ())+  where+    takeValue = do+        v <- getResource r+        writeTVar (valueCell r) Nothing+        pure v+    releaseValue v =+        for_ v $ \_ ->+            join $ atomically (detach r)++-- | Get the value associated with a resource, returning 'Nothing' if the+-- resource's lifetime is expired.+getResource :: MonadSTM m => Resource a -> m (Maybe a)+getResource r = liftSTM $ readTVar (valueCell r)++-- | Like 'getResource', but throws a 'ResourceExpired' exception instead+-- of returning a 'Maybe'.+mustGetResource :: MonadSTM m => Resource a -> m a+mustGetResource r = liftSTM $ getResource r >>= \case+    Nothing -> throwSTM ResourceExpired+    Just v  -> pure v++-- | Detach the resource from its lifetime, returning the cleanup handler.+-- NOTE: if the caller does not otherwise arrange to run the cleanup handler,+-- it will *not* be executed.+detach :: MonadSTM m => Resource a -> m (IO ())+detach r = liftSTM $ do+    key <- readTVar $ releaseKey r+    lt <- readTVar $ lifetime r+    ltMap <- getResourceMap lt+    let result = M.lookup key ltMap+    for_ result $ \_ ->+        modifyMaybeTVar (resources lt) $ M.delete key+    pure $ traverse_ runCleanup result
+ src/Lifetimes/Gc.hs view
@@ -0,0 +1,144 @@+-- | Module: Lifetimes.Gc+-- Description: Attach garbage-collector managed finalizers to resources.+--+-- This module integrates the lifetimes package with GHC's finalizers; this+-- allows you to have the GC run cleanup actions when a resource is garbage+-- collected, rather than managing its lifetime explicitly.+--+-- You should think twice before using this; much of the point of this package+-- is to manage resources whose lifetime is *semantically significant*, so+-- in many cases you will want more control over when the resource is released+-- than this module provides. It would be inappropriate to use this+-- if:+--+-- * You need the resource to be cleaned up promptly for semantic reasons+--   (e.g. dropping a network connection).+-- * The resource is scarce (e.g. file descriptors), so it is not safe to+--   wait for the garbage collector to get around it.+--+-- It is sometimes appropriate however, when time of release is mostly an+-- implementation detail. In particular, this module is fine for use cases+-- where you would want to use a finalizer anyway, and it can be safer:+-- The GHC APIs allow you to attach finalizers to arbitrary values, but+-- doing so is perlious; the compiler and runtime system are free to do+-- many transformations on the code that uses pure values, so it is easy+-- to end up with the finalizer being run sooner than you intended. This+-- module provides a 'Cell' type for finalizable values which is easier+-- to reason about.+{-# LANGUAGE NamedFieldPuns #-}+module Lifetimes.Gc+    ( Cell+    , readCell+    , acquireCell+    , moveToGc+    , newCell+    , addFinalizer+    ) where++import Control.Concurrent.MVar (MVar, mkWeakMVar, newEmptyMVar)+import Control.Concurrent.STM+import Control.Exception       (mask)+import Control.Monad.STM.Class+import Lifetimes+import Zhp++-- | A cell, containing a value with possible finalizers attached. This differs+-- from 'Resource' in that getting the underlying value cannot fail, since+-- cleanup is controlled by the garbage collector.+newtype Cell a+    = Cell (TVar (CellData a))+    deriving(Eq)++-----------------------------------------------------------------------+-- Implementation notes:+--+-- From the docs for the 'Weak' type:+--+-- > WARNING: weak pointers to ordinary non-primitive Haskell types+-- > are particularly fragile, because the compiler is free to optimise+-- > away or duplicate the underlying data structure. Therefore+-- > attempting to place a finalizer on an ordinary Haskell type may+-- > well result in the finalizer running earlier than you expected.+-- >+-- > [...]+-- >+-- > Finalizers can be used reliably for types that are created+-- > explicitly and have identity, such as IORef and MVar. [...]+--+-- So instead, we provide a 'Cell' type, which:+--+-- * Wraps simple value+-- * Can be created and read inside STM, and+-- * May safely have finalizers, using the 'addFinalizer' function in+--   this module.+-- * Ensures that the finalizers will not be run before any transaction that+--   reads data is complete.+--+-- Note that it is *not* safe to use the primitives from "Sys.Mem.Weak" to+-- add finalizers.+-----------------------------------------------------------------------++-- The actual contents of a cell. This is wrapped in a 'TVar' to force accesses+-- to add the a reference the transaction log from which the finalizers are+-- reachable, thus preventing them from running before the completion of any+-- transaction that examines the value.+data CellData a = CellData+    { value      :: a+    -- ^ The value wrapped by the cell.++    , finalizers :: [MVar ()]+    -- ^ Experimentally, TVars appear not to be safe for finalizers, so+    -- instead we create MVars for the finalizers, and store them in this+    -- list so that we maintain a reference to them.+    }+    deriving(Eq)++-- | Get the value from a cell. The value will not be collected until after+-- the all transactions which read it complete.+--+-- Note that this is intentionally not in 'MonadSTM': it is unsafe to use it+-- in 'IO', since the transaction would be finished as soon as it is read.+-- Instead, in 'IO' you should use acquireCell+readCell :: Cell a -> STM a+readCell (Cell state) = value <$> readTVar state++-- | Create  a new cell, initially with no finalizers.+newCell :: MonadSTM m => a -> m (Cell a)+newCell value = liftSTM $ Cell <$> newTVar CellData { value, finalizers = [] }++-- | Add a new finalizer to the cell. Cells may have many finalizers+-- attached.+addFinalizer :: Cell a -> IO () -> IO ()+addFinalizer (Cell stateVar) fin = do+    mvar <- newEmptyMVar+    _ <- mkWeakMVar mvar fin+    atomically $ modifyTVar' stateVar $ \state@CellData{finalizers} ->+        state { finalizers = mvar : finalizers }++-- | Move a resource to the garbage collector, detaching it from its+-- original lifetime.+moveToGc :: Resource a -> IO (Cell a)+moveToGc r =+    mask $ \_ -> join $ atomically $ do+        value <- mustGetResource r+        fin <- detach r+        cell <- newCell value+        pure $ do+            addFinalizer cell fin+            pure cell+++-- | Acquire a reference to the underlying value. This keeps the finalizer+-- from being run before the acquired reference is dropped.+--+-- If you need to use the value in 'IO', you should use this to get a+-- reference to it. If you only need to use it in 'STM', 'readCell'+-- may be more ergonomic.+acquireCell :: Cell a -> Acquire a+acquireCell (Cell var) = mkAcquire+    (atomically $ value <$> readTVar var)+    (\_ -> atomically $ do+        -- Touch the contents of the cell, to make sure it stays alive.+        CellData{} <- readTVar var+        pure ()+    )
+ src/Lifetimes/Rc.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NamedFieldPuns #-}+-- | Module: Lifetimes.Rc+-- Description: Support for working with reference-counted resources.+--+-- Rather than associating a resource with one lifetime, a reference counted+-- resource associates each *reference* with a lifetime, and is released when+-- all references have expired.+module Lifetimes.Rc+    ( Rc+    , addRef+    , refCounted+    ) where++import Control.Concurrent.STM+import Lifetimes+import Zhp++-- | A resource which is managed by reference counting.+data Rc a = Rc+    { count   :: TVar Int+    , value   :: a+    , cleanup :: IO ()+    }++-- | Acquire a new reference.+addRef :: Rc a -> Acquire a+addRef rc =+    mkAcquire+        (atomically $ incRef rc)+        (\_ -> join $ atomically $ decRef rc)++resourceToRc :: Resource a -> STM (Rc a)+resourceToRc res = do+    value <- mustGetResource res+    cleanup <- detach res+    count <- newTVar 1+    pure Rc { count, cleanup, value }+++-- | Acquire a resource using refcounting. Takes an 'Acquire' for the underlying+-- resource, and returns one that acquires an initial reference to it. Additional+-- references may be created using 'addRef', and the underlying resource will be+-- kept alive until all resources are released.+refCounted :: Acquire a -> Acquire (Rc a)+refCounted acq = do+    lt <- currentLifetime+    liftIO $ withLifetime $ \tmpLt -> do+        res <- acquire tmpLt acq+        acquireValue lt $ mkAcquire+            (atomically $ resourceToRc res)+            (join . atomically . decRef)+++incRef :: Rc a -> STM a+incRef Rc{count, value} = do+    modifyTVar' count succ+    pure value++decRef :: Rc a -> STM (IO ())+decRef Rc{count, cleanup} = do+    modifyTVar' count pred+    c <- readTVar count+    pure $ case c of+        0 -> cleanup+        _ -> pure ()
+ tests/Main.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Main (main) where++import           Control.Exception.Safe (SomeException, throwString, try)+import           Data.IORef+import           Lifetimes+import qualified Lifetimes.Gc           as Gc+import qualified Lifetimes.Rc           as Rc+import           System.Mem             (performGC)+import           Test.Hspec+import           Zhp++main :: IO ()+main = hspec $ do+    describe "withAcquire" $ do+        it "Should run the handler on success" $ do+            ref <- newIORef 0+            withAcquire (mkAcquire (pure ()) (\() -> writeIORef ref 1)) $ \_ -> pure ()+            value <- readIORef ref+            value `shouldBe` 1+        it "Should run the handler on exceptions" $ do+            ref <- newIORef 0+            result <- try $ withAcquire (mkAcquire (pure ()) (\() -> writeIORef ref 1)) $ \() ->+                throwString "Error"+            case result of+                Right () -> error "Should have thrown an exception"+                Left (_ :: SomeException) -> do+                    value <- readIORef ref+                    value `shouldBe` 1+        it "Should run cleanup handlers in reverse order" $ do+            ref <- newIORef []+            withAcquire+                (traverse_ (append ref) [1,2,3])+                pure+            value <- readIORef ref+            value `shouldBe` [3,2,1]+    describe "nested lifetimes" $ do+        it "Should order resources underneath their lifetimes." $ do+            ref <- newIORef []+            withLifetime $ \lt -> do+                void $ acquire lt $ append ref 1+                lt' <- acquireValue lt newLifetime+                void $ acquire lt $ append ref 2+                -- even though 3 is allocated after 2, it will be freed when+                -- lt' is freed.+                void $ acquire lt' $ append ref 3+            value <- readIORef ref+            value `shouldBe` [2,3,1]+    describe "releaseEarly" $ do+        it "Should release the resource immediately" $ do+            ref <- newIORef []+            withLifetime $ \lt -> do+                void $ acquire lt $ append ref 1+                res2 <- acquire lt $ append ref 2+                void $ acquire lt $ append ref 3+                releaseEarly res2+            value <- readIORef ref+            value `shouldBe` [2,3,1]+    describe "moveTo" $ do+        it "Should live longer when moved to a longer-lived lifetime" $ do+            ref <- newIORef []+            withLifetime $ \lt -> do+                void $ acquire lt $ append ref 1+                lt' <- acquireValue lt newLifetime+                void $ acquire lt $ append ref 2+                res3 <- acquire lt' $ append ref 3+                -- If we didn't move this, it would be freed when lt'+                -- is freed, but this will make it live until the end of+                -- lt instead.+                moveTo res3 lt+            value <- readIORef ref+            value `shouldBe` [3,2,1]+        it "Should do nothing if the resource has already been freed" $ do+            ref <- newIORef []+            withLifetime $ \lt -> do+                res1 <- acquire lt $ append ref 1+                lt' <- acquireValue lt newLifetime+                void $ acquire lt $ append ref 2+                void $ acquire lt' $ append ref 3+                releaseEarly res1+                moveTo res1 lt'+            value <- readIORef ref+            value `shouldBe` [1,2,3]+    describe "Lifetimes.Rc" $ do+        it "Should release the resources in order if no extra references are acquired" $ do+            ref <- newIORef []+            withLifetime $ \lt -> do+                void $ acquire lt $ Rc.refCounted $ append ref 1+                void $ acquire lt $ Rc.refCounted $ append ref 2+            value <- readIORef ref+            value `shouldBe` [2,1]+        it "Should last until its final reference is dropped" $ do+            ref <- newIORef []+            withLifetime $ \lt1 -> do+                void $ withLifetime $ \lt2 -> do+                    res <- acquireValue lt2 $ Rc.refCounted $ append ref 1+                    acquire lt1 $ Rc.addRef res+                value <- readIORef ref+                value `shouldBe` []+            value <- readIORef ref+            value `shouldBe` [1]+    describe "Lifetimes.Gc" $ do+        it "Should not release the resource while an acquired reference is active." $ do+            ref <- newIORef []+            cell <- Gc.newCell ()+            Gc.addFinalizer cell (modifyIORef ref (<>[1]))+            withAcquire (Gc.acquireCell cell) $ \() -> do+                performGC+                value <- readIORef ref+                value `shouldBe` []+        describe "moveToGC" $ do+            it "Should not release a resource when its original lifetime is up." $ do+                ref <- newIORef []+                cell <- withLifetime $ \lt -> do+                    res <- acquire lt $ append ref 1+                    Gc.moveToGc res+                value <- readIORef ref+                value `shouldBe` []+                -- Touch the value to prevent GC:+                withAcquire (Gc.acquireCell cell) $ \_ -> pure ()++append :: IORef [Int] -> Int -> Acquire ()+append ref n = mkAcquire+    (pure ())+    (\() -> modifyIORef ref (<>[n]))