{-# 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