module System.Logging.Facade.Sink (
LogSink
, defaultLogSink
, getLogSink
, setLogSink
, swapLogSink
, withLogSink
) where
import Control.Concurrent
import Data.IORef
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception
import System.Logging.Facade.Types
type LogSink = LogRecord -> IO ()
logSink :: IORef LogSink
logSink = unsafePerformIO (defaultLogSink >>= newIORef)
getLogSink :: IO LogSink
getLogSink = readIORef logSink
setLogSink :: LogSink -> IO ()
setLogSink = atomicWriteIORef logSink
swapLogSink :: LogSink -> IO LogSink
swapLogSink new = atomicModifyIORef logSink $ \old -> (new, old)
withLogSink :: LogSink -> IO () -> IO ()
withLogSink sink action = bracket (swapLogSink sink) setLogSink (const action)
defaultLogSink :: IO LogSink
defaultLogSink = defaultLogSink_ `fmap` newMVar ()
defaultLogSink_ :: MVar () -> LogSink
defaultLogSink_ mvar record = withMVar mvar (\() -> hPutStrLn stderr output)
where
level = logRecordLevel record
mLocation = logRecordLocation record
message = logRecordMessage record
output = shows level . location . showString ": " . showString message $ ""
location = maybe (showString "") ((showString " " .) . formatLocation) mLocation
formatLocation :: Location -> ShowS
formatLocation loc = showString (locationFile loc) . colon . shows (locationLine loc) . colon . shows (locationColumn loc)
where colon = showString ":"
#if !MIN_VERSION_base(4,6,0)
atomicWriteIORef :: IORef a -> a -> IO ()
atomicWriteIORef ref a = do
x <- atomicModifyIORef ref (\_ -> (a, ()))
x `seq` return ()
#endif