    {-# 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 a b. IO a -> (a -> IO b) -> IO b
    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 a b. (a -> b) -> IO a -> IO b
    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