{-# LANGUAGE CPP #-}
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

-- | A consumer for log records
type LogSink = LogRecord -> IO ()

-- use the unsafePerformIO hack to share one sink across a process
logSink :: IORef LogSink
logSink :: IORef LogSink
logSink = forall a. IO a -> a
unsafePerformIO (IO LogSink
defaultLogSink forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
newIORef)
{-# NOINLINE logSink #-}

-- | Return the global log sink.
getLogSink :: IO LogSink
getLogSink :: IO LogSink
getLogSink = forall a. IORef a -> IO a
readIORef IORef LogSink
logSink

-- | Set the global log sink.
setLogSink :: LogSink -> IO ()
setLogSink :: LogSink -> IO ()
setLogSink = forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef LogSink
logSink

-- | Return the global log sink and set it to a new value in one atomic
-- operation.
swapLogSink :: LogSink -> IO LogSink
swapLogSink :: LogSink -> IO LogSink
swapLogSink LogSink
new = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef LogSink
logSink forall a b. (a -> b) -> a -> b
$ \LogSink
old -> (LogSink
new, LogSink
old)

-- | Set the global log sink to a specified value, run given action, and
-- finally restore the global log sink to its previous value.
withLogSink :: LogSink -> IO () -> IO ()
withLogSink :: LogSink -> IO () -> IO ()
withLogSink LogSink
sink IO ()
action = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LogSink -> IO LogSink
swapLogSink LogSink
sink) LogSink -> IO ()
setLogSink (forall a b. a -> b -> a
const IO ()
action)

-- | A thread-safe log sink that writes log messages to `stderr`
defaultLogSink :: IO LogSink
defaultLogSink :: IO LogSink
defaultLogSink = MVar () -> LogSink
defaultLogSink_ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. a -> IO (MVar a)
newMVar ()

defaultLogSink_ :: MVar () -> LogSink
defaultLogSink_ :: MVar () -> LogSink
defaultLogSink_ MVar ()
mvar LogRecord
record = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mvar (\() -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
output)
  where
    level :: LogLevel
level = LogRecord -> LogLevel
logRecordLevel LogRecord
record
    mLocation :: Maybe Location
mLocation = LogRecord -> Maybe Location
logRecordLocation LogRecord
record
    message :: String
message = LogRecord -> String
logRecordMessage LogRecord
record
    output :: String
output = forall a. Show a => a -> String -> String
shows LogLevel
level forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
location forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
": " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
message forall a b. (a -> b) -> a -> b
$ String
""
    location :: String -> String
location = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String -> String
showString String
"") ((String -> String -> String
showString String
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> String -> String
formatLocation) Maybe Location
mLocation

formatLocation :: Location -> ShowS
formatLocation :: Location -> String -> String
formatLocation Location
loc = String -> String -> String
showString (Location -> String
locationFile Location
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
colon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows (Location -> Int
locationLine Location
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
colon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows (Location -> Int
locationColumn Location
loc)
  where colon :: String -> String
colon = String -> String -> String
showString String
":"

#if !MIN_VERSION_base(4,6,0)
atomicWriteIORef :: IORef a -> a -> IO ()
atomicWriteIORef ref a = do
    x <- atomicModifyIORef ref (\_ -> (a, ()))
    x `seq` return ()
#endif