{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module RIO.Orphans
( HasResourceMap (..)
, ResourceMap
, withResourceMap
) where
import RIO
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.Base (MonadBase)
import Control.Monad.Trans.Resource.Internal (MonadResource (..), ReleaseMap, ResourceT (..))
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans.Control (MonadBaseControl (..))
deriving instance MonadCatch (RIO env)
deriving instance MonadMask (RIO env)
deriving instance MonadBase IO (RIO env)
instance MonadBaseControl IO (RIO env) where
type StM (RIO env) a = a
liftBaseWith = withRunInIO
restoreM = return
type ResourceMap = IORef ReleaseMap
withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a
withResourceMap inner =
withRunInIO $ \run -> runResourceT $ ResourceT $ run . inner
class HasResourceMap env where
resourceMapL :: Lens' env ResourceMap
instance HasResourceMap (IORef ReleaseMap) where
resourceMapL = id
instance HasResourceMap env => MonadResource (RIO env) where
liftResourceT (ResourceT f) = view resourceMapL >>= liftIO . f