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