{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}

{- |
Description : General datatypes for resource allocation and release.
Copyright   : Copyright 2022 Shea Levy.
License     : Apache-2.0
Maintainer  : shea@shealevy.com

This module provides a general interface for describing the allocation and
release of some resource in some monadic context.

For /using/ the resources safely, see "Control.Monad.With" and
"Control.Monad.Allocate".

This design and implementation is heavily based on t'Data.Acquire.Internal.Acquire'
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 Data.GeneralAllocate where

import Control.Monad
import {-# SOURCE #-} Control.Monad.With

{- | Describe the allocation and release of an @a@ in @m@.

In monads which allow this, the allocation action is run with exceptions masked.
The argument to the action allows the allocation to run some action with the masking
state restored to its prior state. In monads without masking, the argument is 'id'.

[@m@]: The monad to allocate in
[@e@]: A data type for a failure condition, typically t'Control.Exception.Safe.SomeException'
[@releaseReturn@]: State to be returned upon resource release. Mainly useful for proper threading
                   of monadic state in error conditions.
[@releaseArg@]: An argument to be passed to the release action upon successful completion of usage.
[@a@]: The type of the resource
-}
newtype GeneralAllocate m e releaseReturn releaseArg a
  = GeneralAllocate ((∀ x. m x → m x) → m (GeneralAllocated m e releaseReturn releaseArg a))

{- | A resource allocated and releasable in @m@.

[@m@]: The monad to allocate in
[@e@]: A data type for a failure condition, typically t'Control.Exception.Safe.SomeException'
[@releaseReturn@]: State to be returned upon resource release. Mainly useful for proper threading
                   of monadic state in error conditions.
[@releaseArg@]: An argument to be passed to the release action upon successful completion of usage.
[@a@]: The type of the resource
-}
data GeneralAllocated m e releaseReturn releaseArg a = GeneralAllocated
  { forall (m :: * -> *) e releaseReturn releaseArg a.
GeneralAllocated m e releaseReturn releaseArg a -> a
allocatedResource ∷ !a
  -- ^ The allocated resource
  , forall (m :: * -> *) e releaseReturn releaseArg a.
GeneralAllocated m e releaseReturn releaseArg a
-> GeneralReleaseType e releaseArg -> m releaseReturn
releaseAllocated ∷ !(GeneralReleaseType e releaseArg → m releaseReturn)
  -- ^ The action to release the allocated resource
  }

{- | Types of release requests that can occur.

[@e@]: A data type for a failure condition, typically t'Control.Exception.Safe.SomeException'
[@a@]: A data type for success conditions
-}
data GeneralReleaseType e a
  = -- | The resource was used successfully
    ReleaseSuccess !a
  | -- | Some kind of error occured while the resource was held.
    --
    -- The error need not have originated from using the resource itself.
    ReleaseFailure !e
  deriving stock (forall a b. a -> GeneralReleaseType e b -> GeneralReleaseType e a
forall a b.
(a -> b) -> GeneralReleaseType e a -> GeneralReleaseType e b
forall e a b. a -> GeneralReleaseType e b -> GeneralReleaseType e a
forall e a b.
(a -> b) -> GeneralReleaseType e a -> GeneralReleaseType e 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 -> GeneralReleaseType e b -> GeneralReleaseType e a
$c<$ :: forall e a b. a -> GeneralReleaseType e b -> GeneralReleaseType e a
fmap :: forall a b.
(a -> b) -> GeneralReleaseType e a -> GeneralReleaseType e b
$cfmap :: forall e a b.
(a -> b) -> GeneralReleaseType e a -> GeneralReleaseType e b
Functor)

instance Functor (GeneralAllocated m e releaseReturn releaseArg) where
  a -> b
f fmap :: forall a b.
(a -> b)
-> GeneralAllocated m e releaseReturn releaseArg a
-> GeneralAllocated m e releaseReturn releaseArg b
`fmap` (GeneralAllocated a
x GeneralReleaseType e releaseArg -> m releaseReturn
rel) = forall (m :: * -> *) e releaseReturn releaseArg a.
a
-> (GeneralReleaseType e releaseArg -> m releaseReturn)
-> GeneralAllocated m e releaseReturn releaseArg a
GeneralAllocated (a -> b
f a
x) GeneralReleaseType e releaseArg -> m releaseReturn
rel

instance (Functor m) ⇒ Functor (GeneralAllocate m e releaseReturn releaseArg) where
  -- Refactoring `\restore → fmap f <$> alloc restore` to `fmap (fmap f) . alloc)` causes type inference failure
  {- HLINT ignore "Use fmap" -}
  a -> b
f fmap :: forall a b.
(a -> b)
-> GeneralAllocate m e releaseReturn releaseArg a
-> GeneralAllocate m e releaseReturn releaseArg b
`fmap` (GeneralAllocate (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a)
alloc) = forall (m :: * -> *) e releaseReturn releaseArg a.
((forall x. m x -> m x)
 -> m (GeneralAllocated m e releaseReturn releaseArg a))
-> GeneralAllocate m e releaseReturn releaseArg a
GeneralAllocate forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
restore → forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a)
alloc forall x. m x -> m x
restore

instance (MonadWith m, Monoid releaseReturn, e ~ WithException m) ⇒ Applicative (GeneralAllocate m e releaseReturn releaseArg) where
  pure :: forall a. a -> GeneralAllocate m e releaseReturn releaseArg a
pure a
a = forall (m :: * -> *) e releaseReturn releaseArg a.
((forall x. m x -> m x)
 -> m (GeneralAllocated m e releaseReturn releaseArg a))
-> GeneralAllocate m e releaseReturn releaseArg a
GeneralAllocate forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
_ → forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e releaseReturn releaseArg a.
a
-> (GeneralReleaseType e releaseArg -> m releaseReturn)
-> GeneralAllocated m e releaseReturn releaseArg a
GeneralAllocated a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  <*> :: forall a b.
GeneralAllocate m e releaseReturn releaseArg (a -> b)
-> GeneralAllocate m e releaseReturn releaseArg a
-> GeneralAllocate m e releaseReturn releaseArg b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (MonadWith m, Monoid releaseReturn, e ~ WithException m) ⇒ Monad (GeneralAllocate m e releaseReturn releaseArg) where
  return :: forall a. a -> GeneralAllocate m e releaseReturn releaseArg a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (GeneralAllocate (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a)
allocX) >>= :: forall a b.
GeneralAllocate m e releaseReturn releaseArg a
-> (a -> GeneralAllocate m e releaseReturn releaseArg b)
-> GeneralAllocate m e releaseReturn releaseArg b
>>= a -> GeneralAllocate m e releaseReturn releaseArg b
f = forall (m :: * -> *) e releaseReturn releaseArg a.
((forall x. m x -> m x)
 -> m (GeneralAllocated m e releaseReturn releaseArg a))
-> GeneralAllocate m e releaseReturn releaseArg a
GeneralAllocate forall a b. (a -> b) -> a -> b
$ \forall x. m x -> m x
restore → do
    GeneralAllocated a
x GeneralReleaseType e releaseArg -> m releaseReturn
releaseX ← (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg a)
allocX forall x. m x -> m x
restore
    let GeneralAllocate (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg b)
allocY = a -> GeneralAllocate m e releaseReturn releaseArg b
f a
x
    GeneralAllocated b
y GeneralReleaseType e releaseArg -> m releaseReturn
releaseY ← (forall x. m x -> m x)
-> m (GeneralAllocated m e releaseReturn releaseArg b)
allocY forall x. m x -> m x
restore forall (m :: * -> *) a b.
MonadWith m =>
m a -> (WithException m -> m b) -> m a
`onFailure` (GeneralReleaseType e releaseArg -> m releaseReturn
releaseX forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. e -> GeneralReleaseType e a
ReleaseFailure)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e releaseReturn releaseArg a.
a
-> (GeneralReleaseType e releaseArg -> m releaseReturn)
-> GeneralAllocated m e releaseReturn releaseArg a
GeneralAllocated b
y forall a b. (a -> b) -> a -> b
$ \GeneralReleaseType e releaseArg
relTy →
        forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b. MonadWith m => m a -> m b -> m (a, b)
generalFinally (GeneralReleaseType e releaseArg -> m releaseReturn
releaseY GeneralReleaseType e releaseArg
relTy) (GeneralReleaseType e releaseArg -> m releaseReturn
releaseX GeneralReleaseType e releaseArg
relTy)