{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Logging
( putMessage
, formatLogMessage
, Severity (..)
, Verbosity (..)
, write
, writeS
, writeR
, info
, warn
, critical
, debug
, debugS
, debugR
, internal
, isEvent
, isDebug
, isInternal
) where
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 qualified as H (ElapsedP, TimeFormatElem (..), timePrint)
import Data.Text.Short qualified as S (replicate)
import Core.Data.Clock
import Core.Program.Context
import Core.System.Base
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities
data Message = Message Time Severity Rope (Maybe Rope)
data Severity
= SeverityNone
| SeverityCritical
| SeverityWarn
| SeverityInfo
| SeverityDebug
| SeverityInternal
putMessage :: Context τ -> Message -> IO ()
putMessage :: forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Message Time
now Severity
level Rope
text Maybe Rope
possiblelValue) = do
let i :: MVar Time
i = forall τ. Context τ -> MVar Time
startTimeFrom Context τ
context
Time
start <- forall a. MVar a -> IO a
readMVar MVar Time
i
let output :: TQueue (Maybe Rope)
output = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
coloured :: Bool
coloured = forall τ. Context τ -> Bool
terminalColouredFrom Context τ
context
let display :: Rope
display = case Maybe Rope
possiblelValue of
Just Rope
value ->
if Char -> Rope -> Bool
containsCharacter Char
'\n' Rope
value
then Rope
text forall a. Semigroup a => a -> a -> a
<> Rope
" =\n" forall a. Semigroup a => a -> a -> a
<> Rope
value
else Rope
text forall a. Semigroup a => a -> a -> a
<> Rope
" = " forall a. Semigroup a => a -> a -> a
<> Rope
value
Maybe Rope
Nothing -> Rope
text
let !result :: Rope
result = Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage Time
start Time
now Bool
coloured Severity
level Rope
display
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
output (forall a. a -> Maybe a
Just Rope
result)
formatLogMessage :: Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage :: Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage Time
start Time
now Bool
coloured Severity
severity Rope
message =
let !start' :: Int64
start' = Time -> Int64
unTime Time
start
!now' :: Int64
now' = Time -> Int64
unTime Time
now
!stampZ :: String
stampZ =
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> String
H.timePrint
[ TimeFormatElem
H.Format_Hour
, Char -> TimeFormatElem
H.Format_Text Char
':'
, TimeFormatElem
H.Format_Minute
, Char -> TimeFormatElem
H.Format_Text Char
':'
, TimeFormatElem
H.Format_Second
, Char -> TimeFormatElem
H.Format_Text Char
'Z'
]
(forall a. Instant a => Time -> a
fromTime Time
now :: H.ElapsedP)
!elapsed :: Fixed E3
elapsed = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational (Int64
now' forall a. Num a => a -> a -> a
- Int64
start') forall a. Fractional a => a -> a -> a
/ Rational
1e9) :: Fixed E3
!colour :: Rope
colour = case Severity
severity of
Severity
SeverityNone -> Rope
emptyRope
Severity
SeverityCritical -> AnsiColour -> Rope
intoEscapes AnsiColour
pureRed
Severity
SeverityWarn -> AnsiColour -> Rope
intoEscapes AnsiColour
pureYellow
Severity
SeverityInfo -> AnsiColour -> Rope
intoEscapes AnsiColour
dullWhite
Severity
SeverityDebug -> AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey
Severity
SeverityInternal -> AnsiColour -> Rope
intoEscapes AnsiColour
dullBlue
!reset :: Rope
reset = AnsiColour -> Rope
intoEscapes AnsiColour
resetColour
in case Bool
coloured of
Bool
True ->
forall a. Monoid a => [a] -> a
mconcat
[ AnsiColour -> Rope
intoEscapes AnsiColour
dullWhite
, forall α. Textual α => α -> Rope
intoRope String
stampZ
, Rope
" ("
, Int -> String -> Rope
padWithZeros Int
6 (forall a. Show a => a -> String
show Fixed E3
elapsed)
, Rope
") "
, Rope
colour
, Rope
message
, Rope
reset
]
Bool
False ->
forall a. Monoid a => [a] -> a
mconcat
[ forall α. Textual α => α -> Rope
intoRope String
stampZ
, Rope
" ("
, Int -> String -> Rope
padWithZeros Int
6 (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 =
forall α. Textual α => α -> Rope
intoRope ShortText
pad forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope String
str
where
!pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len ShortText
"0"
!len :: Int
len = Int
digits forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
write :: Rope -> Program τ ()
write :: forall τ. Rope -> Program τ ()
write Rope
text = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
!Rope
text' <- forall a. a -> IO a
evaluate Rope
text
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
text')
writeS :: Show α => α -> Program τ ()
writeS :: forall α τ. Show α => α -> Program τ ()
writeS = forall τ. Rope -> Program τ ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. Textual α => α -> Rope
intoRope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
writeR :: Render α => α -> Program τ ()
writeR :: forall α τ. Render α => α -> Program τ ()
writeR α
thing = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
let columns :: Int
columns = forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
let text :: Rope
text = forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
!Rope
text' <- forall a. a -> IO a
evaluate Rope
text
forall a. STM a -> IO a
atomically (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
text'))
info :: Rope -> Program τ ()
info :: forall τ. Rope -> Program τ ()
info Rope
text = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInfo Rope
text forall a. Maybe a
Nothing)
warn :: Rope -> Program τ ()
warn :: forall τ. Rope -> Program τ ()
warn Rope
text = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityWarn Rope
text forall a. Maybe a
Nothing)
critical :: Rope -> Program τ ()
critical :: forall τ. Rope -> Program τ ()
critical Rope
text = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityCritical Rope
text forall a. Maybe a
Nothing)
isEvent :: Verbosity -> Bool
isEvent :: Verbosity -> Bool
isEvent Verbosity
level = case Verbosity
level of
Verbosity
Output -> Bool
False
Verbosity
Verbose -> Bool
True
Verbosity
Debug -> Bool
True
Verbosity
Internal -> Bool
True
isDebug :: Verbosity -> Bool
isDebug :: Verbosity -> Bool
isDebug Verbosity
level = case Verbosity
level of
Verbosity
Output -> Bool
False
Verbosity
Verbose -> Bool
False
Verbosity
Debug -> Bool
True
Verbosity
Internal -> Bool
True
isInternal :: Verbosity -> Bool
isInternal :: Verbosity -> Bool
isInternal Verbosity
level = case Verbosity
level of
Verbosity
Output -> Bool
False
Verbosity
Verbose -> Bool
False
Verbosity
Debug -> Bool
False
Verbosity
Internal -> Bool
True
debug :: Rope -> Rope -> Program τ ()
debug :: forall τ. Rope -> Rope -> Program τ ()
debug Rope
label Rope
value = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
!Rope
value' <- forall a. a -> IO a
evaluate Rope
value
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug Rope
label (forall a. a -> Maybe a
Just Rope
value'))
debugS :: Show α => Rope -> α -> Program τ ()
debugS :: forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
label α
value = forall τ. Rope -> Rope -> Program τ ()
debug Rope
label (forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show α
value))
debugR :: Render α => Rope -> α -> Program τ ()
debugR :: forall α τ. Render α => Rope -> α -> Program τ ()
debugR Rope
label α
thing = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
let columns :: Int
columns = forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
let value :: Rope
value = forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
!Rope
value' <- forall a. a -> IO a
evaluate Rope
value
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug Rope
label (forall a. a -> Maybe a
Just Rope
value'))
internal :: Rope -> Program τ ()
internal :: forall τ. Rope -> Program τ ()
internal Rope
label = do
Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isInternal Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInternal Rope
label forall a. Maybe a
Nothing)