{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Util.ResourceRegistry ( RegistryClosedException (..) , ResourceRegistryThreadException -- * Creating and releasing the registry itself , bracketWithPrivateRegistry , registryThread , withRegistry -- * Allocating and releasing regular resources , ResourceKey , allocate , allocateEither , release , releaseAll , unsafeRelease , unsafeReleaseAll -- * Threads , cancelThread , forkLinkedThread , forkThread , linkToRegistry , threadId , waitAnyThread , waitThread , withThread -- ** opaque , Thread -- * Temporary registry , TempRegistryException (..) , allocateTemp , modifyWithTempRegistry , runInnerWithTempRegistry , runWithTempRegistry -- ** opaque , WithTempRegistry -- * Combinators primarily for testing , closeRegistry , countResources , unsafeNewRegistry -- * opaque , ResourceRegistry ) where import Control.Applicative ((<|>)) import Control.Exception (asyncExceptionFromException) import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bifunctor import Data.Bimap (Bimap) import qualified Data.Bimap as Bimap import Data.Either (partitionEithers) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, listToMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (InspectHeapNamed (..), OnlyCheckWhnfNamed (..), allNoThunks) import Ouroboros.Consensus.Util (mustBeRight, whenJust) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -- | Resource registry -- -- Note on terminology: when thread A forks thread B, we will say that thread A -- is the " parent " and thread B is the " child ". No further relationship -- between the two threads is implied by this terminology. In particular, note -- that the child may outlive the parent. We will use "fork" and "spawn" -- interchangeably. -- -- = Motivation -- -- Whenever we allocate resources, we must keep track of them so that we can -- deallocate them when they are no longer required. The most important tool we -- have to achieve this is 'bracket': -- -- > bracket allocateResource releaseResource $ \r -> -- > .. use r .. -- -- Often 'bracket' comes in the guise of a with-style combinator -- -- > withResource $ \r -> -- > .. use r .. -- -- Where this pattern is applicable, it should be used and there is no need to -- use the 'ResourceRegistry'. However, 'bracket' introduces strict lexical -- scoping: the resource is available inside the scope of the bracket, and -- will be deallocated once we leave that scope. That pattern is sometimes -- hard to use. -- -- For example, suppose we have this interface to an SQL server -- -- > query :: Query -> IO QueryHandle -- > close :: QueryHandle -> IO () -- > next :: QueryHandle -> IO Row -- -- and suppose furthermore that we are writing a simple webserver that allows a -- client to send multiple SQL queries, get rows from any open query, and close -- queries when no longer required: -- -- > server :: IO () -- > server = go Map.empty -- > where -- > go :: Map QueryId QueryHandle -> IO () -- > go handles = getRequest >>= \case -- > New q -> do -- > h <- query q -- allocate -- > qId <- generateQueryId -- > sendResponse qId -- > go $ Map.insert qId h handles -- > Close qId -> do -- > close (handles ! qId) -- release -- > go $ Map.delete qId handles -- > Next qId -> do -- > sendResponse =<< next (handles ! qId) -- > go handles -- -- The server opens and closes query handles in response to client requests. -- Restructuring this code to use 'bracket' would be awkward, but as it stands -- this code does not ensure that resources get deallocated; for example, if -- the server thread is killed ('killThread'), resources will be leaked. -- -- Another, perhaps simpler, example is spawning threads. Threads too should -- be considered to be resources that we should keep track of and deallocate -- when they are no longer required, primarily because when we deallocate -- (terminate) those threads they too will have a chance to deallocate /their/ -- resources. As for other resources, we have a with-style combinator for this -- -- > withAsync $ \thread -> .. -- -- Lexical scoping of threads is often inconvenient, however, more so than for -- regular resources. The temptation is therefore to simply fork a thread and -- forget about it, but if we are serious about resource deallocation this is -- not an acceptable solution. -- -- = The resource registry -- -- The resource registry is essentially a piece of state tracking which -- resources have been allocated. The registry itself is allocated with a -- with-style combinator 'withRegistry', and when we leave that scope any -- resources not yet deallocated will be released at that point. Typically -- the registry is only used as a fall-back, ensuring that resources will -- deallocated even in the presence of exceptions. For example, here's how -- we might rewrite the above server example using a registry: -- -- > server' :: IO () -- > server' = -- > withRegistry $ \registry -> go registry Map.empty -- > where -- > go :: ResourceRegistry IO -- > -> Map QueryId (ResourceKey, QueryHandle) -- > -> IO () -- > go registry handles = getRequest >>= \case -- > New q -> do -- > (key, h) <- allocate registry (query q) close -- allocate -- > qId <- generateQueryId -- > sendResponse qId -- > go registry $ Map.insert qId (key, h) handles -- > Close qId -> do -- > release registry (fst (handles ! qId)) -- release -- > go registry $ Map.delete qId handles -- > Next qId -> do -- > sendResponse =<< next (snd (handles ! qId)) -- > go registry handles -- -- We allocate the query with the help of the registry, providing the registry -- with the means to deallocate the query should that be required. We can /and -- should/ still manually release resources also: in this particular example, -- the (lexical) scope of the registry is the entire server thread, so delaying -- releasing queries until we exit that scope will probably mean we hold on to -- resources for too long. The registry is only there as a fall-back. -- -- = Spawning threads -- -- We already observed in the introduction that insisting on lexical scoping -- for threads is often inconvenient, and that simply using 'fork' is no -- solution as it means we might leak resources. There is however another -- problem with 'fork'. Consider this snippet: -- -- > withRegistry $ \registry -> -- > r <- allocate registry allocateResource releaseResource -- > fork $ .. use r .. -- -- It is easy to see that this code is problematic: we allocate a resource @r@, -- then spawn a thread that uses @r@, and finally leave the scope of -- 'withRegistry', thereby deallocating @r@ -- leaving the thread to run with -- a now deallocated resource. -- -- It is /only/ safe for threads to use a given registry, and/or its registered -- resources, if the lifetime of those threads is tied to the lifetime of the -- registry. There would be no problem with the example above if the thread -- would be terminated when we exit the scope of 'withRegistry'. -- -- The 'forkThread' combinator provided by the registry therefore does two -- things: it allocates the thread as a resource in the registry, so that it can -- kill the thread when releasing all resources in the registry. It also records -- the thread ID in a set of known threads. Whenever the registry is accessed -- from a thread /not/ in this set, the registry throws a runtime exception, -- since such a thread might outlive the registry and hence its contents. The -- intention is that this guards against dangerous patterns like the one above. -- -- = Linking -- -- When thread A spawns thread B using 'withAsync', the lifetime of B is tied -- to the lifetime of A: -- -- > withAsync .. $ \threadB -> .. -- -- After all, when A exits the scope of the 'withAsync', thread B will be -- killed. The reverse is however not true: thread B can terminate before -- thread A. It is often useful for thread A to be able to declare a dependency -- on thread B: if B somehow fails, that is, terminates with an exception, we -- want that exception to be rethrown in thread A as well. A can achieve this -- by /linking/ to B: -- -- > withAsync .. $ \threadB -> do -- > link threadB -- > .. -- -- Linking a parent to a child is however of limited value if the lifetime of -- the child is not limited by the lifetime of the parent. For example, if A -- does -- -- > threadB <- async $ .. -- > link threadB -- -- and A terminates before B does, any exception thrown by B might be send to a -- thread that no longer exists. This is particularly problematic when we start -- chaining threads: if A spawns-and-links-to B which spawns-and-links-to C, and -- C throws an exception, perhaps the intention is that this gets rethrown to B, -- and then rethrown to A, terminating all three threads; however, if B has -- terminated before the exception is thrown, C will throw the exception to a -- non-existent thread and A is never notified. -- -- For this reason, the registry's 'linkToRegistry' combinator does not link the -- specified thread to the thread calling 'linkToRegistry', but rather to the -- thread that created the registry. After all, the lifetime of threads spawned -- with 'forkThread' can certainly exceed the lifetime of their parent threads, -- but the lifetime of /all/ threads spawned using the registry will be limited -- by the scope of that registry, and hence the lifetime of the thread that -- created it. So, when we call 'linkToRegistry', the exception will be thrown -- the thread that created the registry, which (if not caught) will cause that -- that to exit the scope of 'withRegistry', thereby terminating all threads in -- that registry. -- -- = Combining the registry and with-style allocation -- -- It is perfectly possible (indeed, advisable) to use 'bracket' and -- bracket-like allocation functions alongside the registry, but note that the -- usual caveats with 'bracket' and forking threads still applies. In -- particular, spawning threads inside the 'bracket' that make use of the -- bracketed resource is problematic; this is of course true whether or not a -- registry is used. -- -- In principle this also includes 'withAsync'; however, since 'withAsync' -- results in a thread that is not known to the registry, such a thread will not -- be able to use the registry (the registry would throw an unknown thread -- exception, as described above). For this purpose we provide 'withThread'; -- 'withThread' (as opposed to 'forkThread') should be used when a parent thread -- wants to handle exceptions in the child thread; see 'withThread' for -- detailed discussion. -- -- It is /also/ fine to includes nested calls to 'withRegistry'. Since the -- lifetime of such a registry (and all resources within) is tied to the thread -- calling 'withRegistry', which itself is tied to the "parent registry" in -- which it was created, this creates a hierarchy of registries. It is of course -- essential for compositionality that we should be able to create local -- registries, but even if we do have easy access to a parent regisry, creating -- a local one where possibly is useful as it limits the scope of the resources -- created within, and hence their maximum lifetimes. data ResourceRegistry m = ResourceRegistry { -- | Context in which the registry was created ResourceRegistry m -> Context m registryContext :: !(Context m) -- | Registry state , ResourceRegistry m -> StrictTVar m (RegistryState m) registryState :: !(StrictTVar m (RegistryState m)) } deriving ((forall x. ResourceRegistry m -> Rep (ResourceRegistry m) x) -> (forall x. Rep (ResourceRegistry m) x -> ResourceRegistry m) -> Generic (ResourceRegistry m) forall x. Rep (ResourceRegistry m) x -> ResourceRegistry m forall x. ResourceRegistry m -> Rep (ResourceRegistry m) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) x. Rep (ResourceRegistry m) x -> ResourceRegistry m forall (m :: * -> *) x. ResourceRegistry m -> Rep (ResourceRegistry m) x $cto :: forall (m :: * -> *) x. Rep (ResourceRegistry m) x -> ResourceRegistry m $cfrom :: forall (m :: * -> *) x. ResourceRegistry m -> Rep (ResourceRegistry m) x Generic) deriving instance IOLike m => NoThunks (ResourceRegistry m) {------------------------------------------------------------------------------- Internal: registry state -------------------------------------------------------------------------------} -- | The age of a resource -- -- Age here is represented by an meaningless number. The one and only property -- that matters is that the age of resource A that was successfully allocated -- before resource B was (in the same registry) will be greater than the age of -- resource B. -- -- For the current implementation, that property will be true unless the -- registry lives long enough to have contained 2^64 separately allocated -- resources. -- -- This data is not exposed by the 'ResourceRegistry' interface. newtype Age = Age Word64 deriving stock (Int -> Age -> ShowS [Age] -> ShowS Age -> String (Int -> Age -> ShowS) -> (Age -> String) -> ([Age] -> ShowS) -> Show Age forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Age] -> ShowS $cshowList :: [Age] -> ShowS show :: Age -> String $cshow :: Age -> String showsPrec :: Int -> Age -> ShowS $cshowsPrec :: Int -> Age -> ShowS Show) deriving newtype (Age -> Age -> Bool (Age -> Age -> Bool) -> (Age -> Age -> Bool) -> Eq Age forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Age -> Age -> Bool $c/= :: Age -> Age -> Bool == :: Age -> Age -> Bool $c== :: Age -> Age -> Bool Eq, Eq Age Eq Age -> (Age -> Age -> Ordering) -> (Age -> Age -> Bool) -> (Age -> Age -> Bool) -> (Age -> Age -> Bool) -> (Age -> Age -> Bool) -> (Age -> Age -> Age) -> (Age -> Age -> Age) -> Ord Age Age -> Age -> Bool Age -> Age -> Ordering Age -> Age -> Age forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Age -> Age -> Age $cmin :: Age -> Age -> Age max :: Age -> Age -> Age $cmax :: Age -> Age -> Age >= :: Age -> Age -> Bool $c>= :: Age -> Age -> Bool > :: Age -> Age -> Bool $c> :: Age -> Age -> Bool <= :: Age -> Age -> Bool $c<= :: Age -> Age -> Bool < :: Age -> Age -> Bool $c< :: Age -> Age -> Bool compare :: Age -> Age -> Ordering $ccompare :: Age -> Age -> Ordering $cp1Ord :: Eq Age Ord) deriving Context -> Age -> IO (Maybe ThunkInfo) Proxy Age -> String (Context -> Age -> IO (Maybe ThunkInfo)) -> (Context -> Age -> IO (Maybe ThunkInfo)) -> (Proxy Age -> String) -> NoThunks Age forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy Age -> String $cshowTypeOf :: Proxy Age -> String wNoThunks :: Context -> Age -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> Age -> IO (Maybe ThunkInfo) noThunks :: Context -> Age -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> Age -> IO (Maybe ThunkInfo) NoThunks via InspectHeapNamed "Age" Age -- | The age of the first resource successfully allocated in a fresh registry ageOfFirstResource :: Age ageOfFirstResource :: Age ageOfFirstResource = Word64 -> Age Age Word64 forall a. Bounded a => a maxBound -- | Map the age of the latest resource to be successfully allocated to the age -- of the next resource to be successfully allocated in the same registry nextYoungerAge :: Age -> Age nextYoungerAge :: Age -> Age nextYoungerAge (Age Word64 n) = Word64 -> Age Age (Word64 n Word64 -> Word64 -> Word64 forall a. Num a => a -> a -> a - Word64 1) -- | Internal registry state -- -- INVARIANT: We record exactly the ages of currently allocated resources, -- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@. data RegistryState m = RegistryState { -- | Forked threads RegistryState m -> KnownThreads m registryThreads :: !(KnownThreads m) -- | Currently allocated resources , RegistryState m -> Map ResourceId (Resource m) registryResources :: !(Map ResourceId (Resource m)) -- | Next available resource key , RegistryState m -> ResourceId registryNextKey :: !ResourceId -- | The age of each currently allocated resource -- -- We use a 'Bimap' so we can maintain the keys in sorted order by age, -- which is necessary when closing the registry. , RegistryState m -> Bimap ResourceId Age registryAges :: !(Bimap ResourceId Age) -- | The age of the next resource , RegistryState m -> Age registryNextAge :: !Age -- | Does the registry still accept new allocations? -- -- See 'RegistryClosedException' for discussion. , RegistryState m -> RegistryStatus registryStatus :: !RegistryStatus } deriving ((forall x. RegistryState m -> Rep (RegistryState m) x) -> (forall x. Rep (RegistryState m) x -> RegistryState m) -> Generic (RegistryState m) forall x. Rep (RegistryState m) x -> RegistryState m forall x. RegistryState m -> Rep (RegistryState m) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) x. Rep (RegistryState m) x -> RegistryState m forall (m :: * -> *) x. RegistryState m -> Rep (RegistryState m) x $cto :: forall (m :: * -> *) x. Rep (RegistryState m) x -> RegistryState m $cfrom :: forall (m :: * -> *) x. RegistryState m -> Rep (RegistryState m) x Generic, Context -> RegistryState m -> IO (Maybe ThunkInfo) Proxy (RegistryState m) -> String (Context -> RegistryState m -> IO (Maybe ThunkInfo)) -> (Context -> RegistryState m -> IO (Maybe ThunkInfo)) -> (Proxy (RegistryState m) -> String) -> NoThunks (RegistryState m) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *). Context -> RegistryState m -> IO (Maybe ThunkInfo) forall (m :: * -> *). Proxy (RegistryState m) -> String showTypeOf :: Proxy (RegistryState m) -> String $cshowTypeOf :: forall (m :: * -> *). Proxy (RegistryState m) -> String wNoThunks :: Context -> RegistryState m -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *). Context -> RegistryState m -> IO (Maybe ThunkInfo) noThunks :: Context -> RegistryState m -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *). Context -> RegistryState m -> IO (Maybe ThunkInfo) NoThunks) -- | The currently allocated keys in youngest-to-oldest order getYoungestToOldest :: RegistryState m -> [ResourceId] getYoungestToOldest :: RegistryState m -> [ResourceId] getYoungestToOldest = ((Age, ResourceId) -> ResourceId) -> [(Age, ResourceId)] -> [ResourceId] forall a b. (a -> b) -> [a] -> [b] map (Age, ResourceId) -> ResourceId forall a b. (a, b) -> b snd ([(Age, ResourceId)] -> [ResourceId]) -> (RegistryState m -> [(Age, ResourceId)]) -> RegistryState m -> [ResourceId] forall b c a. (b -> c) -> (a -> b) -> a -> c . Bimap ResourceId Age -> [(Age, ResourceId)] forall a b. Bimap a b -> [(b, a)] Bimap.toAscListR (Bimap ResourceId Age -> [(Age, ResourceId)]) -> (RegistryState m -> Bimap ResourceId Age) -> RegistryState m -> [(Age, ResourceId)] forall b c a. (b -> c) -> (a -> b) -> a -> c . RegistryState m -> Bimap ResourceId Age forall (m :: * -> *). RegistryState m -> Bimap ResourceId Age registryAges -- | Threads known to the registry -- -- This is the set of threads spawned using 'forkThread'. The lifetimes of all -- of these threads are limited by the lifetime of the registry. -- -- Does not include the thread ID of the thread that created the registry. After -- all, this thread may well outlive the registry (though the registry cannot -- outlive it). -- -- Invariant (informal): the set of registered threads is a subset of the -- registered resources ('registryResources'). (This invariant is temporarily -- broken when we start a new thread in 'forkThread' but will be re-established -- before that thread starts execution proper.) newtype KnownThreads m = KnownThreads (Set (ThreadId m)) deriving Context -> KnownThreads m -> IO (Maybe ThunkInfo) Proxy (KnownThreads m) -> String (Context -> KnownThreads m -> IO (Maybe ThunkInfo)) -> (Context -> KnownThreads m -> IO (Maybe ThunkInfo)) -> (Proxy (KnownThreads m) -> String) -> NoThunks (KnownThreads m) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *). Context -> KnownThreads m -> IO (Maybe ThunkInfo) forall (m :: * -> *). Proxy (KnownThreads m) -> String showTypeOf :: Proxy (KnownThreads m) -> String $cshowTypeOf :: forall (m :: * -> *). Proxy (KnownThreads m) -> String wNoThunks :: Context -> KnownThreads m -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *). Context -> KnownThreads m -> IO (Maybe ThunkInfo) noThunks :: Context -> KnownThreads m -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *). Context -> KnownThreads m -> IO (Maybe ThunkInfo) NoThunks via InspectHeapNamed "KnownThreads" (KnownThreads m) -- | Status of the registry (open or closed) data RegistryStatus = RegistryOpen -- | We record the 'CallStack' to the call to 'close | RegistryClosed !PrettyCallStack deriving ((forall x. RegistryStatus -> Rep RegistryStatus x) -> (forall x. Rep RegistryStatus x -> RegistryStatus) -> Generic RegistryStatus forall x. Rep RegistryStatus x -> RegistryStatus forall x. RegistryStatus -> Rep RegistryStatus x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep RegistryStatus x -> RegistryStatus $cfrom :: forall x. RegistryStatus -> Rep RegistryStatus x Generic, Context -> RegistryStatus -> IO (Maybe ThunkInfo) Proxy RegistryStatus -> String (Context -> RegistryStatus -> IO (Maybe ThunkInfo)) -> (Context -> RegistryStatus -> IO (Maybe ThunkInfo)) -> (Proxy RegistryStatus -> String) -> NoThunks RegistryStatus forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy RegistryStatus -> String $cshowTypeOf :: Proxy RegistryStatus -> String wNoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo) noThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo) NoThunks) -- | Resource key -- -- Resource keys are tied to a particular registry. data ResourceKey m = ResourceKey !(ResourceRegistry m) !ResourceId deriving ((forall x. ResourceKey m -> Rep (ResourceKey m) x) -> (forall x. Rep (ResourceKey m) x -> ResourceKey m) -> Generic (ResourceKey m) forall x. Rep (ResourceKey m) x -> ResourceKey m forall x. ResourceKey m -> Rep (ResourceKey m) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) x. Rep (ResourceKey m) x -> ResourceKey m forall (m :: * -> *) x. ResourceKey m -> Rep (ResourceKey m) x $cto :: forall (m :: * -> *) x. Rep (ResourceKey m) x -> ResourceKey m $cfrom :: forall (m :: * -> *) x. ResourceKey m -> Rep (ResourceKey m) x Generic, Context -> ResourceKey m -> IO (Maybe ThunkInfo) Proxy (ResourceKey m) -> String (Context -> ResourceKey m -> IO (Maybe ThunkInfo)) -> (Context -> ResourceKey m -> IO (Maybe ThunkInfo)) -> (Proxy (ResourceKey m) -> String) -> NoThunks (ResourceKey m) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *). IOLike m => Context -> ResourceKey m -> IO (Maybe ThunkInfo) forall (m :: * -> *). IOLike m => Proxy (ResourceKey m) -> String showTypeOf :: Proxy (ResourceKey m) -> String $cshowTypeOf :: forall (m :: * -> *). IOLike m => Proxy (ResourceKey m) -> String wNoThunks :: Context -> ResourceKey m -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *). IOLike m => Context -> ResourceKey m -> IO (Maybe ThunkInfo) noThunks :: Context -> ResourceKey m -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *). IOLike m => Context -> ResourceKey m -> IO (Maybe ThunkInfo) NoThunks) -- | Return the 'ResourceId' of a 'ResourceKey'. resourceKeyId :: ResourceKey m -> ResourceId resourceKeyId :: ResourceKey m -> ResourceId resourceKeyId (ResourceKey ResourceRegistry m _rr ResourceId rid) = ResourceId rid -- | Resource ID -- -- This uniquifying data is not exposed by the 'ResourceRegistry' interface. newtype ResourceId = ResourceId Int deriving stock (Int -> ResourceId -> ShowS [ResourceId] -> ShowS ResourceId -> String (Int -> ResourceId -> ShowS) -> (ResourceId -> String) -> ([ResourceId] -> ShowS) -> Show ResourceId forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ResourceId] -> ShowS $cshowList :: [ResourceId] -> ShowS show :: ResourceId -> String $cshow :: ResourceId -> String showsPrec :: Int -> ResourceId -> ShowS $cshowsPrec :: Int -> ResourceId -> ShowS Show, ResourceId -> ResourceId -> Bool (ResourceId -> ResourceId -> Bool) -> (ResourceId -> ResourceId -> Bool) -> Eq ResourceId forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: ResourceId -> ResourceId -> Bool $c/= :: ResourceId -> ResourceId -> Bool == :: ResourceId -> ResourceId -> Bool $c== :: ResourceId -> ResourceId -> Bool Eq, Eq ResourceId Eq ResourceId -> (ResourceId -> ResourceId -> Ordering) -> (ResourceId -> ResourceId -> Bool) -> (ResourceId -> ResourceId -> Bool) -> (ResourceId -> ResourceId -> Bool) -> (ResourceId -> ResourceId -> Bool) -> (ResourceId -> ResourceId -> ResourceId) -> (ResourceId -> ResourceId -> ResourceId) -> Ord ResourceId ResourceId -> ResourceId -> Bool ResourceId -> ResourceId -> Ordering ResourceId -> ResourceId -> ResourceId forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: ResourceId -> ResourceId -> ResourceId $cmin :: ResourceId -> ResourceId -> ResourceId max :: ResourceId -> ResourceId -> ResourceId $cmax :: ResourceId -> ResourceId -> ResourceId >= :: ResourceId -> ResourceId -> Bool $c>= :: ResourceId -> ResourceId -> Bool > :: ResourceId -> ResourceId -> Bool $c> :: ResourceId -> ResourceId -> Bool <= :: ResourceId -> ResourceId -> Bool $c<= :: ResourceId -> ResourceId -> Bool < :: ResourceId -> ResourceId -> Bool $c< :: ResourceId -> ResourceId -> Bool compare :: ResourceId -> ResourceId -> Ordering $ccompare :: ResourceId -> ResourceId -> Ordering $cp1Ord :: Eq ResourceId Ord) deriving newtype (Int -> ResourceId ResourceId -> Int ResourceId -> [ResourceId] ResourceId -> ResourceId ResourceId -> ResourceId -> [ResourceId] ResourceId -> ResourceId -> ResourceId -> [ResourceId] (ResourceId -> ResourceId) -> (ResourceId -> ResourceId) -> (Int -> ResourceId) -> (ResourceId -> Int) -> (ResourceId -> [ResourceId]) -> (ResourceId -> ResourceId -> [ResourceId]) -> (ResourceId -> ResourceId -> [ResourceId]) -> (ResourceId -> ResourceId -> ResourceId -> [ResourceId]) -> Enum ResourceId forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: ResourceId -> ResourceId -> ResourceId -> [ResourceId] $cenumFromThenTo :: ResourceId -> ResourceId -> ResourceId -> [ResourceId] enumFromTo :: ResourceId -> ResourceId -> [ResourceId] $cenumFromTo :: ResourceId -> ResourceId -> [ResourceId] enumFromThen :: ResourceId -> ResourceId -> [ResourceId] $cenumFromThen :: ResourceId -> ResourceId -> [ResourceId] enumFrom :: ResourceId -> [ResourceId] $cenumFrom :: ResourceId -> [ResourceId] fromEnum :: ResourceId -> Int $cfromEnum :: ResourceId -> Int toEnum :: Int -> ResourceId $ctoEnum :: Int -> ResourceId pred :: ResourceId -> ResourceId $cpred :: ResourceId -> ResourceId succ :: ResourceId -> ResourceId $csucc :: ResourceId -> ResourceId Enum, Context -> ResourceId -> IO (Maybe ThunkInfo) Proxy ResourceId -> String (Context -> ResourceId -> IO (Maybe ThunkInfo)) -> (Context -> ResourceId -> IO (Maybe ThunkInfo)) -> (Proxy ResourceId -> String) -> NoThunks ResourceId forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy ResourceId -> String $cshowTypeOf :: Proxy ResourceId -> String wNoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo) noThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo) $cnoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo) NoThunks) -- | Information about a resource data Resource m = Resource { -- | Context in which the resource was created Resource m -> Context m resourceContext :: !(Context m) -- | Deallocate the resource , Resource m -> Release m resourceRelease :: !(Release m) } deriving ((forall x. Resource m -> Rep (Resource m) x) -> (forall x. Rep (Resource m) x -> Resource m) -> Generic (Resource m) forall x. Rep (Resource m) x -> Resource m forall x. Resource m -> Rep (Resource m) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) x. Rep (Resource m) x -> Resource m forall (m :: * -> *) x. Resource m -> Rep (Resource m) x $cto :: forall (m :: * -> *) x. Rep (Resource m) x -> Resource m $cfrom :: forall (m :: * -> *) x. Resource m -> Rep (Resource m) x Generic, Context -> Resource m -> IO (Maybe ThunkInfo) Proxy (Resource m) -> String (Context -> Resource m -> IO (Maybe ThunkInfo)) -> (Context -> Resource m -> IO (Maybe ThunkInfo)) -> (Proxy (Resource m) -> String) -> NoThunks (Resource m) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *). Context -> Resource m -> IO (Maybe ThunkInfo) forall (m :: * -> *). Proxy (Resource m) -> String showTypeOf :: Proxy (Resource m) -> String $cshowTypeOf :: forall (m :: * -> *). Proxy (Resource m) -> String wNoThunks :: Context -> Resource m -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *). Context -> Resource m -> IO (Maybe ThunkInfo) noThunks :: Context -> Resource m -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *). Context -> Resource m -> IO (Maybe ThunkInfo) NoThunks) -- | Release the resource, return 'True' when the resource was actually -- released, return 'False' when the resource was already released. -- -- If unsure, returning 'True' is always fine. newtype Release m = Release (m Bool) deriving Context -> Release m -> IO (Maybe ThunkInfo) Proxy (Release m) -> String (Context -> Release m -> IO (Maybe ThunkInfo)) -> (Context -> Release m -> IO (Maybe ThunkInfo)) -> (Proxy (Release m) -> String) -> NoThunks (Release m) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *). Context -> Release m -> IO (Maybe ThunkInfo) forall (m :: * -> *). Proxy (Release m) -> String showTypeOf :: Proxy (Release m) -> String $cshowTypeOf :: forall (m :: * -> *). Proxy (Release m) -> String wNoThunks :: Context -> Release m -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *). Context -> Release m -> IO (Maybe ThunkInfo) noThunks :: Context -> Release m -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *). Context -> Release m -> IO (Maybe ThunkInfo) NoThunks via OnlyCheckWhnfNamed "Release" (Release m) releaseResource :: Resource m -> m Bool releaseResource :: Resource m -> m Bool releaseResource Resource{resourceRelease :: forall (m :: * -> *). Resource m -> Release m resourceRelease = Release m Bool f} = m Bool f instance Show (Release m) where show :: Release m -> String show Release m _ = String "<<release>>" {------------------------------------------------------------------------------- Internal: pure functions on the registry state -------------------------------------------------------------------------------} modifyKnownThreads :: (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m modifyKnownThreads :: (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m modifyKnownThreads Set (ThreadId m) -> Set (ThreadId m) f (KnownThreads Set (ThreadId m) ts) = Set (ThreadId m) -> KnownThreads m forall (m :: * -> *). Set (ThreadId m) -> KnownThreads m KnownThreads (Set (ThreadId m) -> Set (ThreadId m) f Set (ThreadId m) ts) -- | Auxiliary for functions that should be disallowed when registry is closed unlessClosed :: State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed :: State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed State (RegistryState m) a f = do RegistryStatus status <- (RegistryState m -> RegistryStatus) -> StateT (RegistryState m) Identity RegistryStatus forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets RegistryState m -> RegistryStatus forall (m :: * -> *). RegistryState m -> RegistryStatus registryStatus case RegistryStatus status of RegistryClosed PrettyCallStack closed -> Either PrettyCallStack a -> State (RegistryState m) (Either PrettyCallStack a) forall (m :: * -> *) a. Monad m => a -> m a return (Either PrettyCallStack a -> State (RegistryState m) (Either PrettyCallStack a)) -> Either PrettyCallStack a -> State (RegistryState m) (Either PrettyCallStack a) forall a b. (a -> b) -> a -> b $ PrettyCallStack -> Either PrettyCallStack a forall a b. a -> Either a b Left PrettyCallStack closed RegistryStatus RegistryOpen -> a -> Either PrettyCallStack a forall a b. b -> Either a b Right (a -> Either PrettyCallStack a) -> State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> State (RegistryState m) a f -- | Allocate key for new resource allocKey :: State (RegistryState m) (Either PrettyCallStack ResourceId) allocKey :: State (RegistryState m) (Either PrettyCallStack ResourceId) allocKey = State (RegistryState m) ResourceId -> State (RegistryState m) (Either PrettyCallStack ResourceId) forall (m :: * -> *) a. State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed (State (RegistryState m) ResourceId -> State (RegistryState m) (Either PrettyCallStack ResourceId)) -> State (RegistryState m) ResourceId -> State (RegistryState m) (Either PrettyCallStack ResourceId) forall a b. (a -> b) -> a -> b $ do ResourceId nextKey <- (RegistryState m -> ResourceId) -> State (RegistryState m) ResourceId forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets RegistryState m -> ResourceId forall (m :: * -> *). RegistryState m -> ResourceId registryNextKey (RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity ()) -> (RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity () forall a b. (a -> b) -> a -> b $ \RegistryState m st -> RegistryState m st {registryNextKey :: ResourceId registryNextKey = ResourceId -> ResourceId forall a. Enum a => a -> a succ ResourceId nextKey} ResourceId -> State (RegistryState m) ResourceId forall (m :: * -> *) a. Monad m => a -> m a return ResourceId nextKey -- | Insert new resource insertResource :: ResourceId -> Resource m -> State (RegistryState m) (Either PrettyCallStack ()) insertResource :: ResourceId -> Resource m -> State (RegistryState m) (Either PrettyCallStack ()) insertResource ResourceId key Resource m r = State (RegistryState m) () -> State (RegistryState m) (Either PrettyCallStack ()) forall (m :: * -> *) a. State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed (State (RegistryState m) () -> State (RegistryState m) (Either PrettyCallStack ())) -> State (RegistryState m) () -> State (RegistryState m) (Either PrettyCallStack ()) forall a b. (a -> b) -> a -> b $ do (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState m -> RegistryState m) -> State (RegistryState m) ()) -> (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall a b. (a -> b) -> a -> b $ \RegistryState m st -> RegistryState m st { registryResources :: Map ResourceId (Resource m) registryResources = ResourceId -> Resource m -> Map ResourceId (Resource m) -> Map ResourceId (Resource m) forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert ResourceId key Resource m r (RegistryState m -> Map ResourceId (Resource m) forall (m :: * -> *). RegistryState m -> Map ResourceId (Resource m) registryResources RegistryState m st) , registryAges :: Bimap ResourceId Age registryAges = ResourceId -> Age -> Bimap ResourceId Age -> Bimap ResourceId Age forall a b. (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b Bimap.insert ResourceId key (RegistryState m -> Age forall (m :: * -> *). RegistryState m -> Age registryNextAge RegistryState m st) (RegistryState m -> Bimap ResourceId Age forall (m :: * -> *). RegistryState m -> Bimap ResourceId Age registryAges RegistryState m st) , registryNextAge :: Age registryNextAge = Age -> Age nextYoungerAge (RegistryState m -> Age forall (m :: * -> *). RegistryState m -> Age registryNextAge RegistryState m st) } -- | Remove resource from the registry (if it exists) removeResource :: ResourceId -> State (RegistryState m) (Maybe (Resource m)) removeResource :: ResourceId -> State (RegistryState m) (Maybe (Resource m)) removeResource ResourceId key = (RegistryState m -> (Maybe (Resource m), RegistryState m)) -> State (RegistryState m) (Maybe (Resource m)) forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a state ((RegistryState m -> (Maybe (Resource m), RegistryState m)) -> State (RegistryState m) (Maybe (Resource m))) -> (RegistryState m -> (Maybe (Resource m), RegistryState m)) -> State (RegistryState m) (Maybe (Resource m)) forall a b. (a -> b) -> a -> b $ \RegistryState m st -> let (Maybe (Resource m) mbResource, Map ResourceId (Resource m) resources') = (ResourceId -> Resource m -> Maybe (Resource m)) -> ResourceId -> Map ResourceId (Resource m) -> (Maybe (Resource m), Map ResourceId (Resource m)) forall k a. Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a) Map.updateLookupWithKey (\ResourceId _ Resource m _ -> Maybe (Resource m) forall a. Maybe a Nothing) ResourceId key (RegistryState m -> Map ResourceId (Resource m) forall (m :: * -> *). RegistryState m -> Map ResourceId (Resource m) registryResources RegistryState m st) st' :: RegistryState m st' = RegistryState m st { registryResources :: Map ResourceId (Resource m) registryResources = Map ResourceId (Resource m) resources' , registryAges :: Bimap ResourceId Age registryAges = ResourceId -> Bimap ResourceId Age -> Bimap ResourceId Age forall a b. (Ord a, Ord b) => a -> Bimap a b -> Bimap a b Bimap.delete ResourceId key (RegistryState m -> Bimap ResourceId Age forall (m :: * -> *). RegistryState m -> Bimap ResourceId Age registryAges RegistryState m st) } in (Maybe (Resource m) mbResource, RegistryState m st') -- | Insert thread into the set of known threads insertThread :: IOLike m => ThreadId m -> State (RegistryState m) () insertThread :: ThreadId m -> State (RegistryState m) () insertThread ThreadId m tid = (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState m -> RegistryState m) -> State (RegistryState m) ()) -> (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall a b. (a -> b) -> a -> b $ \RegistryState m st -> RegistryState m st { registryThreads :: KnownThreads m registryThreads = (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m forall (m :: * -> *). (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m modifyKnownThreads (ThreadId m -> Set (ThreadId m) -> Set (ThreadId m) forall a. Ord a => a -> Set a -> Set a Set.insert ThreadId m tid) (KnownThreads m -> KnownThreads m) -> KnownThreads m -> KnownThreads m forall a b. (a -> b) -> a -> b $ RegistryState m -> KnownThreads m forall (m :: * -> *). RegistryState m -> KnownThreads m registryThreads RegistryState m st } -- | Remove thread from set of known threads removeThread :: IOLike m => ThreadId m -> State (RegistryState m) () removeThread :: ThreadId m -> State (RegistryState m) () removeThread ThreadId m tid = (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState m -> RegistryState m) -> State (RegistryState m) ()) -> (RegistryState m -> RegistryState m) -> State (RegistryState m) () forall a b. (a -> b) -> a -> b $ \RegistryState m st -> RegistryState m st { registryThreads :: KnownThreads m registryThreads = (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m forall (m :: * -> *). (Set (ThreadId m) -> Set (ThreadId m)) -> KnownThreads m -> KnownThreads m modifyKnownThreads (ThreadId m -> Set (ThreadId m) -> Set (ThreadId m) forall a. Ord a => a -> Set a -> Set a Set.delete ThreadId m tid) (KnownThreads m -> KnownThreads m) -> KnownThreads m -> KnownThreads m forall a b. (a -> b) -> a -> b $ RegistryState m -> KnownThreads m forall (m :: * -> *). RegistryState m -> KnownThreads m registryThreads RegistryState m st } -- | Close the registry -- -- Returns the keys currently allocated if the registry is not already closed. -- -- POSTCONDITION: They are returned in youngest-to-oldest order. close :: PrettyCallStack -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) close :: PrettyCallStack -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) close PrettyCallStack closeCallStack = State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) forall (m :: * -> *) a. State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed (State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId])) -> State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) forall a b. (a -> b) -> a -> b $ do (RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity ()) -> (RegistryState m -> RegistryState m) -> StateT (RegistryState m) Identity () forall a b. (a -> b) -> a -> b $ \RegistryState m st -> RegistryState m st {registryStatus :: RegistryStatus registryStatus = PrettyCallStack -> RegistryStatus RegistryClosed PrettyCallStack closeCallStack} (RegistryState m -> [ResourceId]) -> State (RegistryState m) [ResourceId] forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets RegistryState m -> [ResourceId] forall (m :: * -> *). RegistryState m -> [ResourceId] getYoungestToOldest -- | Convenience function for updating the registry state updateState :: forall m a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState :: ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr State (RegistryState m) a f = STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m a -> m a) -> STM m a -> m a forall a b. (a -> b) -> a -> b $ StrictTVar m (RegistryState m) -> (RegistryState m -> (a, RegistryState m)) -> STM m a forall (m :: * -> *) s a. MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a stateTVar (ResourceRegistry m -> StrictTVar m (RegistryState m) forall (m :: * -> *). ResourceRegistry m -> StrictTVar m (RegistryState m) registryState ResourceRegistry m rr) (State (RegistryState m) a -> RegistryState m -> (a, RegistryState m) forall s a. State s a -> s -> (a, s) runState State (RegistryState m) a f) -- | Attempt to allocate a resource in a registry which is closed -- -- When calling 'closeRegistry' (typically, leaving the scope of -- 'withRegistry'), all resources in the registry must be released. If a -- concurrent thread is still allocating resources, we end up with a race -- between the thread trying to allocate new resources and the registry trying -- to free them all. To avoid this, before releasing anything, the registry will -- record itself as closed. Any attempt by a concurrent thread to allocate a new -- resource will then result in a 'RegistryClosedException'. -- -- It is probably not particularly useful for threads to try and catch this -- exception (apart from in a generic handler that does local resource cleanup). -- The thread will anyway soon receive a 'ThreadKilled' exception. data RegistryClosedException = forall m. IOLike m => RegistryClosedException { -- | The context in which the registry was created () registryClosedRegistryContext :: !(Context m) -- | Callstack to the call to 'close' -- -- Note that 'close' can only be called from the same thread that -- created the registry. , RegistryClosedException -> PrettyCallStack registryClosedCloseCallStack :: !PrettyCallStack -- | Context of the call resulting in the exception , () registryClosedAllocContext :: !(Context m) } deriving instance Show RegistryClosedException instance Exception RegistryClosedException {------------------------------------------------------------------------------- Creating and releasing the registry itself -------------------------------------------------------------------------------} -- | Create a new registry -- -- You are strongly encouraged to use 'withRegistry' instead. -- Exported primarily for the benefit of tests. unsafeNewRegistry :: (IOLike m, HasCallStack) => m (ResourceRegistry m) unsafeNewRegistry :: m (ResourceRegistry m) unsafeNewRegistry = do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext StrictTVar m (RegistryState m) stateVar <- RegistryState m -> m (StrictTVar m (RegistryState m)) forall (m :: * -> *) a. (MonadSTM m, HasCallStack, NoThunks a) => a -> m (StrictTVar m a) newTVarIO RegistryState m forall (m :: * -> *). RegistryState m initState ResourceRegistry m -> m (ResourceRegistry m) forall (m :: * -> *) a. Monad m => a -> m a return ResourceRegistry :: forall (m :: * -> *). Context m -> StrictTVar m (RegistryState m) -> ResourceRegistry m ResourceRegistry { registryContext :: Context m registryContext = Context m context , registryState :: StrictTVar m (RegistryState m) registryState = StrictTVar m (RegistryState m) stateVar } where initState :: RegistryState m initState :: RegistryState m initState = RegistryState :: forall (m :: * -> *). KnownThreads m -> Map ResourceId (Resource m) -> ResourceId -> Bimap ResourceId Age -> Age -> RegistryStatus -> RegistryState m RegistryState { registryThreads :: KnownThreads m registryThreads = Set (ThreadId m) -> KnownThreads m forall (m :: * -> *). Set (ThreadId m) -> KnownThreads m KnownThreads Set (ThreadId m) forall a. Set a Set.empty , registryResources :: Map ResourceId (Resource m) registryResources = Map ResourceId (Resource m) forall k a. Map k a Map.empty , registryNextKey :: ResourceId registryNextKey = Int -> ResourceId ResourceId Int 1 , registryAges :: Bimap ResourceId Age registryAges = Bimap ResourceId Age forall a b. Bimap a b Bimap.empty , registryNextAge :: Age registryNextAge = Age ageOfFirstResource , registryStatus :: RegistryStatus registryStatus = RegistryStatus RegistryOpen } -- | Close the registry -- -- This can only be called from the same thread that created the registry. -- This is a no-op if the registry is already closed. -- -- This entire function runs with exceptions masked, so that we are not -- interrupted while we release all resources. -- -- Resources will be allocated from young to old, so that resources allocated -- later can safely refer to resources created earlier. -- -- The release functions are run in the scope of an exception handler, so that -- if releasing one resource throws an exception, we still attempt to release -- the other resources. Should we catch an exception whilst we close the -- registry, we will rethrow it after having attempted to release all resources. -- If there is more than one, we will pick a random one to rethrow, though we -- will prioritize asynchronous exceptions over other exceptions. This may be -- important for exception handlers that catch all-except-asynchronous -- exceptions. closeRegistry :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () closeRegistry :: ResourceRegistry m -> m () closeRegistry ResourceRegistry m rr = m () -> m () forall (m :: * -> *) a. MonadMask m => m a -> m a mask_ (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId Context m context ThreadId m -> ThreadId m -> Bool forall a. Eq a => a -> a -> Bool == Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId (ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr)) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryThreadException -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (ResourceRegistryThreadException -> m ()) -> ResourceRegistryThreadException -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryClosedFromWrongThread :: forall (m :: * -> *). IOLike m => Context m -> Context m -> ResourceRegistryThreadException ResourceRegistryClosedFromWrongThread { resourceRegistryCreatedIn :: Context m resourceRegistryCreatedIn = ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr , resourceRegistryUsedIn :: Context m resourceRegistryUsedIn = Context m context } -- Close the registry so that we cannot allocate any further resources Either PrettyCallStack [ResourceId] alreadyClosed <- ResourceRegistry m -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId]) forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId])) -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId]) forall a b. (a -> b) -> a -> b $ PrettyCallStack -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) forall (m :: * -> *). PrettyCallStack -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) close (Context m -> PrettyCallStack forall (m :: * -> *). Context m -> PrettyCallStack contextCallStack Context m context) case Either PrettyCallStack [ResourceId] alreadyClosed of Left PrettyCallStack _ -> () -> m () forall (m :: * -> *) a. Monad m => a -> m a return () Right [ResourceId] keys -> do -- At this point we have not /removed/ any elements from the map, -- allowing concurrent threads to do their own cleanup of resources -- (this may for instance be important if a thread deallocates its -- resources in a particular order -- note that cancelling a thread -- is a synchronous operation, so we will wait for it to finish -- releasing its resources.) -- /If/ a concurrent thread does some cleanup, then some of the calls -- to 'release' that we do here might be no-ops. m [Context m] -> m () forall (f :: * -> *) a. Functor f => f a -> f () void (m [Context m] -> m ()) -> m [Context m] -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistry m -> [ResourceId] -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] forall (m :: * -> *). IOLike m => ResourceRegistry m -> [ResourceId] -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseResources ResourceRegistry m rr [ResourceId] keys ResourceKey m -> m (Maybe (Context m)) forall (m :: * -> *). (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) release -- | Helper for 'closeRegistry', 'releaseAll', and 'unsafeReleaseAll': release -- the resources allocated with the given 'ResourceId's. -- -- Returns the contexts of the resources that were actually released. releaseResources :: IOLike m => ResourceRegistry m -> [ResourceId] -- ^ PRECONDITION: The currently allocated keys, -- youngest-to-oldest -> (ResourceKey m -> m (Maybe (Context m))) -- ^ How to release the resource, e.g., 'release' or -- 'unsafeRelease'. -> m [Context m] releaseResources :: ResourceRegistry m -> [ResourceId] -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseResources ResourceRegistry m rr [ResourceId] sortedKeys ResourceKey m -> m (Maybe (Context m)) releaser = do ([SomeException] exs, [Maybe (Context m)] mbContexts) <- ([Either SomeException (Maybe (Context m))] -> ([SomeException], [Maybe (Context m)])) -> m [Either SomeException (Maybe (Context m))] -> m ([SomeException], [Maybe (Context m)]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [Either SomeException (Maybe (Context m))] -> ([SomeException], [Maybe (Context m)]) forall a b. [Either a b] -> ([a], [b]) partitionEithers (m [Either SomeException (Maybe (Context m))] -> m ([SomeException], [Maybe (Context m)])) -> m [Either SomeException (Maybe (Context m))] -> m ([SomeException], [Maybe (Context m)]) forall a b. (a -> b) -> a -> b $ [ResourceId] -> (ResourceId -> m (Either SomeException (Maybe (Context m)))) -> m [Either SomeException (Maybe (Context m))] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [ResourceId] sortedKeys ((ResourceId -> m (Either SomeException (Maybe (Context m)))) -> m [Either SomeException (Maybe (Context m))]) -> (ResourceId -> m (Either SomeException (Maybe (Context m)))) -> m [Either SomeException (Maybe (Context m))] forall a b. (a -> b) -> a -> b $ m (Maybe (Context m)) -> m (Either SomeException (Maybe (Context m))) forall (m :: * -> *) e a. (MonadCatch m, Exception e) => m a -> m (Either e a) try (m (Maybe (Context m)) -> m (Either SomeException (Maybe (Context m)))) -> (ResourceId -> m (Maybe (Context m))) -> ResourceId -> m (Either SomeException (Maybe (Context m))) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResourceKey m -> m (Maybe (Context m)) releaser (ResourceKey m -> m (Maybe (Context m))) -> (ResourceId -> ResourceKey m) -> ResourceId -> m (Maybe (Context m)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResourceRegistry m -> ResourceId -> ResourceKey m forall (m :: * -> *). ResourceRegistry m -> ResourceId -> ResourceKey m ResourceKey ResourceRegistry m rr case [SomeException] -> Maybe SomeException prioritize [SomeException] exs of Maybe SomeException Nothing -> [Context m] -> m [Context m] forall (m :: * -> *) a. Monad m => a -> m a return ([Maybe (Context m)] -> [Context m] forall a. [Maybe a] -> [a] catMaybes [Maybe (Context m)] mbContexts) Just SomeException e -> SomeException -> m [Context m] forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO SomeException e where prioritize :: [SomeException] -> Maybe SomeException prioritize :: [SomeException] -> Maybe SomeException prioritize = (\([SomeException] asyncEx, [SomeException] otherEx) -> [SomeException] -> Maybe SomeException forall a. [a] -> Maybe a listToMaybe [SomeException] asyncEx Maybe SomeException -> Maybe SomeException -> Maybe SomeException forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [SomeException] -> Maybe SomeException forall a. [a] -> Maybe a listToMaybe [SomeException] otherEx) (([SomeException], [SomeException]) -> Maybe SomeException) -> ([SomeException] -> ([SomeException], [SomeException])) -> [SomeException] -> Maybe SomeException forall b c a. (b -> c) -> (a -> b) -> a -> c . ([Maybe SomeException] -> [SomeException]) -> ([Maybe SomeException], [SomeException]) -> ([SomeException], [SomeException]) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first [Maybe SomeException] -> [SomeException] forall a. [Maybe a] -> [a] catMaybes (([Maybe SomeException], [SomeException]) -> ([SomeException], [SomeException])) -> ([SomeException] -> ([Maybe SomeException], [SomeException])) -> [SomeException] -> ([SomeException], [SomeException]) forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Maybe SomeException, SomeException)] -> ([Maybe SomeException], [SomeException]) forall a b. [(a, b)] -> ([a], [b]) unzip ([(Maybe SomeException, SomeException)] -> ([Maybe SomeException], [SomeException])) -> ([SomeException] -> [(Maybe SomeException, SomeException)]) -> [SomeException] -> ([Maybe SomeException], [SomeException]) forall b c a. (b -> c) -> (a -> b) -> a -> c . (SomeException -> (Maybe SomeException, SomeException)) -> [SomeException] -> [(Maybe SomeException, SomeException)] forall a b. (a -> b) -> [a] -> [b] map (\SomeException e -> (SomeException -> Maybe SomeException forall e. Exception e => SomeException -> Maybe e asyncExceptionFromException SomeException e, SomeException e)) -- | Create a new registry -- -- See documentation of 'ResourceRegistry' for a detailed discussion. withRegistry :: (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a withRegistry :: (ResourceRegistry m -> m a) -> m a withRegistry = m (ResourceRegistry m) -> (ResourceRegistry m -> m ()) -> (ResourceRegistry m -> m a) -> m a forall (m :: * -> *) a b c. MonadThrow m => m a -> (a -> m b) -> (a -> m c) -> m c bracket m (ResourceRegistry m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (ResourceRegistry m) unsafeNewRegistry ResourceRegistry m -> m () forall (m :: * -> *). (IOLike m, HasCallStack) => ResourceRegistry m -> m () closeRegistry -- | Create a new private registry for use by a bracketed resource -- -- Use this combinator as a more specific and easier-to-maintain alternative to -- the following. -- -- > 'withRegistry' $ \rr -> -- > 'bracket' (newFoo rr) closeFoo $ \foo -> -- > (... rr does not occur in this scope ...) -- -- NB The scoped body can use `withRegistry` if it also needs its own, separate -- registry. -- -- Use this combinator to emphasize that the registry is private to (ie only -- used by and/or via) the bracketed resource and that it thus has nearly the -- same lifetime. This combinator ensures the following specific invariants -- regarding lifetimes and order of releases. -- -- o The registry itself is older than the bracketed resource. -- -- o The only registered resources older than the bracketed resource were -- allocated in the registry by the function that allocated the bracketed -- resource. -- -- o Because of the older resources, the bracketed resource is itself also -- registered in the registry; that's the only way we can be sure to release -- all resources in the right order. -- -- NB Because the registry is private to the resource, the @a@ type could save -- the handle to @registry@ and safely close the registry if the scoped body -- calls @closeA@ before the bracket ends. Though we have not used the type -- system to guarantee that the interface of the @a@ type cannot leak the -- registry to the body, this combinator does its part to keep the registry -- private to the bracketed resource. -- -- See documentation of 'ResourceRegistry' for a more general discussion. bracketWithPrivateRegistry :: (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> (a -> m ()) -- ^ Release the resource -> (a -> m r) -> m r bracketWithPrivateRegistry :: (ResourceRegistry m -> m a) -> (a -> m ()) -> (a -> m r) -> m r bracketWithPrivateRegistry ResourceRegistry m -> m a newA a -> m () closeA a -> m r body = (ResourceRegistry m -> m r) -> m r forall (m :: * -> *) a. (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a withRegistry ((ResourceRegistry m -> m r) -> m r) -> (ResourceRegistry m -> m r) -> m r forall a b. (a -> b) -> a -> b $ \ResourceRegistry m registry -> do (ResourceKey m _key, a a) <- ResourceRegistry m -> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a) forall (m :: * -> *) a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a) allocate ResourceRegistry m registry (\ResourceId _key -> ResourceRegistry m -> m a newA ResourceRegistry m registry) a -> m () closeA a -> m r body a a {------------------------------------------------------------------------------- Temporary registry -------------------------------------------------------------------------------} -- | Run an action with a temporary resource registry. -- -- When allocating resources that are meant to end up in some final state, -- e.g., stored in a 'TVar', after which they are guaranteed to be released -- correctly, it is possible that an exception is thrown after allocating such -- a resource, but before it was stored in the final state. In that case, the -- resource would be leaked. 'runWithTempRegistry' solves that problem. -- -- When no exception is thrown before the end of 'runWithTempRegistry', the -- user must have transferred all the resources it allocated to their final -- state. This means that these resources don't have to be released by the -- temporary registry anymore, the final state is now in charge of releasing -- them. -- -- In case an exception is thrown before the end of 'runWithTempRegistry', -- /all/ resources allocated in the temporary registry will be released. -- -- Resources must be allocated using 'allocateTemp'. -- -- To make sure that the user doesn't forget to transfer a resource to the -- final state @st@, the user must pass a function to 'allocateTemp' that -- checks whether a given @st@ contains the resource, i.e., whether the -- resource was successfully transferred to its final destination. -- -- When no exception is thrown before the end of 'runWithTempRegistry', we -- check whether all allocated resources have been transferred to the final -- state @st@. If there's a resource that hasn't been transferred to the final -- state /and/ that hasn't be released or closed before (see the release -- function passed to 'allocateTemp'), a 'TempRegistryRemainingResource' -- exception will be thrown. -- -- For that reason, 'WithTempRegistry' is parameterised over the final state -- type @st@ and the given 'WithTempRegistry' action must return the final -- state. -- -- NOTE: we explicitly don't let 'runWithTempRegistry' return the final state, -- because the state /must/ have been stored somewhere safely, transferring -- the resources, before the temporary registry is closed. runWithTempRegistry :: (IOLike m, HasCallStack) => WithTempRegistry st m (a, st) -> m a runWithTempRegistry :: WithTempRegistry st m (a, st) -> m a runWithTempRegistry WithTempRegistry st m (a, st) m = (ResourceRegistry m -> m a) -> m a forall (m :: * -> *) a. (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a withRegistry ((ResourceRegistry m -> m a) -> m a) -> (ResourceRegistry m -> m a) -> m a forall a b. (a -> b) -> a -> b $ \ResourceRegistry m rr -> do StrictTVar m (TransferredTo st) varTransferredTo <- TransferredTo st -> m (StrictTVar m (TransferredTo st)) forall (m :: * -> *) a. (MonadSTM m, HasCallStack, NoThunks a) => a -> m (StrictTVar m a) newTVarIO TransferredTo st forall a. Monoid a => a mempty let tempRegistry :: TempRegistry st m tempRegistry = TempRegistry :: forall st (m :: * -> *). ResourceRegistry m -> StrictTVar m (TransferredTo st) -> TempRegistry st m TempRegistry { tempResourceRegistry :: ResourceRegistry m tempResourceRegistry = ResourceRegistry m rr , tempTransferredTo :: StrictTVar m (TransferredTo st) tempTransferredTo = StrictTVar m (TransferredTo st) varTransferredTo } (a a, st st) <- ReaderT (TempRegistry st m) m (a, st) -> TempRegistry st m -> m (a, st) forall r (m :: * -> *) a. ReaderT r m a -> r -> m a runReaderT (WithTempRegistry st m (a, st) -> ReaderT (TempRegistry st m) m (a, st) forall st (m :: * -> *) a. WithTempRegistry st m a -> ReaderT (TempRegistry st m) m a unWithTempRegistry WithTempRegistry st m (a, st) m) TempRegistry st m tempRegistry -- We won't reach this point if an exception is thrown, so we won't check -- for remaining resources in that case. -- -- No need to mask here, whether we throw the async exception or -- 'TempRegistryRemainingResource' doesn't matter. TransferredTo st transferredTo <- STM m (TransferredTo st) -> m (TransferredTo st) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (TransferredTo st) -> m (TransferredTo st)) -> STM m (TransferredTo st) -> m (TransferredTo st) forall a b. (a -> b) -> a -> b $ StrictTVar m (TransferredTo st) -> STM m (TransferredTo st) forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a readTVar StrictTVar m (TransferredTo st) varTransferredTo ResourceRegistry m -> TransferredTo st -> st -> m () forall (m :: * -> *) st. IOLike m => ResourceRegistry m -> TransferredTo st -> st -> m () untrackTransferredTo ResourceRegistry m rr TransferredTo st transferredTo st st Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext [Context m] remainingResources <- ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] forall (m :: * -> *). IOLike m => ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseAllHelper ResourceRegistry m rr Context m context ResourceKey m -> m (Maybe (Context m)) forall (m :: * -> *). (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) release Maybe (Context m) -> (Context m -> m ()) -> m () forall (f :: * -> *) a. Applicative f => Maybe a -> (a -> f ()) -> f () whenJust ([Context m] -> Maybe (Context m) forall a. [a] -> Maybe a listToMaybe [Context m] remainingResources) ((Context m -> m ()) -> m ()) -> (Context m -> m ()) -> m () forall a b. (a -> b) -> a -> b $ \Context m remainingResource -> TempRegistryException -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (TempRegistryException -> m ()) -> TempRegistryException -> m () forall a b. (a -> b) -> a -> b $ TempRegistryRemainingResource :: forall (m :: * -> *). IOLike m => Context m -> Context m -> TempRegistryException TempRegistryRemainingResource { tempRegistryContext :: Context m tempRegistryContext = ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr , tempRegistryResource :: Context m tempRegistryResource = Context m remainingResource } a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a a -- | Embed a self-contained 'WithTempRegistry' computation into a larger one. -- -- The internal 'WithTempRegistry' is effectively passed to -- 'runWithTempRegistry'. It therefore must have no dangling resources, for -- example. This is the meaning of /self-contained/ above. -- -- The key difference beyond 'runWithTempRegistry' is that the resulting -- composite resource is also guaranteed to be registered in the outer -- 'WithTempRegistry' computation's registry once the inner registry is closed. -- Combined with the following assumption, this establishes the invariant that -- all resources are (transitively) in a temporary registry. -- -- As the resource might require some implementation details to be closed, the -- function to close it will also be provided by the inner computation. -- -- ASSUMPTION: closing @res@ closes every resource contained in @innerSt@ -- -- NOTE: In the current implementation, there will be a brief moment where the -- inner registry still contains the inner computation's resources and also the -- outer registry simultaneously contains the new composite resource. If an -- async exception is received at that time, then the inner resources will be -- closed and then the composite resource will be closed. This means there's a -- risk of /double freeing/, which can be harmless if anticipated. runInnerWithTempRegistry :: forall innerSt st m res a. IOLike m => WithTempRegistry innerSt m (a, innerSt, res) -- ^ The embedded computation; see ASSUMPTION above -> (res -> m Bool) -- ^ How to free; same as for 'allocateTemp' -> (st -> res -> Bool) -- ^ How to check; same as for 'allocateTemp' -> WithTempRegistry st m a runInnerWithTempRegistry :: WithTempRegistry innerSt m (a, innerSt, res) -> (res -> m Bool) -> (st -> res -> Bool) -> WithTempRegistry st m a runInnerWithTempRegistry WithTempRegistry innerSt m (a, innerSt, res) inner res -> m Bool free st -> res -> Bool isTransferred = do TempRegistry st m outerTR <- ReaderT (TempRegistry st m) m (TempRegistry st m) -> WithTempRegistry st m (TempRegistry st m) forall st (m :: * -> *) a. ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a WithTempRegistry ReaderT (TempRegistry st m) m (TempRegistry st m) forall r (m :: * -> *). MonadReader r m => m r ask m a -> WithTempRegistry st m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m a -> WithTempRegistry st m a) -> m a -> WithTempRegistry st m a forall a b. (a -> b) -> a -> b $ WithTempRegistry innerSt m (a, innerSt) -> m a forall (m :: * -> *) st a. (IOLike m, HasCallStack) => WithTempRegistry st m (a, st) -> m a runWithTempRegistry (WithTempRegistry innerSt m (a, innerSt) -> m a) -> WithTempRegistry innerSt m (a, innerSt) -> m a forall a b. (a -> b) -> a -> b $ do (a a, innerSt innerSt, res res) <- WithTempRegistry innerSt m (a, innerSt, res) inner -- Allocate in the outer layer. res _ <- TempRegistry st m -> WithTempRegistry st m res -> WithTempRegistry innerSt m res withFixedTempRegistry TempRegistry st m outerTR (WithTempRegistry st m res -> WithTempRegistry innerSt m res) -> WithTempRegistry st m res -> WithTempRegistry innerSt m res forall a b. (a -> b) -> a -> b $ m res -> (res -> m Bool) -> (st -> res -> Bool) -> WithTempRegistry st m res forall (m :: * -> *) a st. (IOLike m, HasCallStack) => m a -> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a allocateTemp (res -> m res forall (m :: * -> *) a. Monad m => a -> m a return res res) res -> m Bool free st -> res -> Bool isTransferred -- TODO This point here is where an async exception could cause both the -- inner resources to be closed and the outer resource to be closed later. -- -- If we want to do better than that, we'll need a variant of -- 'runWithTempRegistry' that lets us perform some action with async -- exceptions masked "at the same time" it closes its registry. -- Note that everything in `inner` allocated via `allocateTemp` must either be -- closed or else present in `innerSt` by this point -- `runWithTempRegistry` -- would have thrown if not. (a, innerSt) -> WithTempRegistry innerSt m (a, innerSt) forall (f :: * -> *) a. Applicative f => a -> f a pure (a a, innerSt innerSt) where withFixedTempRegistry :: TempRegistry st m -> WithTempRegistry st m res -> WithTempRegistry innerSt m res withFixedTempRegistry :: TempRegistry st m -> WithTempRegistry st m res -> WithTempRegistry innerSt m res withFixedTempRegistry TempRegistry st m env (WithTempRegistry (ReaderT TempRegistry st m -> m res f)) = ReaderT (TempRegistry innerSt m) m res -> WithTempRegistry innerSt m res forall st (m :: * -> *) a. ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a WithTempRegistry (ReaderT (TempRegistry innerSt m) m res -> WithTempRegistry innerSt m res) -> ReaderT (TempRegistry innerSt m) m res -> WithTempRegistry innerSt m res forall a b. (a -> b) -> a -> b $ (TempRegistry innerSt m -> m res) -> ReaderT (TempRegistry innerSt m) m res forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a ReaderT ((TempRegistry innerSt m -> m res) -> ReaderT (TempRegistry innerSt m) m res) -> (TempRegistry innerSt m -> m res) -> ReaderT (TempRegistry innerSt m) m res forall a b. (a -> b) -> a -> b $ \TempRegistry innerSt m _ -> TempRegistry st m -> m res f TempRegistry st m env -- | When 'runWithTempRegistry' exits successfully while there are still -- resources remaining in the temporary registry that haven't been transferred -- to the final state. data TempRegistryException = forall m. IOLike m => TempRegistryRemainingResource { -- | The context in which the temporary registry was created. () tempRegistryContext :: !(Context m) -- | The context in which the resource was allocated that was not -- transferred to the final state. , () tempRegistryResource :: !(Context m) } deriving instance Show TempRegistryException instance Exception TempRegistryException -- | Given a final state, return the 'ResourceId's of the resources that have -- been /transferred to/ that state. newtype TransferredTo st = TransferredTo { TransferredTo st -> st -> Set ResourceId runTransferredTo :: st -> Set ResourceId } deriving newtype (b -> TransferredTo st -> TransferredTo st NonEmpty (TransferredTo st) -> TransferredTo st TransferredTo st -> TransferredTo st -> TransferredTo st (TransferredTo st -> TransferredTo st -> TransferredTo st) -> (NonEmpty (TransferredTo st) -> TransferredTo st) -> (forall b. Integral b => b -> TransferredTo st -> TransferredTo st) -> Semigroup (TransferredTo st) forall b. Integral b => b -> TransferredTo st -> TransferredTo st forall st. NonEmpty (TransferredTo st) -> TransferredTo st forall st. TransferredTo st -> TransferredTo st -> TransferredTo st forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a forall st b. Integral b => b -> TransferredTo st -> TransferredTo st stimes :: b -> TransferredTo st -> TransferredTo st $cstimes :: forall st b. Integral b => b -> TransferredTo st -> TransferredTo st sconcat :: NonEmpty (TransferredTo st) -> TransferredTo st $csconcat :: forall st. NonEmpty (TransferredTo st) -> TransferredTo st <> :: TransferredTo st -> TransferredTo st -> TransferredTo st $c<> :: forall st. TransferredTo st -> TransferredTo st -> TransferredTo st Semigroup, Semigroup (TransferredTo st) TransferredTo st Semigroup (TransferredTo st) -> TransferredTo st -> (TransferredTo st -> TransferredTo st -> TransferredTo st) -> ([TransferredTo st] -> TransferredTo st) -> Monoid (TransferredTo st) [TransferredTo st] -> TransferredTo st TransferredTo st -> TransferredTo st -> TransferredTo st forall st. Semigroup (TransferredTo st) forall st. TransferredTo st forall a. Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a forall st. [TransferredTo st] -> TransferredTo st forall st. TransferredTo st -> TransferredTo st -> TransferredTo st mconcat :: [TransferredTo st] -> TransferredTo st $cmconcat :: forall st. [TransferredTo st] -> TransferredTo st mappend :: TransferredTo st -> TransferredTo st -> TransferredTo st $cmappend :: forall st. TransferredTo st -> TransferredTo st -> TransferredTo st mempty :: TransferredTo st $cmempty :: forall st. TransferredTo st $cp1Monoid :: forall st. Semigroup (TransferredTo st) Monoid) deriving Context -> TransferredTo st -> IO (Maybe ThunkInfo) Proxy (TransferredTo st) -> String (Context -> TransferredTo st -> IO (Maybe ThunkInfo)) -> (Context -> TransferredTo st -> IO (Maybe ThunkInfo)) -> (Proxy (TransferredTo st) -> String) -> NoThunks (TransferredTo st) forall st. Context -> TransferredTo st -> IO (Maybe ThunkInfo) forall st. Proxy (TransferredTo st) -> String forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a showTypeOf :: Proxy (TransferredTo st) -> String $cshowTypeOf :: forall st. Proxy (TransferredTo st) -> String wNoThunks :: Context -> TransferredTo st -> IO (Maybe ThunkInfo) $cwNoThunks :: forall st. Context -> TransferredTo st -> IO (Maybe ThunkInfo) noThunks :: Context -> TransferredTo st -> IO (Maybe ThunkInfo) $cnoThunks :: forall st. Context -> TransferredTo st -> IO (Maybe ThunkInfo) NoThunks via OnlyCheckWhnfNamed "TransferredTo" (TransferredTo st) -- | The environment used to run a 'WithTempRegistry' action. data TempRegistry st m = TempRegistry { TempRegistry st m -> ResourceRegistry m tempResourceRegistry :: !(ResourceRegistry m) , TempRegistry st m -> StrictTVar m (TransferredTo st) tempTransferredTo :: !(StrictTVar m (TransferredTo st)) -- ^ Used as a @Writer@. } -- | An action with a temporary registry in scope, see 'runWithTempRegistry' -- for more details. -- -- The most important function to run in this monad is 'allocateTemp'. newtype WithTempRegistry st m a = WithTempRegistry { WithTempRegistry st m a -> ReaderT (TempRegistry st m) m a unWithTempRegistry :: ReaderT (TempRegistry st m) m a } deriving newtype (a -> WithTempRegistry st m b -> WithTempRegistry st m a (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b (forall a b. (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b) -> (forall a b. a -> WithTempRegistry st m b -> WithTempRegistry st m a) -> Functor (WithTempRegistry st m) forall a b. a -> WithTempRegistry st m b -> WithTempRegistry st m a forall a b. (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b forall st (m :: * -> *) a b. Functor m => a -> WithTempRegistry st m b -> WithTempRegistry st m a forall st (m :: * -> *) a b. Functor m => (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> WithTempRegistry st m b -> WithTempRegistry st m a $c<$ :: forall st (m :: * -> *) a b. Functor m => a -> WithTempRegistry st m b -> WithTempRegistry st m a fmap :: (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b $cfmap :: forall st (m :: * -> *) a b. Functor m => (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b Functor, Functor (WithTempRegistry st m) a -> WithTempRegistry st m a Functor (WithTempRegistry st m) -> (forall a. a -> WithTempRegistry st m a) -> (forall a b. WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b) -> (forall a b c. (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c) -> (forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b) -> (forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a) -> Applicative (WithTempRegistry st m) WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c forall a. a -> WithTempRegistry st m a forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b forall a b. WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b forall a b c. (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c forall st (m :: * -> *). Applicative m => Functor (WithTempRegistry st m) forall st (m :: * -> *) a. Applicative m => a -> WithTempRegistry st m a forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b forall st (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c forall (f :: * -> *). Functor f -> (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f <* :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a $c<* :: forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a *> :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b $c*> :: forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b liftA2 :: (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c $cliftA2 :: forall st (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c <*> :: WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b $c<*> :: forall st (m :: * -> *) a b. Applicative m => WithTempRegistry st m (a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b pure :: a -> WithTempRegistry st m a $cpure :: forall st (m :: * -> *) a. Applicative m => a -> WithTempRegistry st m a $cp1Applicative :: forall st (m :: * -> *). Applicative m => Functor (WithTempRegistry st m) Applicative, Applicative (WithTempRegistry st m) a -> WithTempRegistry st m a Applicative (WithTempRegistry st m) -> (forall a b. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b) -> (forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b) -> (forall a. a -> WithTempRegistry st m a) -> Monad (WithTempRegistry st m) WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b forall a. a -> WithTempRegistry st m a forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b forall a b. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b forall st (m :: * -> *). Monad m => Applicative (WithTempRegistry st m) forall st (m :: * -> *) a. Monad m => a -> WithTempRegistry st m a forall st (m :: * -> *) a b. Monad m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b forall st (m :: * -> *) a b. Monad m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b forall (m :: * -> *). Applicative m -> (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m return :: a -> WithTempRegistry st m a $creturn :: forall st (m :: * -> *) a. Monad m => a -> WithTempRegistry st m a >> :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b $c>> :: forall st (m :: * -> *) a b. Monad m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m b >>= :: WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b $c>>= :: forall st (m :: * -> *) a b. Monad m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m b $cp1Monad :: forall st (m :: * -> *). Monad m => Applicative (WithTempRegistry st m) Monad, Monad (WithTempRegistry st m) e -> WithTempRegistry st m a Monad (WithTempRegistry st m) -> (forall e a. Exception e => e -> WithTempRegistry st m a) -> (forall a b c. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c) -> (forall a b c. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c) -> (forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a) -> MonadThrow (WithTempRegistry st m) WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall e a. Exception e => e -> WithTempRegistry st m a forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall a b c. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c forall a b c. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c forall st (m :: * -> *). MonadThrow m => Monad (WithTempRegistry st m) forall st (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> WithTempRegistry st m a forall st (m :: * -> *) a b. MonadThrow m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall st (m :: * -> *) a b c. MonadThrow m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c forall st (m :: * -> *) a b c. MonadThrow m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c forall (m :: * -> *). Monad m -> (forall e a. Exception e => e -> m a) -> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c) -> (forall a b c. m a -> m b -> m c -> m c) -> (forall a b. m a -> m b -> m a) -> MonadThrow m finally :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a $cfinally :: forall st (m :: * -> *) a b. MonadThrow m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a bracket_ :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c $cbracket_ :: forall st (m :: * -> *) a b c. MonadThrow m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m c -> WithTempRegistry st m c bracket :: WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c $cbracket :: forall st (m :: * -> *) a b c. MonadThrow m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c throwIO :: e -> WithTempRegistry st m a $cthrowIO :: forall st (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> WithTempRegistry st m a $cp1MonadThrow :: forall st (m :: * -> *). MonadThrow m => Monad (WithTempRegistry st m) MonadThrow, MonadThrow (WithTempRegistry st m) MonadThrow (WithTempRegistry st m) -> (forall e a. Exception e => WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a) -> (forall e b a. Exception e => (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a) -> (forall e a. Exception e => WithTempRegistry st m a -> WithTempRegistry st m (Either e a)) -> (forall e b a. Exception e => (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a)) -> (forall e a. Exception e => (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a) -> (forall e b a. Exception e => (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a) -> (forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a) -> (forall a b c. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c) -> (forall a b c. WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c)) -> MonadCatch (WithTempRegistry st m) WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a WithTempRegistry st m a -> WithTempRegistry st m (Either e a) WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c) (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a) (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a forall e a. Exception e => WithTempRegistry st m a -> WithTempRegistry st m (Either e a) forall e a. Exception e => WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a forall e a. Exception e => (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a forall a b. WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall e b a. Exception e => (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a) forall e b a. Exception e => (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a forall e b a. Exception e => (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a forall a b c. WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c forall a b c. WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c) forall st (m :: * -> *). MonadCatch m => MonadThrow (WithTempRegistry st m) forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => WithTempRegistry st m a -> WithTempRegistry st m (Either e a) forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a forall st (m :: * -> *) a b. MonadCatch m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a) forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a forall st (m :: * -> *) a b c. MonadCatch m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c forall st (m :: * -> *) a b c. MonadCatch m => WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c) forall (m :: * -> *). MonadThrow m -> (forall e a. Exception e => m a -> (e -> m a) -> m a) -> (forall e b a. Exception e => (e -> Maybe b) -> m a -> (b -> m a) -> m a) -> (forall e a. Exception e => m a -> m (Either e a)) -> (forall e b a. Exception e => (e -> Maybe b) -> m a -> m (Either b a)) -> (forall e a. Exception e => (e -> m a) -> m a -> m a) -> (forall e b a. Exception e => (e -> Maybe b) -> (b -> m a) -> m a -> m a) -> (forall a b. m a -> m b -> m a) -> (forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c) -> (forall a b c. m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)) -> MonadCatch m generalBracket :: WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c) $cgeneralBracket :: forall st (m :: * -> *) a b c. MonadCatch m => WithTempRegistry st m a -> (a -> ExitCase b -> WithTempRegistry st m c) -> (a -> WithTempRegistry st m b) -> WithTempRegistry st m (b, c) bracketOnError :: WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c $cbracketOnError :: forall st (m :: * -> *) a b c. MonadCatch m => WithTempRegistry st m a -> (a -> WithTempRegistry st m b) -> (a -> WithTempRegistry st m c) -> WithTempRegistry st m c onException :: WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a $conException :: forall st (m :: * -> *) a b. MonadCatch m => WithTempRegistry st m a -> WithTempRegistry st m b -> WithTempRegistry st m a handleJust :: (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a $chandleJust :: forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a handle :: (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a $chandle :: forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => (e -> WithTempRegistry st m a) -> WithTempRegistry st m a -> WithTempRegistry st m a tryJust :: (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a) $ctryJust :: forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> WithTempRegistry st m a -> WithTempRegistry st m (Either b a) try :: WithTempRegistry st m a -> WithTempRegistry st m (Either e a) $ctry :: forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => WithTempRegistry st m a -> WithTempRegistry st m (Either e a) catchJust :: (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a $ccatchJust :: forall st (m :: * -> *) e b a. (MonadCatch m, Exception e) => (e -> Maybe b) -> WithTempRegistry st m a -> (b -> WithTempRegistry st m a) -> WithTempRegistry st m a catch :: WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a $ccatch :: forall st (m :: * -> *) e a. (MonadCatch m, Exception e) => WithTempRegistry st m a -> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a $cp1MonadCatch :: forall st (m :: * -> *). MonadCatch m => MonadThrow (WithTempRegistry st m) MonadCatch, MonadCatch (WithTempRegistry st m) MonadCatch (WithTempRegistry st m) -> (forall b. ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b) -> (forall b. ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b) -> (forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> (forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> MonadMask (WithTempRegistry st m) WithTempRegistry st m a -> WithTempRegistry st m a WithTempRegistry st m a -> WithTempRegistry st m a ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b forall a. WithTempRegistry st m a -> WithTempRegistry st m a forall b. ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b forall st (m :: * -> *). MonadMask m => MonadCatch (WithTempRegistry st m) forall st (m :: * -> *) a. MonadMask m => WithTempRegistry st m a -> WithTempRegistry st m a forall st (m :: * -> *) b. MonadMask m => ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b forall (m :: * -> *). MonadCatch m -> (forall b. ((forall a. m a -> m a) -> m b) -> m b) -> (forall b. ((forall a. m a -> m a) -> m b) -> m b) -> (forall a. m a -> m a) -> (forall a. m a -> m a) -> MonadMask m uninterruptibleMask_ :: WithTempRegistry st m a -> WithTempRegistry st m a $cuninterruptibleMask_ :: forall st (m :: * -> *) a. MonadMask m => WithTempRegistry st m a -> WithTempRegistry st m a mask_ :: WithTempRegistry st m a -> WithTempRegistry st m a $cmask_ :: forall st (m :: * -> *) a. MonadMask m => WithTempRegistry st m a -> WithTempRegistry st m a uninterruptibleMask :: ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b $cuninterruptibleMask :: forall st (m :: * -> *) b. MonadMask m => ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b mask :: ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b $cmask :: forall st (m :: * -> *) b. MonadMask m => ((forall a. WithTempRegistry st m a -> WithTempRegistry st m a) -> WithTempRegistry st m b) -> WithTempRegistry st m b $cp1MonadMask :: forall st (m :: * -> *). MonadMask m => MonadCatch (WithTempRegistry st m) MonadMask) instance MonadTrans (WithTempRegistry st) where lift :: m a -> WithTempRegistry st m a lift = ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a forall st (m :: * -> *) a. ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a WithTempRegistry (ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a) -> (m a -> ReaderT (TempRegistry st m) m a) -> m a -> WithTempRegistry st m a forall b c a. (b -> c) -> (a -> b) -> a -> c . m a -> ReaderT (TempRegistry st m) m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift instance MonadState s m => MonadState s (WithTempRegistry st m) where state :: (s -> (a, s)) -> WithTempRegistry st m a state = ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a forall st (m :: * -> *) a. ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a WithTempRegistry (ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a) -> ((s -> (a, s)) -> ReaderT (TempRegistry st m) m a) -> (s -> (a, s)) -> WithTempRegistry st m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (s -> (a, s)) -> ReaderT (TempRegistry st m) m a forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a state -- | Untrack all the resources from the registry that have been transferred to -- the given state. -- -- Untracking a resource means removing it from the registry without releasing -- it. -- -- NOTE: does not check that it's called by the same thread that allocated the -- resources, as it's an internal function only used in 'runWithTempRegistry'. untrackTransferredTo :: IOLike m => ResourceRegistry m -> TransferredTo st -> st -> m () untrackTransferredTo :: ResourceRegistry m -> TransferredTo st -> st -> m () untrackTransferredTo ResourceRegistry m rr TransferredTo st transferredTo st st = ResourceRegistry m -> State (RegistryState m) () -> m () forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) () -> m ()) -> State (RegistryState m) () -> m () forall a b. (a -> b) -> a -> b $ (ResourceId -> StateT (RegistryState m) Identity (Maybe (Resource m))) -> Set ResourceId -> State (RegistryState m) () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ ResourceId -> StateT (RegistryState m) Identity (Maybe (Resource m)) forall (m :: * -> *). ResourceId -> State (RegistryState m) (Maybe (Resource m)) removeResource Set ResourceId rids where rids :: Set ResourceId rids = TransferredTo st -> st -> Set ResourceId forall st. TransferredTo st -> st -> Set ResourceId runTransferredTo TransferredTo st transferredTo st st -- | Allocate a resource in a temporary registry until it has been transferred -- to the final state @st@. See 'runWithTempRegistry' for more details. allocateTemp :: (IOLike m, HasCallStack) => m a -- ^ Allocate the resource -> (a -> m Bool) -- ^ Release the resource, return 'True' when the resource was actually -- released, return 'False' when the resource was already released. -- -- Note that it is safe to always return 'True' when unsure. -> (st -> a -> Bool) -- ^ Check whether the resource is in the given state -> WithTempRegistry st m a allocateTemp :: m a -> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a allocateTemp m a alloc a -> m Bool free st -> a -> Bool isTransferred = ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a forall st (m :: * -> *) a. ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a WithTempRegistry (ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a) -> ReaderT (TempRegistry st m) m a -> WithTempRegistry st m a forall a b. (a -> b) -> a -> b $ do TempRegistry ResourceRegistry m rr StrictTVar m (TransferredTo st) varTransferredTo <- ReaderT (TempRegistry st m) m (TempRegistry st m) forall r (m :: * -> *). MonadReader r m => m r ask (ResourceKey m key, a a) <- m (ResourceKey m, a) -> ReaderT (TempRegistry st m) m (ResourceKey m, a) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m (ResourceKey m, a) -> ReaderT (TempRegistry st m) m (ResourceKey m, a)) -> m (ResourceKey m, a) -> ReaderT (TempRegistry st m) m (ResourceKey m, a) forall a b. (a -> b) -> a -> b $ (Either Void (ResourceKey m, a) -> (ResourceKey m, a)) -> m (Either Void (ResourceKey m, a)) -> m (ResourceKey m, a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Either Void (ResourceKey m, a) -> (ResourceKey m, a) forall a. Either Void a -> a mustBeRight (m (Either Void (ResourceKey m, a)) -> m (ResourceKey m, a)) -> m (Either Void (ResourceKey m, a)) -> m (ResourceKey m, a) forall a b. (a -> b) -> a -> b $ ResourceRegistry m -> (ResourceId -> m (Either Void a)) -> (a -> m Bool) -> m (Either Void (ResourceKey m, a)) forall (m :: * -> *) e a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m (Either e a)) -> (a -> m Bool) -> m (Either e (ResourceKey m, a)) allocateEither ResourceRegistry m rr ((a -> Either Void a) -> m a -> m (Either Void a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Either Void a forall a b. b -> Either a b Right (m a -> m (Either Void a)) -> (ResourceId -> m a) -> ResourceId -> m (Either Void a) forall b c a. (b -> c) -> (a -> b) -> a -> c . m a -> ResourceId -> m a forall a b. a -> b -> a const m a alloc) a -> m Bool free m () -> ReaderT (TempRegistry st m) m () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> ReaderT (TempRegistry st m) m ()) -> m () -> ReaderT (TempRegistry st m) m () forall a b. (a -> b) -> a -> b $ STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ StrictTVar m (TransferredTo st) -> (TransferredTo st -> TransferredTo st) -> STM m () forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () modifyTVar StrictTVar m (TransferredTo st) varTransferredTo ((TransferredTo st -> TransferredTo st) -> STM m ()) -> (TransferredTo st -> TransferredTo st) -> STM m () forall a b. (a -> b) -> a -> b $ TransferredTo st -> TransferredTo st -> TransferredTo st forall a. Monoid a => a -> a -> a mappend (TransferredTo st -> TransferredTo st -> TransferredTo st) -> TransferredTo st -> TransferredTo st -> TransferredTo st forall a b. (a -> b) -> a -> b $ (st -> Set ResourceId) -> TransferredTo st forall st. (st -> Set ResourceId) -> TransferredTo st TransferredTo ((st -> Set ResourceId) -> TransferredTo st) -> (st -> Set ResourceId) -> TransferredTo st forall a b. (a -> b) -> a -> b $ \st st -> if st -> a -> Bool isTransferred st st a a then ResourceId -> Set ResourceId forall a. a -> Set a Set.singleton (ResourceKey m -> ResourceId forall (m :: * -> *). ResourceKey m -> ResourceId resourceKeyId ResourceKey m key) else Set ResourceId forall a. Set a Set.empty a -> ReaderT (TempRegistry st m) m a forall (m :: * -> *) a. Monad m => a -> m a return a a -- | Higher level API on top of 'runWithTempRegistry': modify the given @st@, -- allocating resources in the process that will be transferred to the -- returned @st@. modifyWithTempRegistry :: forall m st a. IOLike m => m st -- ^ Get the state -> (st -> ExitCase st -> m ()) -- ^ Store the new state -> StateT st (WithTempRegistry st m) a -- ^ Modify the state -> m a modifyWithTempRegistry :: m st -> (st -> ExitCase st -> m ()) -> StateT st (WithTempRegistry st m) a -> m a modifyWithTempRegistry m st getSt st -> ExitCase st -> m () putSt StateT st (WithTempRegistry st m) a modSt = WithTempRegistry st m (a, st) -> m a forall (m :: * -> *) st a. (IOLike m, HasCallStack) => WithTempRegistry st m (a, st) -> m a runWithTempRegistry (WithTempRegistry st m (a, st) -> m a) -> WithTempRegistry st m (a, st) -> m a forall a b. (a -> b) -> a -> b $ ((a, st), ()) -> (a, st) forall a b. (a, b) -> a fst (((a, st), ()) -> (a, st)) -> WithTempRegistry st m ((a, st), ()) -> WithTempRegistry st m (a, st) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WithTempRegistry st m st -> (st -> ExitCase (a, st) -> WithTempRegistry st m ()) -> (st -> WithTempRegistry st m (a, st)) -> WithTempRegistry st m ((a, st), ()) forall (m :: * -> *) a b c. MonadCatch m => m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c) generalBracket (m st -> WithTempRegistry st m st forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift m st getSt) st -> ExitCase (a, st) -> WithTempRegistry st m () transfer st -> WithTempRegistry st m (a, st) mutate where transfer :: st -> ExitCase (a, st) -> WithTempRegistry st m () transfer :: st -> ExitCase (a, st) -> WithTempRegistry st m () transfer st initSt ExitCase (a, st) ec = m () -> WithTempRegistry st m () forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m () -> WithTempRegistry st m ()) -> m () -> WithTempRegistry st m () forall a b. (a -> b) -> a -> b $ st -> ExitCase st -> m () putSt st initSt ((a, st) -> st forall a b. (a, b) -> b snd ((a, st) -> st) -> ExitCase (a, st) -> ExitCase st forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ExitCase (a, st) ec) mutate :: st -> WithTempRegistry st m (a, st) mutate :: st -> WithTempRegistry st m (a, st) mutate = StateT st (WithTempRegistry st m) a -> st -> WithTempRegistry st m (a, st) forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) runStateT StateT st (WithTempRegistry st m) a modSt {------------------------------------------------------------------------------- Simple queries on the registry -------------------------------------------------------------------------------} -- | The thread that created the registry registryThread :: ResourceRegistry m -> ThreadId m registryThread :: ResourceRegistry m -> ThreadId m registryThread = Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId (Context m -> ThreadId m) -> (ResourceRegistry m -> Context m) -> ResourceRegistry m -> ThreadId m forall b c a. (b -> c) -> (a -> b) -> a -> c . ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext -- | Number of currently allocated resources -- -- Primarily for the benefit of testing. countResources :: IOLike m => ResourceRegistry m -> m Int countResources :: ResourceRegistry m -> m Int countResources ResourceRegistry m rr = STM m Int -> m Int forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m Int -> m Int) -> STM m Int -> m Int forall a b. (a -> b) -> a -> b $ RegistryState m -> Int forall (m :: * -> *). RegistryState m -> Int aux (RegistryState m -> Int) -> STM m (RegistryState m) -> STM m Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictTVar m (RegistryState m) -> STM m (RegistryState m) forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a readTVar (ResourceRegistry m -> StrictTVar m (RegistryState m) forall (m :: * -> *). ResourceRegistry m -> StrictTVar m (RegistryState m) registryState ResourceRegistry m rr) where aux :: RegistryState m -> Int aux :: RegistryState m -> Int aux = Map ResourceId (Resource m) -> Int forall k a. Map k a -> Int Map.size (Map ResourceId (Resource m) -> Int) -> (RegistryState m -> Map ResourceId (Resource m)) -> RegistryState m -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . RegistryState m -> Map ResourceId (Resource m) forall (m :: * -> *). RegistryState m -> Map ResourceId (Resource m) registryResources {------------------------------------------------------------------------------- Allocating resources -------------------------------------------------------------------------------} -- | Allocate new resource -- -- The allocation function will be run with asynchronous exceptions masked. This -- means that the resource allocation must either be fast or else interruptible; -- see "Dealing with Asynchronous Exceptions during Resource Acquisition" -- <http://www.well-typed.com/blog/97/> for details. allocate :: forall m a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m a) -> (a -> m ()) -- ^ Release the resource -> m (ResourceKey m, a) allocate :: ResourceRegistry m -> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a) allocate ResourceRegistry m rr ResourceId -> m a alloc a -> m () free = Either Void (ResourceKey m, a) -> (ResourceKey m, a) forall a. Either Void a -> a mustBeRight (Either Void (ResourceKey m, a) -> (ResourceKey m, a)) -> m (Either Void (ResourceKey m, a)) -> m (ResourceKey m, a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ResourceRegistry m -> (ResourceId -> m (Either Void a)) -> (a -> m Bool) -> m (Either Void (ResourceKey m, a)) forall (m :: * -> *) e a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m (Either e a)) -> (a -> m Bool) -> m (Either e (ResourceKey m, a)) allocateEither ResourceRegistry m rr ((a -> Either Void a) -> m a -> m (Either Void a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Either Void a forall a b. b -> Either a b Right (m a -> m (Either Void a)) -> (ResourceId -> m a) -> ResourceId -> m (Either Void a) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResourceId -> m a alloc) (\a a -> a -> m () free a a m () -> m Bool -> m Bool forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Bool -> m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool True) -- | Generalization of 'allocate' for allocation functions that may fail allocateEither :: forall m e a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m (Either e a)) -> (a -> m Bool) -- ^ Release the resource, return 'True' when the resource -- hasn't been released or closed before. -> m (Either e (ResourceKey m, a)) allocateEither :: ResourceRegistry m -> (ResourceId -> m (Either e a)) -> (a -> m Bool) -> m (Either e (ResourceKey m, a)) allocateEither ResourceRegistry m rr ResourceId -> m (Either e a) alloc a -> m Bool free = do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext ResourceRegistry m -> Context m -> m () forall (m :: * -> *). IOLike m => ResourceRegistry m -> Context m -> m () ensureKnownThread ResourceRegistry m rr Context m context -- We check if the registry has been closed when we allocate the key, so -- that we can avoid needlessly allocating the resource. Either PrettyCallStack ResourceId mKey <- ResourceRegistry m -> State (RegistryState m) (Either PrettyCallStack ResourceId) -> m (Either PrettyCallStack ResourceId) forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) (Either PrettyCallStack ResourceId) -> m (Either PrettyCallStack ResourceId)) -> State (RegistryState m) (Either PrettyCallStack ResourceId) -> m (Either PrettyCallStack ResourceId) forall a b. (a -> b) -> a -> b $ State (RegistryState m) (Either PrettyCallStack ResourceId) forall (m :: * -> *). State (RegistryState m) (Either PrettyCallStack ResourceId) allocKey case Either PrettyCallStack ResourceId mKey of Left PrettyCallStack closed -> ResourceRegistry m -> Context m -> PrettyCallStack -> m (Either e (ResourceKey m, a)) forall (m :: * -> *) x. IOLike m => ResourceRegistry m -> Context m -> PrettyCallStack -> m x throwRegistryClosed ResourceRegistry m rr Context m context PrettyCallStack closed Right ResourceId key -> m (Either e (ResourceKey m, a)) -> m (Either e (ResourceKey m, a)) forall (m :: * -> *) a. MonadMask m => m a -> m a mask_ (m (Either e (ResourceKey m, a)) -> m (Either e (ResourceKey m, a))) -> m (Either e (ResourceKey m, a)) -> m (Either e (ResourceKey m, a)) forall a b. (a -> b) -> a -> b $ do Either e a ma <- ResourceId -> m (Either e a) alloc ResourceId key case Either e a ma of Left e e -> Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a)) forall (m :: * -> *) a. Monad m => a -> m a return (Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a))) -> Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a)) forall a b. (a -> b) -> a -> b $ e -> Either e (ResourceKey m, a) forall a b. a -> Either a b Left e e Right a a -> do -- TODO: Might want to have an exception handler around this call to -- 'updateState' just in case /that/ throws an exception. Either PrettyCallStack () inserted <- ResourceRegistry m -> State (RegistryState m) (Either PrettyCallStack ()) -> m (Either PrettyCallStack ()) forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) (Either PrettyCallStack ()) -> m (Either PrettyCallStack ())) -> State (RegistryState m) (Either PrettyCallStack ()) -> m (Either PrettyCallStack ()) forall a b. (a -> b) -> a -> b $ ResourceId -> Resource m -> State (RegistryState m) (Either PrettyCallStack ()) forall (m :: * -> *). ResourceId -> Resource m -> State (RegistryState m) (Either PrettyCallStack ()) insertResource ResourceId key (Context m -> a -> Resource m mkResource Context m context a a) case Either PrettyCallStack () inserted of Left PrettyCallStack closed -> do -- Despite the earlier check, it's possible that the registry -- got closed after we allocated a new key but before we got a -- chance to register the resource. In this case, we must -- deallocate the resource again before throwing the exception. m Bool -> m () forall (f :: * -> *) a. Functor f => f a -> f () void (m Bool -> m ()) -> m Bool -> m () forall a b. (a -> b) -> a -> b $ a -> m Bool free a a ResourceRegistry m -> Context m -> PrettyCallStack -> m (Either e (ResourceKey m, a)) forall (m :: * -> *) x. IOLike m => ResourceRegistry m -> Context m -> PrettyCallStack -> m x throwRegistryClosed ResourceRegistry m rr Context m context PrettyCallStack closed Right () -> Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a)) forall (m :: * -> *) a. Monad m => a -> m a return (Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a))) -> Either e (ResourceKey m, a) -> m (Either e (ResourceKey m, a)) forall a b. (a -> b) -> a -> b $ (ResourceKey m, a) -> Either e (ResourceKey m, a) forall a b. b -> Either a b Right (ResourceRegistry m -> ResourceId -> ResourceKey m forall (m :: * -> *). ResourceRegistry m -> ResourceId -> ResourceKey m ResourceKey ResourceRegistry m rr ResourceId key, a a) where mkResource :: Context m -> a -> Resource m mkResource :: Context m -> a -> Resource m mkResource Context m context a a = Resource :: forall (m :: * -> *). Context m -> Release m -> Resource m Resource { resourceContext :: Context m resourceContext = Context m context , resourceRelease :: Release m resourceRelease = m Bool -> Release m forall (m :: * -> *). m Bool -> Release m Release (m Bool -> Release m) -> m Bool -> Release m forall a b. (a -> b) -> a -> b $ a -> m Bool free a a } throwRegistryClosed :: IOLike m => ResourceRegistry m -> Context m -> PrettyCallStack -> m x throwRegistryClosed :: ResourceRegistry m -> Context m -> PrettyCallStack -> m x throwRegistryClosed ResourceRegistry m rr Context m context PrettyCallStack closed = RegistryClosedException -> m x forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO RegistryClosedException :: forall (m :: * -> *). IOLike m => Context m -> PrettyCallStack -> Context m -> RegistryClosedException RegistryClosedException { registryClosedRegistryContext :: Context m registryClosedRegistryContext = ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr , registryClosedCloseCallStack :: PrettyCallStack registryClosedCloseCallStack = PrettyCallStack closed , registryClosedAllocContext :: Context m registryClosedAllocContext = Context m context } -- | Release resource -- -- This deallocates the resource and removes it from the registry. It will be -- the responsibility of the caller to make sure that the resource is no longer -- used in any thread. -- -- The deallocation function is run with exceptions masked, so that we are -- guaranteed not to remove the resource from the registry without releasing it. -- -- Releasing an already released resource is a no-op. -- -- When the resource has not been released before, its context is returned. release :: (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) release :: ResourceKey m -> m (Maybe (Context m)) release key :: ResourceKey m key@(ResourceKey ResourceRegistry m rr ResourceId _) = do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext ResourceRegistry m -> Context m -> m () forall (m :: * -> *). IOLike m => ResourceRegistry m -> Context m -> m () ensureKnownThread ResourceRegistry m rr Context m context ResourceKey m -> m (Maybe (Context m)) forall (m :: * -> *). IOLike m => ResourceKey m -> m (Maybe (Context m)) unsafeRelease ResourceKey m key -- | Unsafe version of 'release' -- -- The only difference between 'release' and 'unsafeRelease' is that the latter -- does not insist that it is called from a thread that is known to the -- registry. This is dangerous, because it implies that there is a thread with -- access to a resource which may be deallocated before that thread is -- terminated. Of course, we can't detect all such situations (when the thread -- merely uses a resource but does not allocate or release we can't tell), but -- normally when we /do/ detect this we throw an exception. -- -- This function should only be used if the above situation can be ruled out -- or handled by other means. unsafeRelease :: IOLike m => ResourceKey m -> m (Maybe (Context m)) unsafeRelease :: ResourceKey m -> m (Maybe (Context m)) unsafeRelease (ResourceKey ResourceRegistry m rr ResourceId rid) = do m (Maybe (Context m)) -> m (Maybe (Context m)) forall (m :: * -> *) a. MonadMask m => m a -> m a mask_ (m (Maybe (Context m)) -> m (Maybe (Context m))) -> m (Maybe (Context m)) -> m (Maybe (Context m)) forall a b. (a -> b) -> a -> b $ do Maybe (Resource m) mResource <- ResourceRegistry m -> State (RegistryState m) (Maybe (Resource m)) -> m (Maybe (Resource m)) forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) (Maybe (Resource m)) -> m (Maybe (Resource m))) -> State (RegistryState m) (Maybe (Resource m)) -> m (Maybe (Resource m)) forall a b. (a -> b) -> a -> b $ ResourceId -> State (RegistryState m) (Maybe (Resource m)) forall (m :: * -> *). ResourceId -> State (RegistryState m) (Maybe (Resource m)) removeResource ResourceId rid case Maybe (Resource m) mResource of Maybe (Resource m) Nothing -> Maybe (Context m) -> m (Maybe (Context m)) forall (m :: * -> *) a. Monad m => a -> m a return Maybe (Context m) forall a. Maybe a Nothing Just Resource m resource -> do Bool actuallyReleased <- Resource m -> m Bool forall (m :: * -> *). Resource m -> m Bool releaseResource Resource m resource Maybe (Context m) -> m (Maybe (Context m)) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe (Context m) -> m (Maybe (Context m))) -> Maybe (Context m) -> m (Maybe (Context m)) forall a b. (a -> b) -> a -> b $ if Bool actuallyReleased then Context m -> Maybe (Context m) forall a. a -> Maybe a Just (Resource m -> Context m forall (m :: * -> *). Resource m -> Context m resourceContext Resource m resource) else Maybe (Context m) forall a. Maybe a Nothing -- | Release all resources in the 'ResourceRegistry' without closing. -- -- See 'closeRegistry' for more details. releaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () releaseAll :: ResourceRegistry m -> m () releaseAll ResourceRegistry m rr = do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId Context m context ThreadId m -> ThreadId m -> Bool forall a. Eq a => a -> a -> Bool == Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId (ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr)) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryThreadException -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (ResourceRegistryThreadException -> m ()) -> ResourceRegistryThreadException -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryClosedFromWrongThread :: forall (m :: * -> *). IOLike m => Context m -> Context m -> ResourceRegistryThreadException ResourceRegistryClosedFromWrongThread { resourceRegistryCreatedIn :: Context m resourceRegistryCreatedIn = ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr , resourceRegistryUsedIn :: Context m resourceRegistryUsedIn = Context m context } m [Context m] -> m () forall (f :: * -> *) a. Functor f => f a -> f () void (m [Context m] -> m ()) -> m [Context m] -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] forall (m :: * -> *). IOLike m => ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseAllHelper ResourceRegistry m rr Context m context ResourceKey m -> m (Maybe (Context m)) forall (m :: * -> *). (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) release -- | This is to 'releaseAll' what 'unsafeRelease' is to 'release': we do not -- insist that this funciton is called from a thread that is known to the -- registry. See 'unsafeRelease' for why this is dangerous. unsafeReleaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () unsafeReleaseAll :: ResourceRegistry m -> m () unsafeReleaseAll ResourceRegistry m rr = do Context m context <- m (Context m) forall (m :: * -> *). (IOLike m, HasCallStack) => m (Context m) captureContext m [Context m] -> m () forall (f :: * -> *) a. Functor f => f a -> f () void (m [Context m] -> m ()) -> m [Context m] -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] forall (m :: * -> *). IOLike m => ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseAllHelper ResourceRegistry m rr Context m context ResourceKey m -> m (Maybe (Context m)) forall (m :: * -> *). IOLike m => ResourceKey m -> m (Maybe (Context m)) unsafeRelease -- | Internal helper used by 'releaseAll' and 'unsafeReleaseAll'. releaseAllHelper :: IOLike m => ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -- ^ How to release a resource -> m [Context m] releaseAllHelper :: ResourceRegistry m -> Context m -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseAllHelper ResourceRegistry m rr Context m context ResourceKey m -> m (Maybe (Context m)) releaser = m [Context m] -> m [Context m] forall (m :: * -> *) a. MonadMask m => m a -> m a mask_ (m [Context m] -> m [Context m]) -> m [Context m] -> m [Context m] forall a b. (a -> b) -> a -> b $ do Either PrettyCallStack [ResourceId] mKeys <- ResourceRegistry m -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId]) forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId])) -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) -> m (Either PrettyCallStack [ResourceId]) forall a b. (a -> b) -> a -> b $ State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) forall (m :: * -> *) a. State (RegistryState m) a -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed (State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId])) -> State (RegistryState m) [ResourceId] -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) forall a b. (a -> b) -> a -> b $ (RegistryState m -> [ResourceId]) -> State (RegistryState m) [ResourceId] forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets RegistryState m -> [ResourceId] forall (m :: * -> *). RegistryState m -> [ResourceId] getYoungestToOldest case Either PrettyCallStack [ResourceId] mKeys of Left PrettyCallStack closed -> ResourceRegistry m -> Context m -> PrettyCallStack -> m [Context m] forall (m :: * -> *) x. IOLike m => ResourceRegistry m -> Context m -> PrettyCallStack -> m x throwRegistryClosed ResourceRegistry m rr Context m context PrettyCallStack closed Right [ResourceId] keys -> ResourceRegistry m -> [ResourceId] -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] forall (m :: * -> *). IOLike m => ResourceRegistry m -> [ResourceId] -> (ResourceKey m -> m (Maybe (Context m))) -> m [Context m] releaseResources ResourceRegistry m rr [ResourceId] keys ResourceKey m -> m (Maybe (Context m)) releaser {------------------------------------------------------------------------------- Threads -------------------------------------------------------------------------------} -- | Thread -- -- The internals of this type are not exported. data Thread m a = IOLike m => Thread { Thread m a -> ThreadId m threadId :: !(ThreadId m) , Thread m a -> ResourceId threadResourceId :: !ResourceId , Thread m a -> Async m a threadAsync :: !(Async m a) , Thread m a -> ResourceRegistry m threadRegistry :: !(ResourceRegistry m) } deriving Context -> Thread m a -> IO (Maybe ThunkInfo) Proxy (Thread m a) -> String (Context -> Thread m a -> IO (Maybe ThunkInfo)) -> (Context -> Thread m a -> IO (Maybe ThunkInfo)) -> (Proxy (Thread m a) -> String) -> NoThunks (Thread m a) forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a forall (m :: * -> *) a. Context -> Thread m a -> IO (Maybe ThunkInfo) forall (m :: * -> *) a. Proxy (Thread m a) -> String showTypeOf :: Proxy (Thread m a) -> String $cshowTypeOf :: forall (m :: * -> *) a. Proxy (Thread m a) -> String wNoThunks :: Context -> Thread m a -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (m :: * -> *) a. Context -> Thread m a -> IO (Maybe ThunkInfo) noThunks :: Context -> Thread m a -> IO (Maybe ThunkInfo) $cnoThunks :: forall (m :: * -> *) a. Context -> Thread m a -> IO (Maybe ThunkInfo) NoThunks via OnlyCheckWhnfNamed "Thread" (Thread m a) -- | 'Eq' instance for 'Thread' compares 'threadId' only. instance Eq (Thread m a) where Thread{threadId :: forall (m :: * -> *) a. Thread m a -> ThreadId m threadId = ThreadId m a} == :: Thread m a -> Thread m a -> Bool == Thread{threadId :: forall (m :: * -> *) a. Thread m a -> ThreadId m threadId = ThreadId m b} = ThreadId m a ThreadId m -> ThreadId m -> Bool forall a. Eq a => a -> a -> Bool == ThreadId m b -- | Cancel a thread -- -- This is a synchronous operation: the thread will have terminated when this -- function returns. -- -- Uses 'uninterruptibleCancel' because that's what 'withAsync' does. cancelThread :: IOLike m => Thread m a -> m () cancelThread :: Thread m a -> m () cancelThread = Async m a -> m () forall (m :: * -> *) a. MonadAsync m => Async m a -> m () uninterruptibleCancel (Async m a -> m ()) -> (Thread m a -> Async m a) -> Thread m a -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . Thread m a -> Async m a forall (m :: * -> *) a. Thread m a -> Async m a threadAsync -- | Wait for thread to terminate and return its result. -- -- If the thread throws an exception, this will rethrow that exception. -- -- NOTE: If A waits on B, and B is linked to the registry, and B throws an -- exception, then A might /either/ receive the exception thrown by B /or/ -- the 'ThreadKilled' exception thrown by the registry. waitThread :: IOLike m => Thread m a -> m a waitThread :: Thread m a -> m a waitThread = Async m a -> m a forall (m :: * -> *) a. MonadAsync m => Async m a -> m a wait (Async m a -> m a) -> (Thread m a -> Async m a) -> Thread m a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . Thread m a -> Async m a forall (m :: * -> *) a. Thread m a -> Async m a threadAsync -- | Lift 'waitAny' to 'Thread' waitAnyThread :: forall m a. IOLike m => [Thread m a] -> m a waitAnyThread :: [Thread m a] -> m a waitAnyThread [Thread m a] ts = (Async m a, a) -> a forall a b. (a, b) -> b snd ((Async m a, a) -> a) -> m (Async m a, a) -> m a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Async m a] -> m (Async m a, a) forall (m :: * -> *) a. MonadAsync m => [Async m a] -> m (Async m a, a) waitAny ((Thread m a -> Async m a) -> [Thread m a] -> [Async m a] forall a b. (a -> b) -> [a] -> [b] map Thread m a -> Async m a forall (m :: * -> *) a. Thread m a -> Async m a threadAsync [Thread m a] ts) -- | Fork a new thread forkThread :: forall m a. (IOLike m, HasCallStack) => ResourceRegistry m -> String -- ^ Label for the thread -> m a -> m (Thread m a) forkThread :: ResourceRegistry m -> String -> m a -> m (Thread m a) forkThread ResourceRegistry m rr String label m a body = (ResourceKey m, Thread m a) -> Thread m a forall a b. (a, b) -> b snd ((ResourceKey m, Thread m a) -> Thread m a) -> m (ResourceKey m, Thread m a) -> m (Thread m a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ResourceRegistry m -> (ResourceId -> m (Thread m a)) -> (Thread m a -> m ()) -> m (ResourceKey m, Thread m a) forall (m :: * -> *) a. (IOLike m, HasCallStack) => ResourceRegistry m -> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a) allocate ResourceRegistry m rr (\ResourceId key -> ResourceId -> Async m a -> Thread m a mkThread ResourceId key (Async m a -> Thread m a) -> m (Async m a) -> m (Thread m a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m a -> m (Async m a) forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a) async (ResourceId -> m a body' ResourceId key)) Thread m a -> m () forall (m :: * -> *) a. IOLike m => Thread m a -> m () cancelThread where mkThread :: ResourceId -> Async m a -> Thread m a mkThread :: ResourceId -> Async m a -> Thread m a mkThread ResourceId rid Async m a child = Thread :: forall (m :: * -> *) a. IOLike m => ThreadId m -> ResourceId -> Async m a -> ResourceRegistry m -> Thread m a Thread { threadId :: ThreadId m threadId = Async m a -> ThreadId m forall (m :: * -> *) a. MonadAsync m => Async m a -> ThreadId m asyncThreadId Async m a child , threadResourceId :: ResourceId threadResourceId = ResourceId rid , threadAsync :: Async m a threadAsync = Async m a child , threadRegistry :: ResourceRegistry m threadRegistry = ResourceRegistry m rr } body' :: ResourceId -> m a body' :: ResourceId -> m a body' ResourceId rid = do ThreadId m me <- m (ThreadId m) forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId ThreadId m -> String -> m () forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m () labelThread ThreadId m me String label (ThreadId m -> m () registerThread ThreadId m me m () -> m a -> m a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> m a body) m a -> m () -> m a forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a `finally` ThreadId m -> ResourceId -> m () unregisterThread ThreadId m me ResourceId rid -- Register the thread -- -- We must add the thread to the list of known threads before the thread -- will start to use the registry. registerThread :: ThreadId m -> m () registerThread :: ThreadId m -> m () registerThread ThreadId m tid = ResourceRegistry m -> State (RegistryState m) () -> m () forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) () -> m ()) -> State (RegistryState m) () -> m () forall a b. (a -> b) -> a -> b $ ThreadId m -> State (RegistryState m) () forall (m :: * -> *). IOLike m => ThreadId m -> State (RegistryState m) () insertThread ThreadId m tid -- Unregister the thread -- -- Threads are the only kinds of resources that "deallocate themselves". -- We remove the thread from the resources as well as the set of known -- threads, so that these datastructures do not grow without bound. -- -- This runs with asynchronous exceptions masked (due to 'finally'), -- though for the current implementation of 'unregisterThread' this -- makes no difference. unregisterThread :: ThreadId m -> ResourceId -> m () unregisterThread :: ThreadId m -> ResourceId -> m () unregisterThread ThreadId m tid ResourceId rid = ResourceRegistry m -> State (RegistryState m) () -> m () forall (m :: * -> *) a. IOLike m => ResourceRegistry m -> State (RegistryState m) a -> m a updateState ResourceRegistry m rr (State (RegistryState m) () -> m ()) -> State (RegistryState m) () -> m () forall a b. (a -> b) -> a -> b $ do ThreadId m -> State (RegistryState m) () forall (m :: * -> *). IOLike m => ThreadId m -> State (RegistryState m) () removeThread ThreadId m tid StateT (RegistryState m) Identity (Maybe (Resource m)) -> State (RegistryState m) () forall (f :: * -> *) a. Functor f => f a -> f () void (StateT (RegistryState m) Identity (Maybe (Resource m)) -> State (RegistryState m) ()) -> StateT (RegistryState m) Identity (Maybe (Resource m)) -> State (RegistryState m) () forall a b. (a -> b) -> a -> b $ ResourceId -> StateT (RegistryState m) Identity (Maybe (Resource m)) forall (m :: * -> *). ResourceId -> State (RegistryState m) (Maybe (Resource m)) removeResource ResourceId rid -- | Bracketed version of 'forkThread' -- -- The analogue of 'withAsync' for the registry. -- -- Scoping thread lifetime using 'withThread' is important when a parent -- thread wants to link to a child thread /and handle any exceptions arising -- from the link/: -- -- > let handleLinkException :: ExceptionInLinkedThread -> m () -- > handleLinkException = .. -- > in handle handleLinkException $ -- > withThread registry codeInChild $ \child -> -- > .. -- -- instead of -- -- > handle handleLinkException $ do -- PROBABLY NOT CORRECT! -- > child <- forkThread registry codeInChild -- > .. -- -- where the parent may exit the scope of the exception handler before the child -- terminates. If the lifetime of the child cannot be limited to the lifetime of -- the parent, the child should probably be linked to the registry instead and -- the thread that spawned the registry should handle any exceptions. -- -- Note that in /principle/ there is no problem in using 'withAync' alongside a -- registry. After all, in a pattern like -- -- > withRegistry $ \registry -> -- > .. -- > withAsync (.. registry ..) $ \async -> -- > .. -- -- the async will be cancelled when leaving the scope of 'withAsync' and so -- that reference to the registry, or indeed any of the resources inside the -- registry, is safe. However, the registry implements a sanity check that the -- registry is only used from known threads. This is useful: when a thread that -- is not known to the registry (in other words, whose lifetime is not tied to -- the lifetime of the registry) spawns a resource in that registry, that -- resource may well be deallocated before the thread terminates, leading to -- undefined and hard to debug behaviour (indeed, whether or not this results in -- problems may well depend on precise timing); an exception that is thrown when -- /allocating/ the resource is (more) deterministic and easier to debug. -- Unfortunately, it means that the above pattern is not applicable, as the -- thread spawned by 'withAsync' is not known to the registry, and so if it were -- to try to use the registry, the registry would throw an error (even though -- this pattern is actually safe). This situation is not ideal, but for now we -- merely provide an alternative to 'withAsync' that /does/ register the thread -- with the registry. -- -- NOTE: Threads that are spawned out of the user's control but that must still -- make use of the registry can use the unsafe API. This should be used with -- caution, however. withThread :: IOLike m => ResourceRegistry m -> String -- ^ Label for the thread -> m a -> (Thread m a -> m b) -> m b withThread :: ResourceRegistry m -> String -> m a -> (Thread m a -> m b) -> m b withThread ResourceRegistry m rr String label m a body = m (Thread m a) -> (Thread m a -> m ()) -> (Thread m a -> m b) -> m b forall (m :: * -> *) a b c. MonadThrow m => m a -> (a -> m b) -> (a -> m c) -> m c bracket (ResourceRegistry m -> String -> m a -> m (Thread m a) forall (m :: * -> *) a. (IOLike m, HasCallStack) => ResourceRegistry m -> String -> m a -> m (Thread m a) forkThread ResourceRegistry m rr String label m a body) Thread m a -> m () forall (m :: * -> *) a. IOLike m => Thread m a -> m () cancelThread -- | Link specified 'Thread' to the (thread that created) the registry linkToRegistry :: IOLike m => Thread m a -> m () linkToRegistry :: Thread m a -> m () linkToRegistry Thread m a t = ThreadId m -> Async m a -> m () forall (m :: * -> *) a. (MonadAsync m, MonadFork m, MonadMask m) => ThreadId m -> Async m a -> m () linkTo (ResourceRegistry m -> ThreadId m forall (m :: * -> *). ResourceRegistry m -> ThreadId m registryThread (ResourceRegistry m -> ThreadId m) -> ResourceRegistry m -> ThreadId m forall a b. (a -> b) -> a -> b $ Thread m a -> ResourceRegistry m forall (m :: * -> *) a. Thread m a -> ResourceRegistry m threadRegistry Thread m a t) (Thread m a -> Async m a forall (m :: * -> *) a. Thread m a -> Async m a threadAsync Thread m a t) -- | Fork a thread and link to it to the registry. -- -- This function is just a convenience. forkLinkedThread :: (IOLike m, HasCallStack) => ResourceRegistry m -> String -- ^ Label for the thread -> m a -> m (Thread m a) forkLinkedThread :: ResourceRegistry m -> String -> m a -> m (Thread m a) forkLinkedThread ResourceRegistry m rr String label m a body = do Thread m a t <- ResourceRegistry m -> String -> m a -> m (Thread m a) forall (m :: * -> *) a. (IOLike m, HasCallStack) => ResourceRegistry m -> String -> m a -> m (Thread m a) forkThread ResourceRegistry m rr String label m a body -- There is no race condition here between the new thread throwing an -- exception and the 'linkToRegistry': if the thread /already/ threw the -- exception when we link it, the exception will be raised immediately -- (see 'linkTo' for details). Thread m a -> m () forall (m :: * -> *) a. IOLike m => Thread m a -> m () linkToRegistry Thread m a t Thread m a -> m (Thread m a) forall (m :: * -> *) a. Monad m => a -> m a return Thread m a t {------------------------------------------------------------------------------- Check that registry is used from known thread -------------------------------------------------------------------------------} ensureKnownThread :: forall m. IOLike m => ResourceRegistry m -> Context m -> m () ensureKnownThread :: ResourceRegistry m -> Context m -> m () ensureKnownThread ResourceRegistry m rr Context m context = do Bool isKnown <- m Bool checkIsKnown Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool isKnown (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryThreadException -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (ResourceRegistryThreadException -> m ()) -> ResourceRegistryThreadException -> m () forall a b. (a -> b) -> a -> b $ ResourceRegistryUsedFromUntrackedThread :: forall (m :: * -> *). IOLike m => Context m -> Context m -> ResourceRegistryThreadException ResourceRegistryUsedFromUntrackedThread { resourceRegistryCreatedIn :: Context m resourceRegistryCreatedIn = ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr , resourceRegistryUsedIn :: Context m resourceRegistryUsedIn = Context m context } where checkIsKnown :: m Bool checkIsKnown :: m Bool checkIsKnown | Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId Context m context ThreadId m -> ThreadId m -> Bool forall a. Eq a => a -> a -> Bool == Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId (ResourceRegistry m -> Context m forall (m :: * -> *). ResourceRegistry m -> Context m registryContext ResourceRegistry m rr) = Bool -> m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool True | Bool otherwise = STM m Bool -> m Bool forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool forall a b. (a -> b) -> a -> b $ do KnownThreads Set (ThreadId m) ts <- RegistryState m -> KnownThreads m forall (m :: * -> *). RegistryState m -> KnownThreads m registryThreads (RegistryState m -> KnownThreads m) -> STM m (RegistryState m) -> STM m (KnownThreads m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StrictTVar m (RegistryState m) -> STM m (RegistryState m) forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a readTVar (ResourceRegistry m -> StrictTVar m (RegistryState m) forall (m :: * -> *). ResourceRegistry m -> StrictTVar m (RegistryState m) registryState ResourceRegistry m rr) Bool -> STM m Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> STM m Bool) -> Bool -> STM m Bool forall a b. (a -> b) -> a -> b $ Context m -> ThreadId m forall (m :: * -> *). Context m -> ThreadId m contextThreadId Context m context ThreadId m -> Set (ThreadId m) -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set (ThreadId m) ts -- | Registry used from untracked threads -- -- If this exception is raised, it indicates a bug in the caller. data ResourceRegistryThreadException = -- | If the registry is used from an untracked thread, we cannot do proper -- reference counting. The following threads are /tracked/: the thread -- that spawned the registry and all threads spawned by the registry. forall m. IOLike m => ResourceRegistryUsedFromUntrackedThread { -- | Information about the context in which the registry was created () resourceRegistryCreatedIn :: !(Context m) -- | The context in which it was used , () resourceRegistryUsedIn :: !(Context m) } -- | Registry closed from different threat than that created it | forall m. IOLike m => ResourceRegistryClosedFromWrongThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) -- | The context in which it was used , resourceRegistryUsedIn :: !(Context m) } deriving instance Show ResourceRegistryThreadException instance Exception ResourceRegistryThreadException {------------------------------------------------------------------------------- Auxiliary: context -------------------------------------------------------------------------------} data Context m = IOLike m => Context { -- | CallStack in which it was created Context m -> PrettyCallStack contextCallStack :: !PrettyCallStack -- | Thread that created the registry or resource , Context m -> ThreadId m contextThreadId :: !(ThreadId m) } -- Existential type; we can't use generics instance NoThunks (Context m) where showTypeOf :: Proxy (Context m) -> String showTypeOf Proxy (Context m) _ = String "Context" wNoThunks :: Context -> Context m -> IO (Maybe ThunkInfo) wNoThunks Context ctxt (Context PrettyCallStack cs ThreadId m tid) = [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo) allNoThunks [ Context -> PrettyCallStack -> IO (Maybe ThunkInfo) forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo) noThunks Context ctxt PrettyCallStack cs , Context -> InspectHeapNamed "ThreadId" (ThreadId m) -> IO (Maybe ThunkInfo) forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo) noThunks Context ctxt (ThreadId m -> InspectHeapNamed "ThreadId" (ThreadId m) forall (name :: Symbol) a. a -> InspectHeapNamed name a InspectHeapNamed @"ThreadId" ThreadId m tid) ] deriving instance Show (Context m) captureContext :: IOLike m => HasCallStack => m (Context m) captureContext :: m (Context m) captureContext = PrettyCallStack -> ThreadId m -> Context m forall (m :: * -> *). IOLike m => PrettyCallStack -> ThreadId m -> Context m Context PrettyCallStack HasCallStack => PrettyCallStack prettyCallStack (ThreadId m -> Context m) -> m (ThreadId m) -> m (Context m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m (ThreadId m) forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId