{-# 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 = withRunInIO
restoreM = return
instance Display LogStr where
display = displayBytesUtf8 . fromLogStr
instance HasLogFunc env => MonadLogger (RIO env) where
monadLoggerLog loc source level 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 logGeneric source rioLogLevel (display $ LegacyLogger.toLogStr msg)
where
rioLogLevel =
case level of
LegacyLogger.LevelDebug -> LevelDebug
LegacyLogger.LevelInfo -> LevelInfo
LegacyLogger.LevelWarn -> LevelWarn
LegacyLogger.LevelError -> LevelError
LegacyLogger.LevelOther name -> LevelOther name
type ResourceMap = IORef ReleaseMap
withResourceMap :: MonadUnliftIO m => (ResourceMap -> m a) -> m a
withResourceMap inner =
withRunInIO $ \run -> runResourceT $ ResourceT $ run . inner
class HasResourceMap env where
resourceMapL :: Lens' env ResourceMap
instance HasResourceMap (IORef ReleaseMap) where
resourceMapL = id
instance HasResourceMap env => MonadResource (RIO env) where
liftResourceT (ResourceT f) = view resourceMapL >>= liftIO . f