{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
{-# 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 (..))
import qualified Control.Monad.Logger as LegacyLogger
import Control.Monad.Logger (MonadLogger (..), LogStr)
import System.Log.FastLogger (fromLogStr)
import qualified GHC.Stack as GS
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 :: (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
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
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
type ResourceMap = IORef ReleaseMap
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
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