module Control.Biegunka.Log
(
Logger, plain, exception
, start, stop
, write
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue
import qualified System.Console.Terminal.Size as Term
import System.IO (Handle, hFlush, stderr, stdout)
import Text.PrettyPrint.ANSI.Leijen (Doc, displayIO, renderPretty)
newtype Logger = Logger (TQueue Command)
data Command =
Display Message
| Stop (MVar ())
data Message =
Plain { doc :: Doc }
| Exception { doc :: Doc }
plain :: Doc -> Message
plain = Plain
exception :: Doc -> Message
exception = Exception
start :: IO Logger
start = do
queue <- newTQueueIO
forkIO (loop queue)
return (Logger queue)
where
loop :: TQueue Command -> IO ()
loop queue = do
command <- atomically (readTQueue queue)
case command of
Display message -> do
width <- fmap (maybe 80 Term.width) Term.size
displayIO (logStream message) (renderPretty 0.9 width (doc message))
hFlush stdout
loop queue
Stop var -> putMVar var ()
logStream :: Message -> Handle
logStream (Plain _) = stdout
logStream (Exception _) = stderr
stop :: Logger -> IO ()
stop (Logger queue) = do
var <- newEmptyMVar
atomically (writeTQueue queue (Stop var))
takeMVar var
write :: Logger -> Message -> IO ()
write (Logger queue) message = atomically $
writeTQueue queue (Display message)