{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Logging
(
putMessage
, Verbosity(..)
, event
, debug
, debugS
, debugR
) where
import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)
import Control.Concurrent.MVar (readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import Control.Exception (evaluate)
import Control.Monad (when)
import Control.Monad.Reader.Class (MonadReader(ask))
import Data.Fixed
import Data.Hourglass (timePrint, TimeFormatElem(..))
import qualified Data.Text.Short as S (replicate)
import Core.Text.Rope
import Core.Text.Utilities
import Core.System.Base
import Core.Program.Context
putMessage :: Context τ -> Message -> IO ()
putMessage context message@(Message now _ text potentialValue) = do
let start = startTimeFrom context
let output = outputChannelFrom context
let logger = loggerChannelFrom context
let display = case potentialValue of
Just value ->
if contains '\n' value
then text <> " =\n" <> value
else text <> " = " <> value
Nothing -> text
let result = formatLogMessage start now display
atomically $ do
writeTQueue output result
writeTQueue logger message
formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage start now message =
let
start' = unTimeStamp start
now' = unTimeStamp now
stampZ = timePrint
[ Format_Hour
, Format_Text ':'
, Format_Minute
, Format_Text ':'
, Format_Second
, Format_Text 'Z'
] now
elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3
in
mconcat
[ intoRope stampZ
, " ("
, padWithZeros 9 (show elapsed)
, ") "
, message
]
padWithZeros :: Int -> String -> Rope
padWithZeros digits str =
intoRope pad <> intoRope str
where
pad = S.replicate len "0"
len = digits - length str
event :: Rope -> Program τ ()
event text = do
context <- ask
liftIO $ do
level <- readMVar (verbosityLevelFrom context)
when (isEvent level) $ do
now <- getCurrentTimeNanoseconds
putMessage context (Message now Event text Nothing)
isEvent :: Verbosity -> Bool
isEvent level = case level of
Output -> False
Event -> True
Debug -> True
isDebug :: Verbosity -> Bool
isDebug level = case level of
Output -> False
Event -> False
Debug -> True
debug :: Rope -> Rope -> Program τ ()
debug label value = do
context <- ask
liftIO $ do
level <- readMVar (verbosityLevelFrom context)
when (isDebug level) $ do
now <- getCurrentTimeNanoseconds
!value' <- evaluate value
putMessage context (Message now Debug label (Just value'))
debugS :: Show α => Rope -> α -> Program τ ()
debugS label value = debug label (intoRope (show value))
debugR :: Render α => Rope -> α -> Program τ ()
debugR label thing = do
context <- ask
liftIO $ do
level <- readMVar (verbosityLevelFrom context)
when (isDebug level) $ do
now <- getCurrentTimeNanoseconds
let columns = terminalWidthFrom context
let value = render columns thing
!value' <- evaluate value
putMessage context (Message now Debug label (Just value'))