content: {-# LANGUAGE AllowAmbiguousTypes #-}
  {-# LANGUAGE DataKinds #-}
  
  -- | Utilities for working with resources
  module Data.Registry.Rio
    ( module Data.Registry.Rio,
      singleton,
      cacheAt
    )
  where
  
  import Control.Monad.Morph
  import Control.Monad.Trans.Resource
  import Data.Dynamic
  import Data.Registry.Internal.Cache
  import Data.Registry.Make (make)
  import Data.Registry.Registry
  import Protolude
  
  -- | This data type provides some support for creating effectful components with resources
  --   You can use the regular MonadResource functions like allocate to make sure that resources are cleaned up
  --   You can also use the 'cacheAt' function
  newtype Rio a = Rio {rioRun :: ReaderT Cache (ResourceT IO) a}
    deriving (Functor, Applicative, Monad, MonadReader Cache, MonadIO, MonadResource, MonadUnliftIO)
  
  -- | Run a Rio action by providing an empty cache and allocating / destroying resources
  runRio :: MonadIO m => Rio a -> m a
  runRio = liftIO . runResourceT . runCache
  
  -- | Run a Rio action by providing an empty cache and allocating / destroying resources
  execRio :: MonadIO m => Rio a -> m (a, Cache)
  execRio = liftIO . runResourceT . execCache
  
  -- | Use the value created by a Rio action so that resources are properly allocated and cached
  withRio :: MonadIO m => Rio a -> (a -> IO b) -> m b
  withRio action f = liftIO . runResourceT $ do
    a <- runCache action
    liftIO $ f a
  
  -- | Use the value created by a Rio action so that resources are properly allocated and cached
  --   inside a monad transformer
  withRioM :: (MonadResource (m (ResourceT IO)), MFunctor m) => Rio a -> (a -> m IO b) -> m IO b
  withRioM action f = hoist runResourceT $ do
    a <- liftResourceT (runCache action)
    hoist lift (f a)
  
  -- | Run a Rio action by providing an empty cache
  runCache :: Rio a -> ResourceT IO a
  runCache (Rio action) = do
    cache <- liftIO newCache
    runReaderT action cache
  
  -- | Run a Rio action by providing an empty cache, and return the final cache
  --   for inspection
  execCache :: Rio a -> ResourceT IO (a, Cache)
  execCache (Rio action) = do
    cache <- liftIO newCache
    (,cache) <$> runReaderT action cache
  
  -- | Lift a resourceful value into Rio
  liftRio :: ResourceT IO a -> Rio a
  liftRio = Rio . lift
  
  -- | This function must be used to run services involving resources
  --   The value a is created using the registry, used with the function 'f'
  --   and all resources are freed at the end
  withRegistry :: forall a b ins out m. (Typeable a, MonadIO m, MakeSingletons out) => Registry ins out -> (a -> IO b) -> m b
  withRegistry registry f =
    liftIO $ runResourceT (runRegistryT @a registry >>= liftIO . f)
  
  -- | This function works like 'withRegistry' for a higher-order monad, typically `PropertyT IO` when
  --   writing property tests with Hedgehog
  withRegistryM ::
    forall a b ins out m.
    (Typeable a, MonadResource (m (ResourceT IO)), MFunctor m, MakeSingletons out) =>
    Registry ins out ->
    (a -> m IO b) ->
    m IO b
  withRegistryM = withRioM . make @(Rio a) . singletons
  
  -- | Create a function of type a with a given registry
  --   Return a ResourceT value to control resource allocation
  runRegistryT :: forall a ins out. (Typeable a, MakeSingletons out) => Registry ins out -> ResourceT IO a
  runRegistryT = runCache . make @(Rio a) . singletons
  
  -- | Make singletons for all the output types of a registry
  --   but only if they not specialized values
  singletons :: forall ins out. (MakeSingletons out) => Registry ins out -> Registry ins out
  singletons r = _singletonsRegistry $ makeSingletons (startSingletonsRegistry r)
  
  -- | Registry where all Rio values are singletons
  newtype SingletonsRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = SingletonsRegistry {_singletonsRegistry :: Registry ins out}
  
  -- | Prepare a Registry for making singletons
  startSingletonsRegistry :: Registry ins out -> SingletonsRegistry out ins out
  startSingletonsRegistry = SingletonsRegistry
  
  -- | Prepare a Registry for making singletons on a specific list of types
  makeSingletonsRegistry :: forall todo ins out. Registry ins out -> SingletonsRegistry todo ins out
  makeSingletonsRegistry = SingletonsRegistry @todo
  
  -- | This typeclass take an existing registry and makes a singleton for each Rio output type
  class MakeSingletons ls where
    makeSingletons :: SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
  
  -- | If the list of types is empty there is nothing to do
  instance MakeSingletons '[] where
    makeSingletons = identity
  
  -- | If the type represents an effectful value, make a singleton for it and recurse on the rest
  instance {-# OVERLAPPING #-} (Typeable a, MakeSingletons rest) => MakeSingletons (Rio a : rest) where
    makeSingletons (SingletonsRegistry r) =
      makeSingletons $ SingletonsRegistry @rest (tweakUnspecialized @(Rio a) singleton r)
  
  -- | If the type represents a pure value, make singletons for the rest
  instance (MakeSingletons rest) => MakeSingletons (a : rest) where
    makeSingletons (SingletonsRegistry r) = makeSingletons (makeSingletonsRegistry @rest r)
  