{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans            #-}

-- | 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
-- 'Control.Monad.Class.MonadFork.forkIO' is no solution as it means we might
-- leak resources. There is however another problem with
-- 'Control.Monad.Class.MonadFork.forkIO'. Consider this snippet:
--
-- > withRegistry $ \registry ->
-- >   r <- allocate registry allocateResource releaseResource
-- >   forkIO $ .. 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.

module Control.ResourceRegistry (
    -- * The resource registry proper
    Context
  , ResourceId
  , ResourceRegistry
    -- * Exceptions
  , RegistryClosedException (..)
  , ResourceRegistryThreadException
    -- * Creating and releasing the registry itself
  , bracketWithPrivateRegistry
  , registryThread
  , withRegistry
    -- * Allocating and releasing regular resources
  , ResourceKey
  , allocate
  , allocateEither
  , release
  , releaseAll
  , unsafeRelease
  , unsafeReleaseAll
    -- * Threads
  , Thread
  , cancelThread
  , forkLinkedThread
  , forkThread
  , linkToRegistry
  , threadId
  , waitAnyThread
  , waitThread
  , withThread
    -- * Temporary registry
  , TempRegistryException (..)
  , WithTempRegistry
  , allocateTemp
  , modifyWithTempRegistry
  , runInnerWithTempRegistry
  , runWithTempRegistry
    -- * Unsafe combinators primarily for testing
  , closeRegistry
  , countResources
  , unsafeNewRegistry
  ) where

import Control.Applicative ((<|>))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (asyncExceptionFromException)
import Control.Monad
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadThrow
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.Bimap (Bimap)
import Data.Bimap qualified as Bimap
import Data.Either (partitionEithers)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, listToMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Void
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack (CallStack, HasCallStack)
import GHC.Stack qualified as GHC
import NoThunks.Class hiding (Context)

-- | Tracks resources during their lifetime.
data ResourceRegistry m = ResourceRegistry {
      -- | Context in which the registry was created
      forall (m :: * -> *). ResourceRegistry m -> Context m
registryContext :: !(Context m)

      -- | Registry state
    , forall (m :: * -> *).
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
$cfrom :: forall (m :: * -> *) x.
ResourceRegistry m -> Rep (ResourceRegistry m) x
from :: forall x. ResourceRegistry m -> Rep (ResourceRegistry m) x
$cto :: forall (m :: * -> *) x.
Rep (ResourceRegistry m) x -> ResourceRegistry m
to :: forall x. Rep (ResourceRegistry m) x -> ResourceRegistry m
Generic)

deriving instance (forall a. NoThunks a => NoThunks (StrictTVar m a))
               => 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
$cshowsPrec :: Int -> Age -> ShowS
showsPrec :: Int -> Age -> ShowS
$cshow :: Age -> String
show :: Age -> String
$cshowList :: [Age] -> ShowS
showList :: [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
$c== :: Age -> Age -> Bool
== :: Age -> Age -> Bool
$c/= :: Age -> Age -> Bool
/= :: 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
$ccompare :: Age -> Age -> Ordering
compare :: Age -> Age -> Ordering
$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
>= :: Age -> Age -> Bool
$cmax :: Age -> Age -> Age
max :: Age -> Age -> Age
$cmin :: Age -> Age -> Age
min :: Age -> Age -> 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
$cnoThunks :: Context -> Age -> IO (Maybe ThunkInfo)
noThunks :: Context -> Age -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Age -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Age -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Age -> String
showTypeOf :: Proxy Age -> String
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
data RegistryState m = RegistryState {
      -- | Forked threads
      forall (m :: * -> *). RegistryState m -> KnownThreads m
registryThreads   :: !(KnownThreads m)

      -- | Currently allocated resources
      --
      -- INVARIANT: We record exactly the ages of currently allocated resources,
      -- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@.
    , forall (m :: * -> *).
RegistryState m -> Map ResourceId (Resource m)
registryResources :: !(Map ResourceId (Resource m))

      -- | Next available resource key
    , forall (m :: * -> *). 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.
    , forall (m :: * -> *). RegistryState m -> Bimap ResourceId Age
registryAges      :: !(Bimap ResourceId Age)

      -- | The age of the next resource
    , forall (m :: * -> *). RegistryState m -> Age
registryNextAge   :: !Age

      -- | Does the registry still accept new allocations?
      --
      -- See 'RegistryClosedException' for discussion.
    , forall (m :: * -> *). 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
$cfrom :: forall (m :: * -> *) x. RegistryState m -> Rep (RegistryState m) x
from :: forall x. RegistryState m -> Rep (RegistryState m) x
$cto :: forall (m :: * -> *) x. Rep (RegistryState m) x -> RegistryState m
to :: forall x. Rep (RegistryState m) x -> RegistryState m
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
$cnoThunks :: forall (m :: * -> *).
Context -> RegistryState m -> IO (Maybe ThunkInfo)
noThunks :: Context -> RegistryState m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> RegistryState m -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> RegistryState m -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (RegistryState m) -> String
showTypeOf :: Proxy (RegistryState m) -> String
NoThunks)

-- | The currently allocated keys in youngest-to-oldest order
getYoungestToOldest :: RegistryState m -> [ResourceId]
getYoungestToOldest :: forall (m :: * -> *). 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
$cnoThunks :: forall (m :: * -> *).
Context -> KnownThreads m -> IO (Maybe ThunkInfo)
noThunks :: Context -> KnownThreads m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> KnownThreads m -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> KnownThreads m -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (KnownThreads m) -> String
showTypeOf :: Proxy (KnownThreads m) -> String
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
$cfrom :: forall x. RegistryStatus -> Rep RegistryStatus x
from :: forall x. RegistryStatus -> Rep RegistryStatus x
$cto :: forall x. Rep RegistryStatus x -> RegistryStatus
to :: forall x. Rep RegistryStatus x -> RegistryStatus
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
$cnoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo)
noThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> RegistryStatus -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy RegistryStatus -> String
showTypeOf :: Proxy RegistryStatus -> String
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
$cfrom :: forall (m :: * -> *) x. ResourceKey m -> Rep (ResourceKey m) x
from :: forall x. ResourceKey m -> Rep (ResourceKey m) x
$cto :: forall (m :: * -> *) x. Rep (ResourceKey m) x -> ResourceKey m
to :: forall x. Rep (ResourceKey m) x -> ResourceKey m
Generic

deriving instance NoThunks (ResourceRegistry m)
               => NoThunks (ResourceKey m)

-- | Return the 'ResourceId' of a 'ResourceKey'.
resourceKeyId :: ResourceKey m -> ResourceId
resourceKeyId :: forall (m :: * -> *). 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
$cshowsPrec :: Int -> ResourceId -> ShowS
showsPrec :: Int -> ResourceId -> ShowS
$cshow :: ResourceId -> String
show :: ResourceId -> String
$cshowList :: [ResourceId] -> ShowS
showList :: [ResourceId] -> ShowS
Show, ResourceId -> ResourceId -> Bool
(ResourceId -> ResourceId -> Bool)
-> (ResourceId -> ResourceId -> Bool) -> Eq ResourceId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResourceId -> ResourceId -> Bool
== :: ResourceId -> ResourceId -> Bool
$c/= :: ResourceId -> ResourceId -> Bool
/= :: 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
$ccompare :: ResourceId -> ResourceId -> Ordering
compare :: ResourceId -> ResourceId -> Ordering
$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
>= :: ResourceId -> ResourceId -> Bool
$cmax :: ResourceId -> ResourceId -> ResourceId
max :: ResourceId -> ResourceId -> ResourceId
$cmin :: ResourceId -> ResourceId -> ResourceId
min :: ResourceId -> ResourceId -> 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
$csucc :: ResourceId -> ResourceId
succ :: ResourceId -> ResourceId
$cpred :: ResourceId -> ResourceId
pred :: ResourceId -> ResourceId
$ctoEnum :: Int -> ResourceId
toEnum :: Int -> ResourceId
$cfromEnum :: ResourceId -> Int
fromEnum :: ResourceId -> Int
$cenumFrom :: ResourceId -> [ResourceId]
enumFrom :: ResourceId -> [ResourceId]
$cenumFromThen :: ResourceId -> ResourceId -> [ResourceId]
enumFromThen :: ResourceId -> ResourceId -> [ResourceId]
$cenumFromTo :: ResourceId -> ResourceId -> [ResourceId]
enumFromTo :: ResourceId -> ResourceId -> [ResourceId]
$cenumFromThenTo :: ResourceId -> ResourceId -> ResourceId -> [ResourceId]
enumFromThenTo :: ResourceId -> ResourceId -> 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
$cnoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo)
noThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ResourceId -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ResourceId -> String
showTypeOf :: Proxy ResourceId -> String
NoThunks)

