{-# 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 = IO (IORef LogSink) -> IORef LogSink
forall a. IO a -> a
unsafePerformIO (IO LogSink
defaultLogSink IO LogSink -> (LogSink -> IO (IORef LogSink)) -> IO (IORef LogSink)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogSink -> IO (IORef LogSink)
forall a. a -> IO (IORef a)
newIORef)
{-# NOINLINE logSink #-}

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

-- | Set the global log sink.
setLogSink :: LogSink -> IO ()
setLogSink :: LogSink -> IO ()
setLogSink = IORef LogSink -> LogSink -> IO ()
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 = IORef LogSink -> (LogSink -> (LogSink, LogSink)) -> IO LogSink
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef LogSink
logSink ((LogSink -> (LogSink, LogSink)) -> IO LogSink)
-> (LogSink -> (LogSink, LogSink)) -> IO 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 = IO LogSink -> (LogSink -> IO ()) -> (LogSink -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LogSink -> IO LogSink
swapLogSink LogSink
sink) LogSink -> IO ()
setLogSink (IO () -> LogSink -> IO ()
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_ (MVar () -> LogSink) -> IO (MVar ()) -> IO LogSink
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()

defaultLogSink_ :: MVar () -> LogSink
defaultLogSink_ :: MVar () -> LogSink
defaultLogSink_ MVar ()
mvar LogRecord
record = MVar () -> (() -> IO ()) -> IO ()
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 = LogLevel -> ShowS
forall a. Show a => a -> ShowS
shows LogLevel
level ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
location ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
message ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
""
    location :: ShowS
location = ShowS -> (Location -> ShowS) -> Maybe Location -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ShowS
showString String
"") ((String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (ShowS -> ShowS) -> (Location -> ShowS) -> Location -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> ShowS
formatLocation) Maybe Location
mLocation

formatLocation :: Location -> ShowS
formatLocation :: Location -> ShowS
formatLocation Location
loc = String -> ShowS
showString (Location -> String
locationFile Location
loc) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
colon ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Location -> Int
locationLine Location
loc) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
colon ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Location -> Int
locationColumn Location
loc)
  where colon :: ShowS
colon = String -> ShowS
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