1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE ImplicitParams #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE NoImplicitPrelude #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# OPTIONS_GHC -fno-warn-orphans #-}
9-- | Orphan instances for the 'RIO' data type.
10module RIO.Orphans
11  ( HasResourceMap (..)
12  , ResourceMap
13  , withResourceMap
14  ) where
15
16import RIO
17import Control.Monad.Catch (MonadCatch, MonadMask)
18import Control.Monad.Base (MonadBase)
19import Control.Monad.IO.Unlift (askRunInIO)
20import Control.Monad.Trans.Resource.Internal (MonadResource (..), ReleaseMap, ResourceT (..))
21import Control.Monad.Trans.Resource (runResourceT)
22import Control.Monad.Trans.Control (MonadBaseControl (..))
23
24import qualified Control.Monad.Logger as LegacyLogger
25import Control.Monad.Logger (MonadLogger (..), MonadLoggerIO (..), LogStr)
26import System.Log.FastLogger (fromLogStr)
27import qualified GHC.Stack as GS
28
29-- | @since 0.1.0.0
30deriving instance MonadCatch (RIO env)
31
32-- | @since 0.1.0.0
33deriving instance MonadMask (RIO env)
34
35-- | @since 0.1.0.0
36deriving instance MonadBase IO (RIO env)
37
38-- | @since 0.1.0.0
39instance MonadBaseControl IO (RIO env) where
40  type StM (RIO env) a = a
41
42  liftBaseWith = withRunInIO
43  restoreM = return
44
45-- | @since 0.1.1.0
46instance Display LogStr where
47  display = displayBytesUtf8 . fromLogStr
48
49-- | @since 0.1.1.0
50instance HasLogFunc env => MonadLogger (RIO env) where
51  monadLoggerLog loc source level msg =
52      let ?callStack = rioCallStack loc
53       in logGeneric source (rioLogLevel level) (display $ LegacyLogger.toLogStr msg)
54
55-- | Do not let the generated function escape its RIO context. This may lead
56--   to log-related cleanup running /before/ the function is called.
57--
58--   @since 0.1.2.0
59instance HasLogFunc env => MonadLoggerIO (RIO env) where
60  askLoggerIO = do
61    runInIO <- askRunInIO
62    pure $ \loc source level str ->
63      let ?callStack = rioCallStack loc
64       in runInIO (logGeneric source (rioLogLevel level) (display str))
65
66rioLogLevel :: LegacyLogger.LogLevel -> LogLevel
67rioLogLevel level =
68  case level of
69    LegacyLogger.LevelDebug -> LevelDebug
70    LegacyLogger.LevelInfo  -> LevelInfo
71    LegacyLogger.LevelWarn  -> LevelWarn
72    LegacyLogger.LevelError  -> LevelError
73    LegacyLogger.LevelOther name -> LevelOther name
74
75rioCallStack :: LegacyLogger.Loc -> CallStack
76rioCallStack loc = GS.fromCallSiteList [("", GS.SrcLoc
77  { GS.srcLocPackage = LegacyLogger.loc_package loc
78  , GS.srcLocModule = LegacyLogger.loc_module loc
79  , GS.srcLocFile = LegacyLogger.loc_filename loc
80  , GS.srcLocStartLine = fst $ LegacyLogger.loc_start loc
81  , GS.srcLocStartCol = snd $ LegacyLogger.loc_start loc
82  , GS.srcLocEndLine = fst $ LegacyLogger.loc_end loc
83  , GS.srcLocEndCol = snd $ LegacyLogger.loc_end loc
84  })]
85
86-- | A collection of all of the registered resource cleanup actions.
87--
88-- @since 0.1.0.0
89type ResourceMap = IORef ReleaseMap
90
91-- | Perform an action with a 'ResourceMap'
92--
93-- @since 0.1.0.0
94withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a
95withResourceMap inner =
96  withRunInIO $ \run -> runResourceT $ ResourceT $ run . inner
97
98-- | An environment with a 'ResourceMap'
99--
100-- @since 0.1.0.0
101class HasResourceMap env where
102  resourceMapL :: Lens' env ResourceMap
103instance HasResourceMap (IORef ReleaseMap) where
104  resourceMapL = id
105instance HasResourceMap env => MonadResource (RIO env) where
106  liftResourceT (ResourceT f) = view resourceMapL >>= liftIO . f
107