{-# LANGUAGE OverloadedStrings #-}

module Hledger.Flow.Logging where

import Hledger.Flow.Types
import Control.Concurrent.STM
import Control.Monad (when)

import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.LocalTime (getZonedTime)

import qualified GHC.IO.Handle.FD as H
import qualified Turtle
import Turtle ((%))

dummyLogger :: TChan LogMessage -> T.Text -> IO ()
dummyLogger :: TChan LogMessage -> Text -> IO ()
dummyLogger TChan LogMessage
_ Text
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

channelOut :: TChan LogMessage -> T.Text -> IO ()
channelOut :: TChan LogMessage -> Text -> IO ()
channelOut TChan LogMessage
ch Text
txt = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LogMessage -> LogMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan LogMessage
ch (LogMessage -> STM ()) -> LogMessage -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
StdOut Text
txt

channelOutLn :: TChan LogMessage -> T.Text -> IO ()
channelOutLn :: TChan LogMessage -> Text -> IO ()
channelOutLn TChan LogMessage
ch Text
txt = TChan LogMessage -> Text -> IO ()
channelOut TChan LogMessage
ch (Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

channelErr :: TChan LogMessage -> T.Text -> IO ()
channelErr :: TChan LogMessage -> Text -> IO ()
channelErr TChan LogMessage
ch Text
txt = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LogMessage -> LogMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan LogMessage
ch (LogMessage -> STM ()) -> LogMessage -> STM ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
StdErr Text
txt

channelErrLn :: TChan LogMessage -> T.Text -> IO ()
channelErrLn :: TChan LogMessage -> Text -> IO ()
channelErrLn TChan LogMessage
ch Text
txt = TChan LogMessage -> Text -> IO ()
channelErr TChan LogMessage
ch (Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

logToChannel :: TChan LogMessage -> T.Text -> IO ()
logToChannel :: TChan LogMessage -> Text -> IO ()
logToChannel TChan LogMessage
ch Text
msg = do
  Text
ts <- Text -> IO Text
timestampPrefix Text
msg
  TChan LogMessage -> Text -> IO ()
channelErrLn TChan LogMessage
ch Text
ts

timestampPrefix :: T.Text -> IO T.Text
timestampPrefix :: Text -> IO Text
timestampPrefix Text
txt = do
  ZonedTime
t <- IO ZonedTime
getZonedTime
  Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Format Text (Text -> Text -> Text) -> Text -> Text -> Text
forall r. Format Text r -> r
Turtle.format (Format (Text -> Text) (Text -> Text -> Text)
forall r. Format r (Text -> r)
Turtle.sFormat (Text -> Text) (Text -> Text -> Text)
-> Format (Text -> Text) (Text -> Text)
-> Format (Text -> Text) (Text -> Text -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format (Text -> Text) (Text -> Text)
"\thledger-flow "Format (Text -> Text) (Text -> Text -> Text)
-> Format Text (Text -> Text) -> Format Text (Text -> Text -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format Text (Text -> Text)
forall r. Format r (Text -> r)
Turtle.s) (ZonedTime -> Text
forall a text. (Show a, IsString text) => a -> text
Turtle.repr ZonedTime
t) Text
txt

consoleChannelLoop :: TChan LogMessage -> IO ()
consoleChannelLoop :: TChan LogMessage -> IO ()
consoleChannelLoop TChan LogMessage
ch = do
  LogMessage
logMsg <- STM LogMessage -> IO LogMessage
forall a. STM a -> IO a
atomically (STM LogMessage -> IO LogMessage)
-> STM LogMessage -> IO LogMessage
forall a b. (a -> b) -> a -> b
$ TChan LogMessage -> STM LogMessage
forall a. TChan a -> STM a
readTChan TChan LogMessage
ch
  case LogMessage
logMsg of
    StdOut Text
msg -> do
      Handle -> Text -> IO ()
T.hPutStr Handle
H.stdout Text
msg
      TChan LogMessage -> IO ()
consoleChannelLoop TChan LogMessage
ch
    StdErr Text
msg -> do
      Handle -> Text -> IO ()
T.hPutStr Handle
H.stderr Text
msg
      TChan LogMessage -> IO ()
consoleChannelLoop TChan LogMessage
ch
    LogMessage
Terminate  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

terminateChannelLoop :: TChan LogMessage -> IO ()
terminateChannelLoop :: TChan LogMessage -> IO ()
terminateChannelLoop TChan LogMessage
ch = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LogMessage -> LogMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan LogMessage
ch LogMessage
Terminate

logVerbose :: HasVerbosity o => o -> TChan LogMessage -> T.Text -> IO ()
logVerbose :: o -> TChan LogMessage -> Text -> IO ()
logVerbose o
opts TChan LogMessage
ch Text
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (o -> Bool
forall a. HasVerbosity a => a -> Bool
verbose o
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LogMessage -> Text -> IO ()
logToChannel TChan LogMessage
ch Text
msg