{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Logging (
putMessage,
Verbosity (..),
write,
writeS,
writeR,
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 (TimeFormatElem (..), timePrint)
import qualified Data.Text.Short as S (replicate)
import Core.Program.Context
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities
putMessage :: Context τ -> Message -> IO ()
putMessage :: Context τ -> Message -> IO ()
putMessage Context τ
context message :: Message
message@(Message TimeStamp
now Verbosity
_ Rope
text Maybe Rope
potentialValue) = do
let i :: MVar TimeStamp
i = Context τ -> MVar TimeStamp
forall τ. Context τ -> MVar TimeStamp
startTimeFrom Context τ
context
TimeStamp
start <- MVar TimeStamp -> IO TimeStamp
forall a. MVar a -> IO a
readMVar MVar TimeStamp
i
let output :: TQueue Rope
output = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
let logger :: TQueue Message
logger = Context τ -> TQueue Message
forall τ. Context τ -> TQueue Message
loggerChannelFrom Context τ
context
let display :: Rope
display = case Maybe Rope
potentialValue of
Just Rope
value ->
if Char -> Rope -> Bool
containsCharacter Char
'\n' Rope
value
then Rope
text Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" =\n" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
value
else Rope
text Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
value
Maybe Rope
Nothing -> Rope
text
let result :: Rope
result = TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage TimeStamp
start TimeStamp
now Rope
display
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue Rope -> Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Rope
output Rope
result
TQueue Message -> Message -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Message
logger Message
message
formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage TimeStamp
start TimeStamp
now Rope
message =
let start' :: Int64
start' = TimeStamp -> Int64
unTimeStamp TimeStamp
start
now' :: Int64
now' = TimeStamp -> Int64
unTimeStamp TimeStamp
now
stampZ :: String
stampZ =
[TimeFormatElem] -> TimeStamp -> String
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> String
timePrint
[ TimeFormatElem
Format_Hour
, Char -> TimeFormatElem
Format_Text Char
':'
, TimeFormatElem
Format_Minute
, Char -> TimeFormatElem
Format_Text Char
':'
, TimeFormatElem
Format_Second
, Char -> TimeFormatElem
Format_Text Char
'Z'
]
TimeStamp
now
elapsed :: Fixed E3
elapsed = Rational -> Fixed E3
forall a. Fractional a => Rational -> a
fromRational (Int64 -> Rational
forall a. Real a => a -> Rational
toRational (Int64
now' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
start') Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1e9) :: Fixed E3
in [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat
[ String -> Rope
forall α. Textual α => α -> Rope
intoRope String
stampZ
, Rope
" ("
, Int -> String -> Rope
padWithZeros Int
6 (Fixed E3 -> String
forall a. Show a => a -> String
show Fixed E3
elapsed)
, Rope
") "
, Rope
message
]
padWithZeros :: Int -> String -> Rope
padWithZeros :: Int -> String -> Rope
padWithZeros Int
digits String
str =
ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope ShortText
pad Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> String -> Rope
forall α. Textual α => α -> Rope
intoRope String
str
where
pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len ShortText
"0"
len :: Int
len = Int
digits Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
write :: Rope -> Program τ ()
write :: Rope -> Program τ ()
write Rope
text = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
let out :: TQueue Rope
out = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
!Rope
text' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
text
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue Rope -> Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Rope
out Rope
text')
writeS :: Show α => α -> Program τ ()
writeS :: α -> Program τ ()
writeS = Rope -> Program τ ()
forall τ. Rope -> Program τ ()
write (Rope -> Program τ ()) -> (α -> Rope) -> α -> Program τ ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (α -> String) -> α -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. α -> String
forall a. Show a => a -> String
show
writeR :: Render α => α -> Program τ ()
writeR :: α -> Program τ ()
writeR α
thing = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
let out :: TQueue Rope
out = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
let columns :: Int
columns = Context τ -> Int
forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
let text :: Rope
text = Int -> α -> Rope
forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
!Rope
text' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
text
STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue Rope -> Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Rope
out Rope
text')
event :: Rope -> Program τ ()
event :: Rope -> Program τ ()
event Rope
text = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (TimeStamp -> Verbosity -> Rope -> Maybe Rope -> Message
Message TimeStamp
now Verbosity
Event Rope
text Maybe Rope
forall a. Maybe a
Nothing)
isEvent :: Verbosity -> Bool
isEvent :: Verbosity -> Bool
isEvent Verbosity
level = case Verbosity
level of
Verbosity
Output -> Bool
False
Verbosity
Event -> Bool
True
Verbosity
Debug -> Bool
True
isDebug :: Verbosity -> Bool
isDebug :: Verbosity -> Bool
isDebug Verbosity
level = case Verbosity
level of
Verbosity
Output -> Bool
False
Verbosity
Event -> Bool
False
Verbosity
Debug -> Bool
True
debug :: Rope -> Rope -> Program τ ()
debug :: Rope -> Rope -> Program τ ()
debug Rope
label Rope
value = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
!Rope
value' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
value
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (TimeStamp -> Verbosity -> Rope -> Maybe Rope -> Message
Message TimeStamp
now Verbosity
Debug Rope
label (Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
value'))
debugS :: Show α => Rope -> α -> Program τ ()
debugS :: Rope -> α -> Program τ ()
debugS Rope
label α
value = Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
label (String -> Rope
forall α. Textual α => α -> Rope
intoRope (α -> String
forall a. Show a => a -> String
show α
value))
debugR :: Render α => Rope -> α -> Program τ ()
debugR :: Rope -> α -> Program τ ()
debugR Rope
label α
thing = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
let columns :: Int
columns = Context τ -> Int
forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
let value :: Rope
value = Int -> α -> Rope
forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
!Rope
value' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
value
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (TimeStamp -> Verbosity -> Rope -> Maybe Rope -> Message
Message TimeStamp
now Verbosity
Debug Rope
label (Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
value'))