{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax #-}

{- |
Copyright   : Copyright 2022 Shea Levy.
License     : Apache-2.0
Maintainer  : shea@shealevy.com

This design and implementation is heavily based on t'Control.Monad.Trans.Resource.Internal.ResourceT'
from [resourcet](https://github.com/snoyberg/conduit/tree/master/resourcet),
including some code copied verbatim and then generalized appropriately. @resourcet@
is @Copyright (c)2011, Michael Snoyman@, and licensed under the BSD 3-clause license
available at [LICENSE.resourcet](https://github.com/shlevy/general-allocate/blob/master/LICENSE.resourcet).
-}
module Control.Monad.NoContinuation.Resource.Internal where

import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Allocate
import Control.Monad.Fix
import Control.Monad.Primitive
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Control.Monad.With
import Control.Monad.Writer.Lazy
import Data.GeneralAllocate
import Data.IntMap.Strict as IntMap
import Data.Primitive.MutVar

{- | A 'MonadTrans'former turning any 'PrimMonad' that is a 'MonadWith' into a 'MonadAllocate'

Note that the 'MonadAllocate' instance is only valid if the underlying monad satisfies the "no continuation"
condition, i.e. that if execution of a computation exits a given lexical scope we are guaranteed that either
all of the actions within that scope have executed or the entire monadic computation has been terminated.

The most common factors violating "no continuation" are call/cc and exception catching. A monad which allows
exception /throwing/ but not catching is not thereby disqualified, as any thrown exception will of necessity
propagate until it terminates the entire monadic computation.

In conjunction with the 'PrimMonad' requirement, this essentially means the base of @m@ must be an 'Control.Monad.ST.ST' and
there must be no 'Control.Monad.Cont.ContT' in the stack.
-}
newtype NoContinuationResourceT m a = NoContinuationResourceT {forall (m :: * -> *) a.
NoContinuationResourceT m a
-> ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
unNoContinuationResourceT ∷ ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a}
  deriving newtype (forall a. a -> NoContinuationResourceT m a
forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m a
forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
forall a b.
NoContinuationResourceT m (a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
forall a b c.
(a -> b -> c)
-> NoContinuationResourceT m a
-> NoContinuationResourceT m b
-> NoContinuationResourceT 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
forall {m :: * -> *}.
Applicative m =>
Functor (NoContinuationResourceT m)
forall (m :: * -> *) a.
Applicative m =>
a -> NoContinuationResourceT m a
forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m a
forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m (a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoContinuationResourceT m a
-> NoContinuationResourceT m b
-> NoContinuationResourceT m c
<* :: forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m a
*> :: forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
liftA2 :: forall a b c.
(a -> b -> c)
-> NoContinuationResourceT m a
-> NoContinuationResourceT m b
-> NoContinuationResourceT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoContinuationResourceT m a
-> NoContinuationResourceT m b
-> NoContinuationResourceT m c
<*> :: forall a b.
NoContinuationResourceT m (a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
NoContinuationResourceT m (a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
pure :: forall a. a -> NoContinuationResourceT m a
$cpure :: forall (m :: * -> *) a.
Applicative m =>
a -> NoContinuationResourceT m a
Applicative, forall a b.
a -> NoContinuationResourceT m b -> NoContinuationResourceT m a
forall a b.
(a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
forall (m :: * -> *) a b.
Functor m =>
a -> NoContinuationResourceT m b -> NoContinuationResourceT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> NoContinuationResourceT m b -> NoContinuationResourceT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NoContinuationResourceT m b -> NoContinuationResourceT m a
fmap :: forall a b.
(a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b)
-> NoContinuationResourceT m a -> NoContinuationResourceT m b
Functor, forall a. a -> NoContinuationResourceT m a
forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
forall a b.
NoContinuationResourceT m a
-> (a -> NoContinuationResourceT m b)
-> NoContinuationResourceT m b
forall {m :: * -> *}.
Monad m =>
Applicative (NoContinuationResourceT m)
forall (m :: * -> *) a. Monad m => a -> NoContinuationResourceT m a
forall (m :: * -> *) a b.
Monad m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
forall (m :: * -> *) a b.
Monad m =>
NoContinuationResourceT m a
-> (a -> NoContinuationResourceT m b)
-> NoContinuationResourceT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> NoContinuationResourceT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> NoContinuationResourceT m a
>> :: forall a b.
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m b -> NoContinuationResourceT m b
>>= :: forall a b.
NoContinuationResourceT m a
-> (a -> NoContinuationResourceT m b)
-> NoContinuationResourceT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
NoContinuationResourceT m a
-> (a -> NoContinuationResourceT m b)
-> NoContinuationResourceT m b
Monad, forall a. NoContinuationResourceT m a
forall a.
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
forall {m :: * -> *}.
MonadPlus m =>
Monad (NoContinuationResourceT m)
forall {m :: * -> *}.
MonadPlus m =>
Alternative (NoContinuationResourceT m)
forall (m :: * -> *) a. MonadPlus m => NoContinuationResourceT m a
forall (m :: * -> *) a.
MonadPlus m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a.
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
mzero :: forall a. NoContinuationResourceT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => NoContinuationResourceT m a
MonadPlus, forall a.
(State# (PrimState (NoContinuationResourceT m))
 -> (# State# (PrimState (NoContinuationResourceT m)), a #))
-> NoContinuationResourceT m a
forall (m :: * -> *).
Monad m
-> (forall a.
    (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> PrimMonad m
forall {m :: * -> *}.
PrimMonad m =>
Monad (NoContinuationResourceT m)
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (NoContinuationResourceT m))
 -> (# State# (PrimState (NoContinuationResourceT m)), a #))
-> NoContinuationResourceT m a
primitive :: forall a.
(State# (PrimState (NoContinuationResourceT m))
 -> (# State# (PrimState (NoContinuationResourceT m)), a #))
-> NoContinuationResourceT m a
$cprimitive :: forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState (NoContinuationResourceT m))
 -> (# State# (PrimState (NoContinuationResourceT m)), a #))
-> NoContinuationResourceT m a
PrimMonad, forall a. String -> NoContinuationResourceT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}.
MonadFail m =>
Monad (NoContinuationResourceT m)
forall (m :: * -> *) a.
MonadFail m =>
String -> NoContinuationResourceT m a
fail :: forall a. String -> NoContinuationResourceT m a
$cfail :: forall (m :: * -> *) a.
MonadFail m =>
String -> NoContinuationResourceT m a
MonadFail, forall a. NoContinuationResourceT m a
forall a.
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
forall a.
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall {m :: * -> *}.
Alternative m =>
Applicative (NoContinuationResourceT m)
forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a
forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
many :: forall a.
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
$cmany :: forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
some :: forall a.
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
$csome :: forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a -> NoContinuationResourceT m [a]
<|> :: forall a.
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
empty :: forall a. NoContinuationResourceT m a
$cempty :: forall (m :: * -> *) a.
Alternative m =>
NoContinuationResourceT m a
Alternative, MonadState s, MonadWriter w, forall a.
(a -> NoContinuationResourceT m a) -> NoContinuationResourceT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}.
MonadFix m =>
Monad (NoContinuationResourceT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> NoContinuationResourceT m a) -> NoContinuationResourceT m a
mfix :: forall a.
(a -> NoContinuationResourceT m a) -> NoContinuationResourceT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> NoContinuationResourceT m a) -> NoContinuationResourceT m a
MonadFix)

instance (MonadReader r m) ⇒ MonadReader r (NoContinuationResourceT m) where
  ask :: NoContinuationResourceT m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a.
(r -> r)
-> NoContinuationResourceT m a -> NoContinuationResourceT m a
local r -> r
f (NoContinuationResourceT ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
go) = forall (m :: * -> *) a.
ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
-> NoContinuationResourceT m a
NoContinuationResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
go

instance MonadTrans NoContinuationResourceT where
  lift :: forall (m :: * -> *) a.
Monad m =>
m a -> NoContinuationResourceT m a
lift = forall (m :: * -> *) a.
ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
-> NoContinuationResourceT m a
NoContinuationResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Caller tried to allocate more than @maxBound :: Int@ resources in a single 'NoContinuationResourceT' scope.
data StupidlyManyResources = StupidlyManyResources deriving stock (Int -> StupidlyManyResources -> ShowS
[StupidlyManyResources] -> ShowS
StupidlyManyResources -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StupidlyManyResources] -> ShowS
$cshowList :: [StupidlyManyResources] -> ShowS
show :: StupidlyManyResources -> String
$cshow :: StupidlyManyResources -> String
showsPrec :: Int -> StupidlyManyResources -> ShowS
$cshowsPrec :: Int -> StupidlyManyResources -> ShowS
Show)

instance Exception StupidlyManyResources

-- | Internal state for 'NoContinuationResourceT'
data NoContinuationReleaseMap m = NoContinuationReleaseMap
  { forall (m :: * -> *). NoContinuationReleaseMap m -> Int
nextKey ∷ !Key
  -- ^ The next key to allocate a release action for.
  --
  -- Invariant: key must be monotonically /decreasing/.
  , forall (m :: * -> *).
NoContinuationReleaseMap m
-> IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions ∷ !(IntMap (GeneralReleaseType (WithException m) () → m ()))
  -- ^ Map of release actions.
  }

-- | Handle to run a release action early in 'NoContinuationResourceT'
data NoContinuationReleaseKey m = NoContinuationReleaseKey
  { forall (m :: * -> *). NoContinuationReleaseKey m -> Int
index ∷ !Key
  -- ^ The index of this action in the map
  , forall (m :: * -> *).
NoContinuationReleaseKey m
-> MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar ∷ !(MutVar (PrimState m) (NoContinuationReleaseMap m))
  -- ^ A reference to the map, shared with the allocation context.
  }

instance (PrimMonad m, MonadWith m) ⇒ MonadAllocate (NoContinuationResourceT m) where
  type AllocationContext (NoContinuationResourceT m) = m
  type AllocationException (NoContinuationResourceT m) = WithException m
  type GeneralReleaseKey (NoContinuationResourceT m) = NoContinuationReleaseKey m
  generalAllocate :: forall a.
GeneralAllocate
  (AllocationContext (NoContinuationResourceT m))
  (AllocationException (NoContinuationResourceT m))
  ()
  ()
  a
-> NoContinuationResourceT
     m (GeneralReleaseKey (NoContinuationResourceT m), a)
generalAllocate (GeneralAllocate (forall x.
 AllocationContext (NoContinuationResourceT m) x
 -> AllocationContext (NoContinuationResourceT m) x)
-> AllocationContext
     (NoContinuationResourceT m)
     (GeneralAllocated
        (AllocationContext (NoContinuationResourceT m))
        (AllocationException (NoContinuationResourceT m))
        ()
        ()
        a)
alloc) = do
    GeneralAllocated a
x GeneralReleaseType (WithException m) () -> m ()
rel ← forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall x.
 AllocationContext (NoContinuationResourceT m) x
 -> AllocationContext (NoContinuationResourceT m) x)
-> AllocationContext
     (NoContinuationResourceT m)
     (GeneralAllocated
        (AllocationContext (NoContinuationResourceT m))
        (AllocationException (NoContinuationResourceT m))
        ()
        ()
        a)
alloc forall a. a -> a
id
    MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar ← forall (m :: * -> *) a.
ReaderT (MutVar (PrimState m) (NoContinuationReleaseMap m)) m a
-> NoContinuationResourceT m a
NoContinuationResourceT forall r (m :: * -> *). MonadReader r m => m r
ask
    Int
index ← forall (m :: * -> *) a b.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> (a, b)) -> m b
atomicModifyMutVar' MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar forall a b. (a -> b) -> a -> b
$ \(NoContinuationReleaseMap{Int
IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions :: IntMap (GeneralReleaseType (WithException m) () -> m ())
nextKey :: Int
releaseActions :: forall (m :: * -> *).
NoContinuationReleaseMap m
-> IntMap (GeneralReleaseType (WithException m) () -> m ())
nextKey :: forall (m :: * -> *). NoContinuationReleaseMap m -> Int
..}) →
      ( NoContinuationReleaseMap
          { nextKey :: Int
nextKey = if Int
nextKey forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound then forall e a. Exception e => e -> a
impureThrow StupidlyManyResources
StupidlyManyResources else forall a. Enum a => a -> a
pred Int
nextKey
          , releaseActions :: IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions = forall a. Int -> a -> IntMap a -> IntMap a
insert Int
nextKey GeneralReleaseType (WithException m) () -> m ()
rel IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions
          }
      , Int
nextKey
      )
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (NoContinuationReleaseKey{Int
MutVar (PrimState m) (NoContinuationReleaseMap m)
index :: Int
mapVar :: MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar :: MutVar (PrimState m) (NoContinuationReleaseMap m)
index :: Int
..}, a
x)
  generalRelease :: GeneralReleaseKey (NoContinuationResourceT m)
-> AllocationContext (NoContinuationResourceT m) ()
generalRelease (NoContinuationReleaseKey{Int
MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar :: MutVar (PrimState m) (NoContinuationReleaseMap m)
index :: Int
mapVar :: forall (m :: * -> *).
NoContinuationReleaseKey m
-> MutVar (PrimState m) (NoContinuationReleaseMap m)
index :: forall (m :: * -> *). NoContinuationReleaseKey m -> Int
..}) = do
    Maybe (GeneralReleaseType (WithException m) () -> m ())
m_rel ← forall (m :: * -> *) a b.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> (a, b)) -> m b
atomicModifyMutVar' MutVar (PrimState m) (NoContinuationReleaseMap m)
mapVar forall a b. (a -> b) -> a -> b
$ \(NoContinuationReleaseMap{Int
IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions :: IntMap (GeneralReleaseType (WithException m) () -> m ())
nextKey :: Int
releaseActions :: forall (m :: * -> *).
NoContinuationReleaseMap m
-> IntMap (GeneralReleaseType (WithException m) () -> m ())
nextKey :: forall (m :: * -> *). NoContinuationReleaseMap m -> Int
..}) →
      ( NoContinuationReleaseMap
          { releaseActions :: IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions = forall a. Int -> IntMap a -> IntMap a
delete Int
index IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions
          , Int
nextKey :: Int
nextKey :: Int
..
          }
      , forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
index IntMap (GeneralReleaseType (WithException m) () -> m ())
releaseActions
      )
    case Maybe (GeneralReleaseType (WithException m) () -> m ())
m_rel of
      Maybe (GeneralReleaseType (WithException m) () -> m ())
Nothing → forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just GeneralReleaseType (WithException m) () -> m ()
rel → GeneralReleaseType (WithException m) () -> m ()
rel forall a b. (a -> b) -> a -> b
$ forall e a. a -> GeneralReleaseType e a
ReleaseSuccess ()