-- | Information about a resource
data Resource m = Resource {
      -- | Context in which the resource was created
      forall (m :: * -> *). Resource m -> Context m
resourceContext :: !(Context m)

      -- | Deallocate the resource
    , forall (m :: * -> *). 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
$cfrom :: forall (m :: * -> *) x. Resource m -> Rep (Resource m) x
from :: forall x. Resource m -> Rep (Resource m) x
$cto :: forall (m :: * -> *) x. Rep (Resource m) x -> Resource m
to :: forall x. Rep (Resource m) x -> Resource m
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
$cnoThunks :: forall (m :: * -> *). Context -> Resource m -> IO (Maybe ThunkInfo)
noThunks :: Context -> Resource m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *). Context -> Resource m -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Resource m -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (Resource m) -> String
showTypeOf :: Proxy (Resource m) -> String
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
$cnoThunks :: forall (m :: * -> *). Context -> Release m -> IO (Maybe ThunkInfo)
noThunks :: Context -> Release m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *). Context -> Release m -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Release m -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (Release m) -> String
showTypeOf :: Proxy (Release m) -> String
NoThunks via OnlyCheckWhnfNamed "Release" (Release m)

releaseResource :: Resource m -> m Bool
releaseResource :: forall (m :: * -> *). 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 :: forall (m :: * -> *).
(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 :: forall (m :: * -> *) a.
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 a. a -> StateT (RegistryState m) Identity 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 :: forall (m :: * -> *).
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 = succ nextKey}
    ResourceId -> State (RegistryState m) ResourceId
forall a. a -> StateT (RegistryState m) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ResourceId
nextKey

-- | Insert new resource
insertResource ::
     ResourceId
  -> Resource m
  -> State (RegistryState m) (Either PrettyCallStack ())
