{-# LANGUAGE BlockArguments #-}

module Cauldron.Managed
  ( -- * The Managed monad for handling resources
    Managed,
    managed,
    with,
  )
where

import Control.Concurrent.MVar
import Control.Exception.Base
import Control.Monad.Fix
import Control.Monad.IO.Class
import GHC.IO.Unsafe

-- | This is a copy of the @Managed@ type from the
-- [managed](https://hackage.haskell.org/package/managed) package, with a dodgy
-- 'Control.Monad.Fix.MonadFix' instance tacked on.
newtype Managed a = Managed (forall b. (a -> IO b) -> IO b)

-- | Build a 'Managed' value from a @withFoo@-style resource-handling function
-- that accepts a continuation, like 'System.IO.withFile'.
--
-- Passing functions that do weird things like running their continuation
-- /twice/ will tear apart the fabric of reality. Why would you want to do that?
-- Pass only @withFoo@-style functions.
managed :: (forall r. (a -> IO r) -> IO r) -> Managed a
managed :: forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
managed = (forall b. (a -> IO b) -> IO b) -> Managed a
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed

-- | This instance is a little dodgy (continuation-like monads don't have proper
-- 'MonadFix' instances) but it is nevertheless useful because it lets us use
-- 'Managed' with 'allowSelfDeps'. Follow the recommendations for the 'managed'
-- function.
--
-- [\"if you embrace the unsafety, it could be a fun way to tie knots.\"](https://stackoverflow.com/questions/25827227/why-cant-there-be-an-instance-of-monadfix-for-the-continuation-monad#comment113010373_63906214)
instance MonadFix Managed where
  -- https://stackoverflow.com/a/63906214
  -- See also the implementation for fixIO https://hackage.haskell.org/package/base-4.19.0.0/docs/src/System.IO.html#fixIO
  mfix :: forall a. (a -> Managed a) -> Managed a
mfix a -> Managed a
f = (forall b. (a -> IO b) -> IO b) -> Managed a
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed \a -> IO b
k -> do
    m <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
    x <-
      unsafeDupableInterleaveIO
        ( readMVar m `catch` \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
            FixIOException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO FixIOException
FixIOException
        )
    unManage (f x) \a
x' -> do
      MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
x'
      a -> IO b
k a
x'
    where
      unManage :: Managed a -> (a -> IO b) -> IO b
unManage (Managed forall b. (a -> IO b) -> IO b
a) = (a -> IO b) -> IO b
forall b. (a -> IO b) -> IO b
a

-- | Make use of the managed resource by supplying a callback.
with :: Managed a -> (a -> IO b) -> IO b
with :: forall {a} {b}. Managed a -> (a -> IO b) -> IO b
with (Managed forall b. (a -> IO b) -> IO b
r) = (a -> IO b) -> IO b
forall b. (a -> IO b) -> IO b
r

instance Functor Managed where
  fmap :: forall a b. (a -> b) -> Managed a -> Managed b
fmap a -> b
f (Managed forall b. (a -> IO b) -> IO b
m) = (forall b. (b -> IO b) -> IO b) -> Managed b
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed (\b -> IO b
k -> (a -> IO b) -> IO b
forall b. (a -> IO b) -> IO b
m (\a
x -> b -> IO b
k (a -> b
f a
x)))
  {-# INLINE fmap #-}

instance Applicative Managed where
  pure :: forall a. a -> Managed a
pure a
x = (forall b. (a -> IO b) -> IO b) -> Managed a
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed (\a -> IO b
k -> a -> IO b
k a
x)
  {-# INLINE pure #-}
  Managed forall b. ((a -> b) -> IO b) -> IO b
f <*> :: forall a b. Managed (a -> b) -> Managed a -> Managed b
<*> Managed forall b. (a -> IO b) -> IO b
g = (forall b. (b -> IO b) -> IO b) -> Managed b
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed (\b -> IO b
bfr -> ((a -> b) -> IO b) -> IO b
forall b. ((a -> b) -> IO b) -> IO b
f (\a -> b
ab -> (a -> IO b) -> IO b
forall b. (a -> IO b) -> IO b
g (\a
x -> b -> IO b
bfr (a -> b
ab a
x))))
  {-# INLINE (<*>) #-}

instance Monad Managed where
  return :: forall a. a -> Managed a
return = a -> Managed a
forall a. a -> Managed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  Managed a
m >>= :: forall a b. Managed a -> (a -> Managed b) -> Managed b
>>= a -> Managed b
k = (forall b. (b -> IO b) -> IO b) -> Managed b
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed (\b -> IO b
c -> Managed a -> (a -> IO b) -> IO b
forall {a} {b}. Managed a -> (a -> IO b) -> IO b
with Managed a
m (\a
a -> Managed b -> (b -> IO b) -> IO b
forall {a} {b}. Managed a -> (a -> IO b) -> IO b
with (a -> Managed b
k a
a) b -> IO b
c))
  {-# INLINE (>>=) #-}

instance MonadIO Managed where
  liftIO :: forall a. IO a -> Managed a
liftIO IO a
m = (forall b. (a -> IO b) -> IO b) -> Managed a
forall a. (forall r. (a -> IO r) -> IO r) -> Managed a
Managed \a -> IO b
return_ -> do
    a <- IO a
m
    return_ a
  {-# INLINE liftIO #-}