{-# 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.IO.Unlift (askRunInIO)
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 (..), MonadLoggerIO (..), 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 :: forall a. (RunInBase (RIO env) IO -> IO a) -> RIO env a
liftBaseWith = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO
  restoreM :: forall a. StM (RIO env) a -> RIO env a
restoreM = 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 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 :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> RIO env ()
monadLoggerLog Loc
loc Text
source LogLevel
level msg
msg =
      let ?callStack = Loc -> CallStack
rioCallStack Loc
loc
       in forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
source (LogLevel -> LogLevel
rioLogLevel LogLevel
level) (forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ forall msg. ToLogStr msg => msg -> LogStr
LegacyLogger.toLogStr msg
msg)

-- | Do not let the generated function escape its RIO context. This may lead
--   to log-related cleanup running /before/ the function is called.
--
--   @since 0.1.2.0
instance HasLogFunc env => MonadLoggerIO (RIO env) where
  askLoggerIO :: RIO env (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO = do
    RIO env () -> IO ()
runInIO <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
source LogLevel
level LogStr
str ->
      let ?callStack = Loc -> CallStack
rioCallStack Loc
loc
       in RIO env () -> IO ()
runInIO (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
source (LogLevel -> LogLevel
rioLogLevel LogLevel
level) (forall a. Display a => a -> Utf8Builder
display LogStr
str))

rioLogLevel :: LegacyLogger.LogLevel -> LogLevel
rioLogLevel :: LogLevel -> LogLevel
rioLogLevel LogLevel
level =
  case LogLevel
level of
    LogLevel
LegacyLogger.LevelDebug -> LogLevel
LevelDebug
    LogLevel
LegacyLogger.LevelInfo  -> LogLevel
LevelInfo
    LogLevel
LegacyLogger.LevelWarn  -> LogLevel
LevelWarn
    LogLevel
LegacyLogger.LevelError  -> LogLevel
LevelError
    LegacyLogger.LevelOther Text
name -> Text -> LogLevel
LevelOther Text
name

rioCallStack :: LegacyLogger.Loc -> CallStack
rioCallStack :: Loc -> CallStack
rioCallStack Loc
loc = [([Char], SrcLoc)] -> CallStack
GS.fromCallSiteList [([Char]
"", GS.SrcLoc
  { srcLocPackage :: [Char]
GS.srcLocPackage = Loc -> [Char]
LegacyLogger.loc_package Loc
loc
  , srcLocModule :: [Char]
GS.srcLocModule = Loc -> [Char]
LegacyLogger.loc_module Loc
loc
  , srcLocFile :: [Char]
GS.srcLocFile = Loc -> [Char]
LegacyLogger.loc_filename Loc
loc
  , srcLocStartLine :: Int
GS.srcLocStartLine = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
LegacyLogger.loc_start Loc
loc
  , srcLocStartCol :: Int
GS.srcLocStartCol = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
LegacyLogger.loc_start Loc
loc
  , srcLocEndLine :: Int
GS.srcLocEndLine = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
LegacyLogger.loc_end Loc
loc
  , srcLocEndCol :: Int
GS.srcLocEndCol = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
LegacyLogger.loc_end Loc
loc
  })]

-- | 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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(ResourceMap -> m a) -> m a
withResourceMap ResourceMap -> m a
inner =
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (ResourceMap -> m a) -> ResourceT m a
ResourceT forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
run 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 :: Lens' ResourceMap ResourceMap
resourceMapL = forall a. a -> a
id
instance HasResourceMap env => MonadResource (RIO env) where
  liftResourceT :: forall a. ResourceT IO a -> RIO env a
liftResourceT (ResourceT ResourceMap -> IO a
f) = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasResourceMap env => Lens' env ResourceMap
resourceMapL forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceMap -> IO a
f