{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-}
module System.Log.Heavy.IO
( withLoggingIO
) where
import Control.Exception
import Data.IORef
import Data.TLS.GHC
import System.IO.Unsafe (unsafePerformIO)
import System.Log.Heavy.Types
data LoggingIOState = LoggingIOState {
LoggingIOState -> SpecializedLogger
liosLogger :: SpecializedLogger
, LoggingIOState -> AnyLogBackend
liosBackend :: AnyLogBackend
, LoggingIOState -> LogContext
liosContext :: LogContext
}
loggingTLS :: TLS (IORef (Maybe LoggingIOState))
loggingTLS :: TLS (IORef (Maybe LoggingIOState))
loggingTLS = IO (TLS (IORef (Maybe LoggingIOState)))
-> TLS (IORef (Maybe LoggingIOState))
forall a. IO a -> a
unsafePerformIO (IO (TLS (IORef (Maybe LoggingIOState)))
-> TLS (IORef (Maybe LoggingIOState)))
-> IO (TLS (IORef (Maybe LoggingIOState)))
-> TLS (IORef (Maybe LoggingIOState))
forall a b. (a -> b) -> a -> b
$ IO (IORef (Maybe LoggingIOState))
-> IO (TLS (IORef (Maybe LoggingIOState)))
forall a. IO a -> IO (TLS a)
mkTLS (IO (IORef (Maybe LoggingIOState))
-> IO (TLS (IORef (Maybe LoggingIOState))))
-> IO (IORef (Maybe LoggingIOState))
-> IO (TLS (IORef (Maybe LoggingIOState)))
forall a b. (a -> b) -> a -> b
$ do
Maybe LoggingIOState -> IO (IORef (Maybe LoggingIOState))
forall a. a -> IO (IORef a)
newIORef Maybe LoggingIOState
forall a. Maybe a
Nothing
{-# NOINLINE loggingTLS #-}
withLoggingIO :: LoggingSettings
-> IO a
-> IO a
withLoggingIO :: LoggingSettings -> IO a -> IO a
withLoggingIO (LoggingSettings LogBackendSettings b
settings) IO a
actions =
IO LoggingIOState
-> (LoggingIOState -> IO ()) -> (LoggingIOState -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LogBackendSettings b -> IO LoggingIOState
forall b.
IsLogBackend b =>
LogBackendSettings b -> IO LoggingIOState
init LogBackendSettings b
settings)
(LoggingIOState -> IO ()
forall p. p -> IO ()
cleanup)
(\LoggingIOState
tls -> LoggingIOState -> IO a -> IO a
forall p p. p -> p -> p
withBackend LoggingIOState
tls IO a
actions)
where
init :: LogBackendSettings b -> IO LoggingIOState
init LogBackendSettings b
settings = do
IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
Maybe LoggingIOState
mbState <- IORef (Maybe LoggingIOState) -> IO (Maybe LoggingIOState)
forall a. IORef a -> IO a
readIORef IORef (Maybe LoggingIOState)
ioref
case Maybe LoggingIOState
mbState of
Just LoggingIOState
_ -> String -> IO LoggingIOState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Logging IO state is already initialized. withLoggingIO was called twice?"
Maybe LoggingIOState
Nothing -> do
b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings
let logger :: SpecializedLogger
logger = Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
backend
let st :: LoggingIOState
st = SpecializedLogger -> AnyLogBackend -> LogContext -> LoggingIOState
LoggingIOState SpecializedLogger
logger (b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend b
backend) []
IORef (Maybe LoggingIOState) -> Maybe LoggingIOState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe LoggingIOState)
ioref (LoggingIOState -> Maybe LoggingIOState
forall a. a -> Maybe a
Just LoggingIOState
st)
LoggingIOState -> IO LoggingIOState
forall (m :: * -> *) a. Monad m => a -> m a
return LoggingIOState
st
cleanup :: p -> IO ()
cleanup p
st = do
IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
TLS (IORef (Maybe LoggingIOState)) -> IO ()
forall a. TLS a -> IO ()
freeAllTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
IORef (Maybe LoggingIOState) -> Maybe LoggingIOState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe LoggingIOState)
ioref Maybe LoggingIOState
forall a. Maybe a
Nothing
withBackend :: p -> p -> p
withBackend p
st p
actions = p
actions
getLogginngIOState :: IO LoggingIOState
getLogginngIOState :: IO LoggingIOState
getLogginngIOState = do
IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
Maybe LoggingIOState
mbState <- IORef (Maybe LoggingIOState) -> IO (Maybe LoggingIOState)
forall a. IORef a -> IO a
readIORef IORef (Maybe LoggingIOState)
ioref
case Maybe LoggingIOState
mbState of
Maybe LoggingIOState
Nothing -> String -> IO LoggingIOState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"get: Logging IO state is not initialized. See withLoggingIO."
Just LoggingIOState
st -> LoggingIOState -> IO LoggingIOState
forall (m :: * -> *) a. Monad m => a -> m a
return LoggingIOState
st
modifyLoggingIOState :: (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState :: (LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState LoggingIOState -> LoggingIOState
fn = do
IORef (Maybe LoggingIOState)
ioref <- TLS (IORef (Maybe LoggingIOState))
-> IO (IORef (Maybe LoggingIOState))
forall a. TLS a -> IO a
getTLS TLS (IORef (Maybe LoggingIOState))
loggingTLS
IORef (Maybe LoggingIOState)
-> (Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Maybe LoggingIOState)
ioref ((Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ())
-> (Maybe LoggingIOState -> Maybe LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe LoggingIOState
mbState ->
case Maybe LoggingIOState
mbState of
Maybe LoggingIOState
Nothing -> String -> Maybe LoggingIOState
forall a. HasCallStack => String -> a
error String
"modify: Logging IO state is not initialized. See withLoggingIO."
Just LoggingIOState
st -> LoggingIOState -> Maybe LoggingIOState
forall a. a -> Maybe a
Just (LoggingIOState -> LoggingIOState
fn LoggingIOState
st)
instance HasLogBackend AnyLogBackend IO where
getLogBackend :: IO AnyLogBackend
getLogBackend = do
LoggingIOState
st <- IO LoggingIOState
getLogginngIOState
AnyLogBackend -> IO AnyLogBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyLogBackend -> IO AnyLogBackend)
-> AnyLogBackend -> IO AnyLogBackend
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> AnyLogBackend
liosBackend LoggingIOState
st
instance HasLogger IO where
getLogger :: IO SpecializedLogger
getLogger = do
LoggingIOState
st <- IO LoggingIOState
getLogginngIOState
SpecializedLogger -> IO SpecializedLogger
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecializedLogger -> IO SpecializedLogger)
-> SpecializedLogger -> IO SpecializedLogger
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> SpecializedLogger
liosLogger LoggingIOState
st
localLogger :: SpecializedLogger -> IO a -> IO a
localLogger SpecializedLogger
logger IO a
actions = do
SpecializedLogger
oldLogger <- IO SpecializedLogger
forall (m :: * -> *). HasLogger m => m SpecializedLogger
getLogger
(LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosLogger :: SpecializedLogger
liosLogger = SpecializedLogger
logger}
a
result <- IO a
actions
(LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosLogger :: SpecializedLogger
liosLogger = SpecializedLogger
oldLogger}
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
instance HasLogContext IO where
getLogContext :: IO LogContext
getLogContext = do
LoggingIOState
st <- IO LoggingIOState
getLogginngIOState
LogContext -> IO LogContext
forall (m :: * -> *) a. Monad m => a -> m a
return (LogContext -> IO LogContext) -> LogContext -> IO LogContext
forall a b. (a -> b) -> a -> b
$ LoggingIOState -> LogContext
liosContext LoggingIOState
st
withLogContext :: LogContextFrame -> IO a -> IO a
withLogContext LogContextFrame
frame IO a
actions = do
LogContext
oldContext <- IO LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
(LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosContext :: LogContext
liosContext = LogContextFrame
frameLogContextFrame -> LogContext -> LogContext
forall a. a -> [a] -> [a]
:LogContext
oldContext}
a
result <- IO a
actions
(LoggingIOState -> LoggingIOState) -> IO ()
modifyLoggingIOState ((LoggingIOState -> LoggingIOState) -> IO ())
-> (LoggingIOState -> LoggingIOState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LoggingIOState
st -> LoggingIOState
st {liosContext :: LogContext
liosContext = LogContext
oldContext}
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result