{-# 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 :: Context τ -> Message -> IO ()
putMessage Context τ
context (Message Time
now Severity
level Rope
text Maybe Rope
possiblelValue) = do
let i :: MVar Time
i = Context τ -> MVar Time
forall τ. Context τ -> MVar Time
startTimeFrom Context τ
context
Time
start <- MVar Time -> IO Time
forall a. MVar a -> IO a
readMVar MVar Time
i
let output :: TQueue (Maybe Rope)
output = Context τ -> TQueue (Maybe Rope)
forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
coloured :: Bool
coloured = Context τ -> Bool
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 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 = Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage Time
start Time
now Bool
coloured Severity
level Rope
display
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Rope) -> Maybe Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
output (Rope -> Maybe Rope
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 =
[TimeFormatElem] -> ElapsedP -> String
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'
]
(Time -> ElapsedP
forall a. Instant a => Time -> a
fromTime Time
now :: H.ElapsedP)
!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
!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 ->
[Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat
[ AnsiColour -> Rope
intoEscapes AnsiColour
dullWhite
, 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
colour
, Rope
message
, Rope
reset
]
Bool
False ->
[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 (Maybe Rope)
out = Context τ -> TQueue (Maybe Rope)
forall τ. Context τ -> TQueue (Maybe 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 (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Rope) -> Maybe Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (Rope -> Maybe Rope
forall a. a -> Maybe a
Just 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 (Maybe Rope)
out = Context τ -> TQueue (Maybe Rope)
forall τ. Context τ -> TQueue (Maybe 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 (Maybe Rope) -> Maybe Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
text'))
info :: Rope -> Program τ ()
info :: Rope -> Program τ ()
info 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
Time
now <- IO Time
getCurrentTimeNanoseconds
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInfo Rope
text Maybe Rope
forall a. Maybe a
Nothing)
warn :: Rope -> Program τ ()
warn :: Rope -> Program τ ()
warn 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
Time
now <- IO Time
getCurrentTimeNanoseconds
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityWarn Rope
text Maybe Rope
forall a. Maybe a
Nothing)
critical :: Rope -> Program τ ()
critical :: Rope -> Program τ ()
critical 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
Time
now <- IO Time
getCurrentTimeNanoseconds
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityCritical 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
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 :: 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
Time
now <- IO Time
getCurrentTimeNanoseconds
!Rope
value' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
value
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug 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
Time
now <- IO Time
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 (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug Rope
label (Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
value'))
internal :: Rope -> Program τ ()
internal :: Rope -> Program τ ()
internal Rope
label = 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
isInternal Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInternal Rope
label Maybe Rope
forall a. Maybe a
Nothing)