{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Orphan instances for the 'RIO' data type.
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 (..))

import qualified Control.Monad.Logger as LegacyLogger
import Control.Monad.Logger (MonadLogger (..), LogStr)
import System.Log.FastLogger (fromLogStr)
import qualified GHC.Stack as GS

-- | @since 0.1.0.0
deriving instance MonadCatch (RIO env)

-- | @since 0.1.0.0
deriving instance MonadMask (RIO env)

-- | @since 0.1.0.0
deriving instance MonadBase IO (RIO env)

-- | @since 0.1.0.0
instance MonadBaseControl IO (RIO env) where
  type StM (RIO env) a = a

  liftBaseWith :: (RunInBase (RIO env) IO -> IO a) -> RIO env a
liftBaseWith = (RunInBase (RIO env) IO -> IO a) -> RIO env a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO
  restoreM :: StM (RIO env) a -> RIO env a
restoreM = StM (RIO env) a -> RIO env a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | @since 0.1.1.0
instance Display LogStr where
  display :: LogStr -> Utf8Builder
display = ByteString -> Utf8Builder
displayBytesUtf8 (ByteString -> Utf8Builder)
-> (LogStr -> ByteString) -> LogStr -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr

-- | @since 0.1.1.0
instance HasLogFunc env => MonadLogger (RIO env) where
  monadLoggerLog :: Loc -> Text -> LogLevel -> msg -> RIO env ()
monadLoggerLog loc :: Loc
loc source :: Text
source level :: LogLevel
level msg :: msg
msg =
      let ?callStack = GS.fromCallSiteList [("", GS.SrcLoc
            { GS.srcLocPackage = LegacyLogger.loc_package loc
            , GS.srcLocModule = LegacyLogger.loc_module loc
            , GS.srcLocFile = LegacyLogger.loc_filename loc
            , GS.srcLocStartLine = fst $ LegacyLogger.loc_start loc
            , GS.srcLocStartCol = snd $ LegacyLogger.loc_start loc
            , GS.srcLocEndLine = fst $ LegacyLogger.loc_end loc
            , GS.srcLocEndCol = snd $ LegacyLogger.loc_end loc
            })]
       in Text -> LogLevel -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
source LogLevel
rioLogLevel (LogStr -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (LogStr -> Utf8Builder) -> LogStr -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
LegacyLogger.toLogStr msg
msg)
    where
      rioLogLevel :: LogLevel
rioLogLevel =
        case LogLevel
level of
          LegacyLogger.LevelDebug -> LogLevel
LevelDebug
          LegacyLogger.LevelInfo  -> LogLevel
LevelInfo
          LegacyLogger.LevelWarn  -> LogLevel
LevelWarn
          LegacyLogger.LevelError  -> LogLevel
LevelError
          LegacyLogger.LevelOther name :: Text
name -> Text -> LogLevel
LevelOther Text
name

-- | A collection of all of the registered resource cleanup actions.
--
-- @since 0.1.0.0
type ResourceMap = IORef ReleaseMap

-- | Perform an action with a 'ResourceMap'
--
-- @since 0.1.0.0
withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a
withResourceMap :: (ResourceMap -> m a) -> m a
withResourceMap inner :: ResourceMap -> m a
inner =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \run :: forall a. m a -> IO a
run -> ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (ResourceMap -> IO a) -> ResourceT IO a
forall (m :: * -> *) a. (ResourceMap -> m a) -> ResourceT m a
ResourceT ((ResourceMap -> IO a) -> ResourceT IO a)
-> (ResourceMap -> IO a) -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (ResourceMap -> m a) -> ResourceMap -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceMap -> m a
inner

-- | An environment with a 'ResourceMap'
--
-- @since 0.1.0.0
class HasResourceMap env where
  resourceMapL :: Lens' env ResourceMap
instance HasResourceMap (IORef ReleaseMap) where
  resourceMapL :: (ResourceMap -> f ResourceMap) -> ResourceMap -> f ResourceMap
resourceMapL = (ResourceMap -> f ResourceMap) -> ResourceMap -> f ResourceMap
forall a. a -> a
id
instance HasResourceMap env => MonadResource (RIO env) where
  liftResourceT :: ResourceT IO a -> RIO env a
liftResourceT (ResourceT f :: ResourceMap -> IO a
f) = Getting ResourceMap env ResourceMap -> RIO env ResourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ResourceMap env ResourceMap
forall env. HasResourceMap env => Lens' env ResourceMap
resourceMapL RIO env ResourceMap -> (ResourceMap -> RIO env a) -> RIO env a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RIO env a)
-> (ResourceMap -> IO a) -> ResourceMap -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceMap -> IO a
f