insertResource :: forall (m :: * -> *).
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.insert key r (registryResources st)
      , registryAges      = Bimap.insert
                              key
                              (registryNextAge st)
                              (registryAges st)
      , registryNextAge   = nextYoungerAge (registryNextAge st)
      }

-- | Remove resource from the registry (if it exists)
removeResource :: ResourceId -> State (RegistryState m) (Maybe (Resource m))
removeResource :: forall (m :: * -> *).
ResourceId -> State (RegistryState m) (Maybe (Resource m))
removeResource ResourceId
key = (RegistryState m -> (Maybe (Resource m), RegistryState m))
-> StateT (RegistryState m) Identity (Maybe (Resource m))
forall a.
(RegistryState m -> (a, RegistryState m))
-> StateT (RegistryState m) Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((RegistryState m -> (Maybe (Resource m), RegistryState m))
 -> StateT (RegistryState m) Identity (Maybe (Resource m)))
-> (RegistryState m -> (Maybe (Resource m), RegistryState m))
-> StateT (RegistryState m) Identity (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 = resources'
          , registryAges      = Bimap.delete key (registryAges st)
          }
    in  (Maybe (Resource m)
mbResource, RegistryState m
st')

-- | Insert thread into the set of known threads
insertThread :: MonadThread m => ThreadId m -> State (RegistryState m) ()
insertThread :: forall (m :: * -> *).
MonadThread m =>
ThreadId m -> State (RegistryState m) ()
insertThread ThreadId m
tid =
    (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 {
        registryThreads = modifyKnownThreads (Set.insert tid) $
                            registryThreads st
      }

-- | Remove thread from set of known threads
removeThread :: MonadThread m => ThreadId m -> State (RegistryState m) ()
removeThread :: forall (m :: * -> *).
MonadThread m =>
ThreadId m -> State (RegistryState m) ()
removeThread ThreadId m
tid =
    (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 {
        registryThreads = modifyKnownThreads (Set.delete tid) $
                            registryThreads 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 :: forall (m :: * -> *).
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 = RegistryClosed 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.
     MonadSTM m
  => ResourceRegistry m
  -> State (RegistryState m) a
  -> m a
updateState :: forall (m :: * -> *) a.
MonadSTM m =>
ResourceRegistry m -> State (RegistryState m) a -> m a
updateState ResourceRegistry m
rr State (RegistryState m) a
f =
    STM m a -> m a
forall a. HasCallStack => 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 'Control.Exception.ThreadKilled'
-- exception.
data RegistryClosedException =
    forall m. MonadThread m => RegistryClosedException {
        -- | The context in which the registry was created
        ()
registryClosedRegistryContext :: !(Context m)

        -- | Callstack to the call to 'closeRegistry'
        --
        -- Note that 'closeRegistry' 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 ::
     (MonadSTM m, MonadThread m, HasCallStack)
  => m (ResourceRegistry m)
unsafeNewRegistry :: forall (m :: * -> *).
(MonadSTM m, MonadThread m, HasCallStack) =>
m (ResourceRegistry m)
unsafeNewRegistry = do
    Context m
context  <- m (Context m)
forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
m (Context m)
captureContext
    StrictTVar m (RegistryState m)
stateVar <- RegistryState m -> m (StrictTVar m (RegistryState m))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO RegistryState m
forall (m :: * -> *). RegistryState m
initState
    ResourceRegistry m -> m (ResourceRegistry m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ResourceRegistry {
          registryContext :: Context m
registryContext = Context m
context
        , registryState :: StrictTVar m (RegistryState m)
registryState   = StrictTVar m (RegistryState m)
stateVar
        }
  where
    initState :: RegistryState m
    initState :: forall (m :: * -> *). RegistryState m
initState = 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 ::
     (MonadMask m, MonadThread m, MonadSTM m, HasCallStack)
  => ResourceRegistry m
  -> m ()
closeRegistry :: forall (m :: * -> *).
(MonadMask m, MonadThread m, MonadSTM m, HasCallStack) =>
ResourceRegistry m -> m ()
closeRegistry ResourceRegistry m
rr = m () -> m ()
forall a. m a -> m a
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 :: * -> *).
(MonadThread 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 e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ResourceRegistryThreadException -> m ())
-> ResourceRegistryThreadException -> m ()
forall a b. (a -> b) -> a -> b
$ 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.
MonadSTM 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 a. a -> m a
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 :: * -> *).
MonadCatch 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 :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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 ::
     MonadCatch 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 :: forall (m :: * -> *).
MonadCatch m =>
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 a b. (a -> b) -> m a -> m b
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 e a. Exception e => m a -> m (Either e a)
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 a. a -> m a
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 e a. Exception e => e -> m a
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 a. Maybe a -> Maybe a -> Maybe a
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 a b c. (a -> b) -> (a, c) -> (b, c)
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 ::
     (MonadSTM m, MonadMask m, MonadThread m, HasCallStack)
  => (ResourceRegistry m -> m a)
  -> m a
withRegistry :: forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry = m (ResourceRegistry m)
-> (ResourceRegistry m -> m ())
-> (ResourceRegistry m -> m a)
-> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (ResourceRegistry m)
forall (m :: * -> *).
(MonadSTM m, MonadThread m, HasCallStack) =>
m (ResourceRegistry m)
unsafeNewRegistry ResourceRegistry m -> m ()
forall (m :: * -> *).
(MonadMask m, MonadThread m, MonadSTM 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 ::
     (MonadSTM m, MonadMask m, MonadThread m, HasCallStack)
  => (ResourceRegistry m -> m a)
  -> (a -> m ())  -- ^ Release the resource
  -> (a -> m r)
  -> m r
bracketWithPrivateRegistry :: forall (m :: * -> *) a r.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(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.
(MonadSTM m, MonadMask m, MonadThread 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.
(MonadSTM m, MonadMask m, MonadThread 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 'Control.Monad.Class.MonadSTM.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 ::
     (MonadSTM m, MonadMask m, MonadThread m, HasCallStack)
  => WithTempRegistry st m (a, st)
  -> m a
runWithTempRegistry :: forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry WithTempRegistry st m (a, st)
m = (ResourceRegistry m -> m a) -> m a
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread 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 => a -> m (StrictTVar m a)
newTVarIO TransferredTo st
forall a. Monoid a => a
mempty
    let tempRegistry :: TempRegistry st m
tempRegistry = 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 <- StrictTVar m (TransferredTo st) -> m (TransferredTo st)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (TransferredTo st)
varTransferredTo
    ResourceRegistry m -> TransferredTo st -> st -> m ()
forall (m :: * -> *) st.
MonadSTM m =>
ResourceRegistry m -> TransferredTo st -> st -> m ()
untrackTransferredTo ResourceRegistry m
rr TransferredTo st
transferredTo st
st

    Context m
context <- m (Context m)
forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
m (Context m)
captureContext
    [Context m]
remainingResources <- ResourceRegistry m
-> Context m
-> (ResourceKey m -> m (Maybe (Context m)))
-> m [Context m]
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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 :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release

    Maybe (Context m) -> (Context m -> m ()) -> m ()
forall {f :: * -> *} {t}.
Applicative f =>
Maybe t -> (t -> 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 e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (TempRegistryException -> m ()) -> TempRegistryException -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

    where
        whenJust :: Maybe t -> (t -> f ()) -> f ()
whenJust (Just t
x) t -> f ()
f = t -> f ()
f t
x
        whenJust Maybe t
Nothing t -> f ()
_  = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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.
     (MonadSTM m, MonadMask m, MonadThread 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 :: forall innerSt st (m :: * -> *) res a.
(MonadSTM m, MonadMask m, MonadThread m) =>
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 (m :: * -> *) a. Monad m => 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.
(MonadSTM m, MonadMask m, MonadThread 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.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
m a
-> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a
allocateTemp (res -> m res
forall a. a -> m a
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 a. a -> WithTempRegistry innerSt m a
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. MonadThread 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 {
      forall st. TransferredTo st -> st -> Set ResourceId
runTransferredTo :: st -> Set ResourceId
    }
  deriving newtype (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
$c<> :: forall st. TransferredTo st -> TransferredTo st -> TransferredTo st
<> :: TransferredTo st -> TransferredTo st -> TransferredTo st
$csconcat :: forall st. NonEmpty (TransferredTo st) -> TransferredTo st
sconcat :: NonEmpty (TransferredTo st) -> TransferredTo st
$cstimes :: forall st b.
Integral b =>
b -> TransferredTo st -> TransferredTo st
stimes :: forall b. Integral b => b -> 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
$cmempty :: forall st. TransferredTo st
mempty :: TransferredTo st
$cmappend :: forall st. TransferredTo st -> TransferredTo st -> TransferredTo st
mappend :: TransferredTo st -> TransferredTo st -> TransferredTo st
$cmconcat :: forall st. [TransferredTo st] -> TransferredTo st
mconcat :: [TransferredTo st] -> 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
$cnoThunks :: forall st. Context -> TransferredTo st -> IO (Maybe ThunkInfo)
noThunks :: Context -> TransferredTo st -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall st. Context -> TransferredTo st -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TransferredTo st -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall st. Proxy (TransferredTo st) -> String
showTypeOf :: Proxy (TransferredTo st) -> String
NoThunks via OnlyCheckWhnfNamed "TransferredTo" (TransferredTo st)

-- | The environment used to run a 'WithTempRegistry' action.
data TempRegistry st m = TempRegistry {
      forall st (m :: * -> *). TempRegistry st m -> ResourceRegistry m
tempResourceRegistry :: !(ResourceRegistry m)
    , forall st (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 {
      forall st (m :: * -> *) a.
WithTempRegistry st m a -> ReaderT (TempRegistry st m) m a
unWithTempRegistry :: ReaderT (TempRegistry st m) m a
    }
  deriving newtype ( (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
$cfmap :: forall st (m :: * -> *) a b.
Functor m =>
(a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b
fmap :: forall a b.
(a -> b) -> WithTempRegistry st m a -> WithTempRegistry st m b
$c<$ :: forall st (m :: * -> *) a b.
Functor m =>
a -> WithTempRegistry st m b -> WithTempRegistry st m a
<$ :: forall a b. a -> WithTempRegistry st m b -> WithTempRegistry st m a
Functor
                   , Functor (WithTempRegistry st m)
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)
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
$cpure :: forall st (m :: * -> *) a.
Applicative m =>
a -> WithTempRegistry st m a
pure :: forall a. a -> WithTempRegistry st m a
$c<*> :: forall st (m :: * -> *) a b.
Applicative m =>
WithTempRegistry st m (a -> b)
-> WithTempRegistry st m a -> WithTempRegistry st m b
<*> :: forall a b.
WithTempRegistry st m (a -> b)
-> WithTempRegistry st m a -> WithTempRegistry st m b
$cliftA2 :: forall st (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> WithTempRegistry st m a
-> WithTempRegistry st m b
-> WithTempRegistry st m c
liftA2 :: forall a b c.
(a -> b -> c)
-> WithTempRegistry st m a
-> WithTempRegistry st m b
-> WithTempRegistry st m c
$c*> :: forall st (m :: * -> *) a b.
Applicative m =>
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 b
$c<* :: forall st (m :: * -> *) a b.
Applicative m =>
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 a
Applicative
                   , Applicative (WithTempRegistry st m)
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)
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
$c>>= :: forall st (m :: * -> *) a b.
Monad m =>
WithTempRegistry st m a
-> (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
$c>> :: forall st (m :: * -> *) a b.
Monad m =>
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 b
$creturn :: forall st (m :: * -> *) a. Monad m => a -> WithTempRegistry st m a
return :: forall a. a -> WithTempRegistry st m a
Monad
                   , Monad (WithTempRegistry st m)
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)
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
$cthrowIO :: forall st (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> WithTempRegistry st m a
throwIO :: forall e a. Exception e => e -> WithTempRegistry st m a
$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
bracket :: forall a b c.
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
-> WithTempRegistry st m b
-> WithTempRegistry st m c
-> WithTempRegistry st m c
bracket_ :: forall a b c.
WithTempRegistry st m a
-> WithTempRegistry st m b
-> WithTempRegistry st m c
-> WithTempRegistry st m c
$cfinally :: forall st (m :: * -> *) a b.
MonadThrow m =>
WithTempRegistry st m a
-> WithTempRegistry st m b -> WithTempRegistry st m a
finally :: forall a b.
WithTempRegistry st m a
-> WithTempRegistry st m b -> WithTempRegistry st m a
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)
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
$ccatch :: forall st (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
WithTempRegistry st m a
-> (e -> WithTempRegistry st m a) -> WithTempRegistry st m a
catch :: forall e a.
Exception e =>
WithTempRegistry st m a
-> (e -> 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
catchJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> WithTempRegistry st m a
-> (b -> WithTempRegistry st m a)
-> WithTempRegistry st m a
$ctry :: forall st (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
WithTempRegistry st m a -> WithTempRegistry st m (Either e a)
try :: forall e a.
Exception e =>
WithTempRegistry st m a -> WithTempRegistry st m (Either e 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)
tryJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> WithTempRegistry st m a -> WithTempRegistry st m (Either b a)
$chandle :: forall st (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> WithTempRegistry st m a)
-> WithTempRegistry st m a -> WithTempRegistry st m a
handle :: forall e a.
Exception e =>
(e -> 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
handleJust :: forall e b a.
Exception e =>
(e -> Maybe b)
-> (b -> WithTempRegistry st m a)
-> WithTempRegistry st m a
-> WithTempRegistry st m a
$conException :: forall st (m :: * -> *) a b.
MonadCatch m =>
WithTempRegistry st m a
-> WithTempRegistry st m b -> WithTempRegistry st m a
onException :: forall a b.
WithTempRegistry st m a
-> WithTempRegistry st m b -> WithTempRegistry st m a
$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
bracketOnError :: forall a b c.
WithTempRegistry st m a
-> (a -> WithTempRegistry st m b)
-> (a -> WithTempRegistry st m c)
-> WithTempRegistry st m 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)
generalBracket :: 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
                   , 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)
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
$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
mask :: forall b.
((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
uninterruptibleMask :: forall b.
((forall a. WithTempRegistry st m a -> WithTempRegistry st m a)
 -> WithTempRegistry st m b)
-> WithTempRegistry st m b
$cmask_ :: forall st (m :: * -> *) a.
MonadMask m =>
WithTempRegistry st m a -> WithTempRegistry st m a
mask_ :: forall a. WithTempRegistry st m a -> WithTempRegistry st m a
$cuninterruptibleMask_ :: 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
MonadMask
                   )

instance MonadTrans (WithTempRegistry st) where
  lift :: forall (m :: * -> *) a. Monad m => 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 (m :: * -> *) a.
Monad m =>
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 :: forall a. (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 a. (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 ::
     MonadSTM m
  => ResourceRegistry m
  -> TransferredTo st
  -> st
  -> m ()
untrackTransferredTo :: forall (m :: * -> *) st.
MonadSTM m =>
ResourceRegistry m -> TransferredTo st -> st -> m ()
untrackTransferredTo ResourceRegistry m
rr TransferredTo st
transferredTo st
st =
    ResourceRegistry m -> State (RegistryState m) () -> m ()
forall (m :: * -> *) a.
MonadSTM 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 ::
     (MonadSTM m, MonadMask m, MonadThread 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 :: forall (m :: * -> *) a st.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
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 (m :: * -> *) a.
Monad m =>
m a -> ReaderT (TempRegistry st m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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.
(MonadSTM m, MonadMask m, MonadThread 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 a b. (a -> b) -> m a -> m b
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 (m :: * -> *) a.
Monad m =>
m a -> ReaderT (TempRegistry st m) m a
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 a. HasCallStack => STM m a -> m a
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 a. 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.
     (MonadSTM m, MonadMask m, MonadThread 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 :: forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m) =>
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.
(MonadSTM m, MonadMask m, MonadThread 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 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 (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 (m :: * -> *) a. Monad m => m a -> WithTempRegistry st m a
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 (m :: * -> *) a. Monad m => m a -> WithTempRegistry st m a
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 :: forall (m :: * -> *). 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 :: MonadSTM m => ResourceRegistry m -> m Int
countResources :: forall (m :: * -> *). MonadSTM m => ResourceRegistry m -> m Int
countResources ResourceRegistry m
rr = STM m Int -> m Int
forall a. HasCallStack => STM m a -> m a
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 :: forall (m :: * -> *). 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.
     (MonadSTM m, MonadMask m, MonadThread m, HasCallStack)
  => ResourceRegistry m
  -> (ResourceId -> m a)
  -> (a -> m ())  -- ^ Release the resource
  -> m (ResourceKey m, a)
allocate :: forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
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.
(MonadSTM m, MonadMask m, MonadThread 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 a b. (a -> b) -> m a -> m b
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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
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.
     (MonadSTM m, MonadMask m, MonadThread 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 :: forall (m :: * -> *) e a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
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 :: * -> *).
(MonadThread m, HasCallStack) =>
m (Context m)
captureContext
    ResourceRegistry m -> Context m -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadThread m, MonadSTM 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.
MonadSTM m =>
ResourceRegistry m -> State (RegistryState m) a -> m a
updateState ResourceRegistry m
rr 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.
(MonadThrow m, MonadThread 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 a. m a -> 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 a. a -> 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.
MonadSTM 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.
(MonadThrow m, MonadThread 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 a. a -> 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 {
          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 ::
     (MonadThrow m, MonadThread m)
  => ResourceRegistry m
  -> Context m
  -> PrettyCallStack
  -> m x
throwRegistryClosed :: forall (m :: * -> *) x.
(MonadThrow m, MonadThread m) =>
ResourceRegistry m -> Context m -> PrettyCallStack -> m x
throwRegistryClosed ResourceRegistry m
rr Context m
context PrettyCallStack
closed = RegistryClosedException -> m x
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO 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 ::
     (MonadMask m, MonadSTM m, MonadThread m, HasCallStack)
  => ResourceKey m
  -> m (Maybe (Context m))
release :: forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
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 :: * -> *).
(MonadThread m, HasCallStack) =>
m (Context m)
captureContext
    ResourceRegistry m -> Context m -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadThread m, MonadSTM m) =>
ResourceRegistry m -> Context m -> m ()
ensureKnownThread ResourceRegistry m
rr Context m
context
    ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM 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 ::
     (MonadMask m, MonadSTM m)
  => ResourceKey m
  -> m (Maybe (Context m))
unsafeRelease :: forall (m :: * -> *).
(MonadMask m, MonadSTM m) =>
ResourceKey m -> m (Maybe (Context m))
unsafeRelease (ResourceKey ResourceRegistry m
rr ResourceId
rid) = do
    m (Maybe (Context m)) -> m (Maybe (Context m))
forall a. m a -> m a
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.
MonadSTM 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 a. a -> m a
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 a. a -> m a
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 ::
     (MonadMask m, MonadSTM m, MonadThread m, HasCallStack)
  => ResourceRegistry m
  -> m ()
releaseAll :: forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceRegistry m -> m ()
releaseAll ResourceRegistry m
rr = do
    Context m
context <- m (Context m)
forall (m :: * -> *).
(MonadThread 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 e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ResourceRegistryThreadException -> m ())
-> ResourceRegistryThreadException -> m ()
forall a b. (a -> b) -> a -> b
$ 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 :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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 :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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 ::
     (MonadMask m, MonadSTM m, MonadThread m, HasCallStack)
  => ResourceRegistry m
  -> m ()
unsafeReleaseAll :: forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceRegistry m -> m ()
unsafeReleaseAll ResourceRegistry m
rr = do
    Context m
context <- m (Context m)
forall (m :: * -> *).
(MonadThread 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 :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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 :: * -> *).
(MonadMask m, MonadSTM m) =>
ResourceKey m -> m (Maybe (Context m))
unsafeRelease

-- | Internal helper used by 'releaseAll' and 'unsafeReleaseAll'.
releaseAllHelper ::
     (MonadMask m, MonadSTM m, MonadThread m)
  => ResourceRegistry m
  -> Context m
  -> (ResourceKey m -> m (Maybe (Context m)))
     -- ^ How to release a resource
  -> m [Context m]
releaseAllHelper :: forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread 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))
releaser = m [Context m] -> m [Context m]
forall a. m a -> m a
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.
MonadSTM 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.
(MonadThrow m, MonadThread 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 :: * -> *).
MonadCatch 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 = MonadThread m => Thread {
      -- | The underlying @async@ thread id
      forall (m :: * -> *) a. Thread m a -> ThreadId m
threadId         :: !(ThreadId m)
    , forall (m :: * -> *) a. Thread m a -> ResourceId
threadResourceId :: !ResourceId
    , forall (m :: * -> *) a. Thread m a -> Async m a
threadAsync      :: !(Async m a)
    , forall (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
$cnoThunks :: forall (m :: * -> *) a.
Context -> Thread m a -> IO (Maybe ThunkInfo)
noThunks :: Context -> Thread m a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) a.
Context -> Thread m a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Thread m a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) a. Proxy (Thread m a) -> String
showTypeOf :: Proxy (Thread m a) -> String
NoThunks via OnlyCheckWhnfNamed "Thread" (Thread m a)

-- | 'Eq' instance for 'Thread' compares 'threadId' only.
instance MonadThread m => 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 :: MonadAsync m => Thread m a -> m ()
cancelThread :: forall (m :: * -> *) a. MonadAsync m => Thread m a -> m ()
cancelThread = Async m a -> m ()
forall a. 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 'Control.Exception.ThreadKilled' exception thrown by the registry.
waitThread :: MonadAsync m => Thread m a -> m a
waitThread :: forall (m :: * -> *) a. MonadAsync m => Thread m a -> m a
waitThread = Async m a -> m a
forall a. 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. MonadAsync m => [Thread m a] -> m a
waitAnyThread :: forall (m :: * -> *) a. MonadAsync m => [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 a. [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.
     (MonadMask m, MonadAsync m, HasCallStack)
  => ResourceRegistry m
  -> String  -- ^ Label for the thread
  -> m a
  -> m (Thread m a)
forkThread :: forall (m :: * -> *) a.
(MonadMask m, MonadAsync m, HasCallStack) =>
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.
(MonadSTM m, MonadMask m, MonadThread 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 a. 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. MonadAsync 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 {
          threadId :: ThreadId m
threadId         = Async m a -> ThreadId m
forall a. 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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
body) m a -> m () -> m a
forall a b. m a -> m b -> 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.
MonadSTM 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 :: * -> *).
MonadThread 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.
MonadSTM 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 :: * -> *).
MonadThread 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 'withAsync' 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 ::
     (MonadMask m, MonadAsync m)
  => ResourceRegistry m
  -> String  -- ^ Label for the thread
  -> m a
  -> (Thread m a -> m b)
  -> m b
withThread :: forall (m :: * -> *) a b.
(MonadMask m, MonadAsync m) =>
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 a b c. m a -> (a -> m b) -> (a -> m c) -> m c
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.
(MonadMask m, MonadAsync 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. MonadAsync m => Thread m a -> m ()
cancelThread

-- | Link specified 'Thread' to the (thread that created) the registry
linkToRegistry :: (MonadAsync m, MonadFork m, MonadMask m) => Thread m a -> m ()
linkToRegistry :: forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
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 ::
     (MonadAsync m, MonadFork m, MonadMask m, HasCallStack)
  => ResourceRegistry m
  -> String  -- ^ Label for the thread
  -> m a
  -> m (Thread m a)
forkLinkedThread :: forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
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.
(MonadMask m, MonadAsync 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.
(MonadAsync m, MonadFork m, MonadMask m) =>
Thread m a -> m ()
linkToRegistry Thread m a
t
    Thread m a -> m (Thread m a)
forall a. a -> 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.
     (MonadThrow m, MonadThread m, MonadSTM m)
  => ResourceRegistry m
  -> Context m
  -> m ()
ensureKnownThread :: forall (m :: * -> *).
(MonadThrow m, MonadThread m, MonadSTM m) =>
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 e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ResourceRegistryThreadException -> m ())
-> ResourceRegistryThreadException -> m ()
forall a b. (a -> b) -> a -> b
$ 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | Bool
otherwise = STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
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 a. a -> STM m a
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. MonadThread 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. MonadThread 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
-------------------------------------------------------------------------------}

-- | The internal context of a resource registry, recording a 'PrettyCallStack'
-- of its creation and the creator's 'ThreadId'
data Context m = MonadThread m => Context {
      -- | CallStack in which it was created
      forall (m :: * -> *). Context m -> PrettyCallStack
contextCallStack :: !PrettyCallStack

      -- | Thread that created the registry or resource
    , forall (m :: * -> *). 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 (forall (name :: Symbol) a. a -> InspectHeapNamed name a
InspectHeapNamed @"ThreadId" ThreadId m
tid)
    ]

deriving instance Show (Context m)

captureContext :: MonadThread m => HasCallStack => m (Context m)
captureContext :: forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
m (Context m)
captureContext = PrettyCallStack -> ThreadId m -> Context m
forall (m :: * -> *).
MonadThread 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

{-------------------------------------------------------------------------------
  Misc utilities
-------------------------------------------------------------------------------}

-- | Generalization of 'link' that links an async to an arbitrary thread.
--
-- Non standard (not in 'async' library)
--
linkTo ::
     (MonadAsync m, MonadFork m, MonadMask m)
  => ThreadId m
  -> Async m a
  -> m ()
linkTo :: forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
ThreadId m -> Async m a -> m ()
linkTo ThreadId m
tid = ThreadId m -> (SomeException -> Bool) -> Async m a -> m ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
ThreadId m -> (SomeException -> Bool) -> Async m a -> m ()
linkToOnly ThreadId m
tid (Bool -> Bool
not (Bool -> Bool) -> (SomeException -> Bool) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Bool
isCancel)

-- | Generalization of 'linkOnly' that links an async to an arbitrary thread.
--
-- Non standard (not in 'async' library).
--
linkToOnly ::
     forall m a.
     (MonadAsync m, MonadFork m, MonadMask m)
  => ThreadId m
  -> (SomeException -> Bool)
  -> Async m a
  -> m ()
linkToOnly :: forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
ThreadId m -> (SomeException -> Bool) -> Async m a -> m ()
linkToOnly ThreadId m
tid SomeException -> Bool
shouldThrow Async m a
a = do
    m (ThreadId m) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (ThreadId m) -> m ()) -> m (ThreadId m) -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m () -> m (ThreadId m)
forall (m :: * -> *) a.
(MonadFork m, MonadMask m) =>
String -> m a -> m (ThreadId m)
forkRepeat (String
"linkToOnly " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ThreadId m -> String
forall a. Show a => a -> String
show ThreadId m
linkedThreadId) (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ do
      Either SomeException a
r <- Async m a -> m (Either SomeException a)
forall a. Async m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async m a
a
      case Either SomeException a
r of
        Left SomeException
e | SomeException -> Bool
shouldThrow SomeException
e -> ThreadId m -> ExceptionInLinkedThread -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid (SomeException -> ExceptionInLinkedThread
exceptionInLinkedThread SomeException
e)
        Either SomeException a
_otherwise             -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    linkedThreadId :: ThreadId m
    linkedThreadId :: ThreadId m
linkedThreadId = Async m a -> ThreadId m
forall a. Async m a -> ThreadId m
forall (m :: * -> *) a. MonadAsync m => Async m a -> ThreadId m
asyncThreadId Async m a
a

    exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread
    exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread
exceptionInLinkedThread =
        String -> SomeException -> ExceptionInLinkedThread
ExceptionInLinkedThread (ThreadId m -> String
forall a. Show a => a -> String
show ThreadId m
linkedThreadId)

isCancel :: SomeException -> Bool
isCancel :: SomeException -> Bool
isCancel SomeException
e
  | Just AsyncCancelled
AsyncCancelled <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
  | Bool
otherwise = Bool
False

forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m)
forkRepeat :: forall (m :: * -> *) a.
(MonadFork m, MonadMask m) =>
String -> m a -> m (ThreadId m)
forkRepeat String
label m a
action =
  ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall b. ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m))
-> ((forall a. m a -> m a) -> m (ThreadId m)) -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore ->
    let go :: m ()
go = do Either SomeException a
r <- m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAll (m a -> m a
forall a. m a -> m a
restore m a
action)
                case Either SomeException a
r of
                  Left SomeException
_ -> m ()
go
                  Either SomeException a
_      -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    in m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
label m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
go)

tryAll :: MonadCatch m => m a -> m (Either SomeException a)
tryAll :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAll = m a -> m (Either SomeException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try

mustBeRight :: Either Void a -> a
mustBeRight :: forall a. Either Void a -> a
mustBeRight (Left  Void
v) = Void -> a
forall a. Void -> a
absurd Void
v
mustBeRight (Right a
a) = a
a

{-------------------------------------------------------------------------------
  Auxiliary: CallStack with different Show instance
-------------------------------------------------------------------------------}

-- | CallStack with 'Show' instance using 'prettyCallStack'
newtype PrettyCallStack = PrettyCallStack CallStack
  deriving newtype (Context -> PrettyCallStack -> IO (Maybe ThunkInfo)
Proxy PrettyCallStack -> String
(Context -> PrettyCallStack -> IO (Maybe ThunkInfo))
-> (Context -> PrettyCallStack -> IO (Maybe ThunkInfo))
-> (Proxy PrettyCallStack -> String)
-> NoThunks PrettyCallStack
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PrettyCallStack -> IO (Maybe ThunkInfo)
noThunks :: Context -> PrettyCallStack -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PrettyCallStack -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PrettyCallStack -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PrettyCallStack -> String
showTypeOf :: Proxy PrettyCallStack -> String
NoThunks)

instance Show PrettyCallStack where
  show :: PrettyCallStack -> String
show (PrettyCallStack CallStack
cs) = CallStack -> String
GHC.prettyCallStack CallStack
cs

-- | Capture a 'PrettyCallStack'
prettyCallStack :: HasCallStack => PrettyCallStack
prettyCallStack :: HasCallStack => PrettyCallStack
prettyCallStack = CallStack -> PrettyCallStack
PrettyCallStack CallStack
HasCallStack => CallStack
GHC.callStack

{-------------------------------------------------------------------------------
  Orphan instance
-------------------------------------------------------------------------------}

instance (NoThunks k, NoThunks v)
      => NoThunks (Bimap k v) where
  wNoThunks :: Context -> Bimap k v -> IO (Maybe ThunkInfo)
wNoThunks Context
ctxt = Context -> [(k, v)] -> IO (Maybe ThunkInfo)
forall k v.
(NoThunks k, NoThunks v) =>
Context -> [(k, v)] -> IO (Maybe ThunkInfo)
noThunksInKeysAndValues Context
ctxt ([(k, v)] -> IO (Maybe ThunkInfo))
-> (Bimap k v -> [(k, v)]) -> Bimap k v -> IO (Maybe ThunkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bimap k v -> [(k, v)]
forall a b. Bimap a b -> [(a, b)]
Bimap.toList