{-# 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 :: (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 Text
source LogLevel
level msg
msg =
      let ?callStack = rioCallStack 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 -> LogLevel
rioLogLevel LogLevel
level) (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)

-- | 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 <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> RIO env (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> RIO env (Loc -> Text -> LogLevel -> LogStr -> IO ()))
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> RIO env (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
source LogLevel
level LogStr
str ->
      let ?callStack = rioCallStack loc
       in RIO env () -> IO ()
runInIO (Text -> LogLevel -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
source (LogLevel -> LogLevel
rioLogLevel LogLevel
level) (LogStr -> Utf8Builder
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]
"", SrcLoc :: [Char] -> [Char] -> [Char] -> Int -> Int -> Int -> Int -> SrcLoc
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 = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
LegacyLogger.loc_start Loc
loc
  , srcLocStartCol :: Int
GS.srcLocStartCol = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
LegacyLogger.loc_start Loc
loc
  , srcLocEndLine :: Int
GS.srcLocEndLine = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
LegacyLogger.loc_end Loc
loc
  , srcLocEndCol :: Int
GS.srcLocEndCol = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
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 :: (ResourceMap -> m a) -> m a
withResourceMap 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
$ \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 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