cli/Hcompta/Expr/Log.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 {-# OPTIONS_GHC -fno-warn-tabs #-}
  10 module Hcompta.Expr.Log where
  11
  12 import Control.Applicative (Applicative(..))
  13 import Control.Monad (Monad(..))
  14 import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
  15 import qualified Control.Monad.Classes as MC
  16 import qualified Control.Monad.Classes.Proxied as MC
  17 import qualified Control.Monad.Classes.Run as MC
  18 import Control.Monad.IO.Class (MonadIO(..))
  19 import Data.Function (($), (.))
  20 import Data.Functor (Functor(..))
  21 import Data.Int (Int)
  22 import Data.Monoid ((<>))
  23 import Data.Ord (Ord(..))
  24 import Data.String (IsString(..))
  25 import Data.Text (Text)
  26 import Data.Text.Buildable (Buildable(..))
  27 import qualified Data.Time.LocalTime as Time
  28 import Prelude (truncate)
  29
  30 import Hcompta.Lib.Data.Monoid (Monoid1)
  31
  32 -- * Type 'Log'
  33
  34 data Log a
  35  =   Log
  36  {   log_time     :: Time.ZonedTime
  37  ,   log_facility :: Log_Facility
  38  ,   log_data     :: a
  39  } deriving (Functor)
  40 instance Buildable x => Buildable (Log x) where
  41         build Log{..} =
  42                 let Time.TimeOfDay h m s =
  43                         Time.localTimeOfDay $
  44                         Time.zonedTimeToLocalTime log_time in
  45                 "[" <> int2 h <>
  46                 ":" <> int2 m <>
  47                 ":" <> int2 (truncate s::Int) <>
  48                 "] " <>
  49                 build log_facility <> ": " <>
  50                 build log_data
  51                 where
  52                         int2 i = (if i < 10 then "0" else "") <> build i
  53
  54 -- ** Type 'Log_Facility'
  55 data Log_Facility
  56  =   Debug
  57  |   Info
  58  |   Warn
  59 instance Buildable Log_Facility where
  60         build Debug = "debug"
  61         build Info  = "info"
  62         build Warn  = "warn"
  63
  64 log ::
  65  ( MC.MonadWriter (Log a) m
  66  , MonadIO m
  67  ) => Log_Facility -> a -> m ()
  68 log log_facility log_data = do
  69         log_time <- liftIO Time.getZonedTime
  70         MC.tell Log
  71          { log_time
  72          , log_facility
  73          , log_data
  74          }
  75
  76 -- * Type 'LogT'
  77
  78 -- | A 'Monad' transformer to handle different log data types,
  79 -- eventually embedded (through class instances) into a single data type
  80 -- put in the 'Monad' stack with 'MC.MonadWriter'.
  81 newtype LogT w m a = LogT (MC.CustomWriterT' (Log w) m m a)
  82  deriving
  83  ( Functor, Applicative, Monoid1
  84  , Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
  85
  86 evalLogWith
  87  :: forall w m a . (Log w -> m ())
  88  -> LogT w m a
  89  -> m a
  90 evalLogWith tellFn a =
  91         MC.reify tellFn $ \px ->
  92                 case a of
  93                  LogT (MC.CustomWriterT (MC.Proxied a')) -> a' px
  94
  95 -- ** Type 'Log_Message'
  96
  97 newtype Log_Message = Log_Message Text
  98 instance Buildable Log_Message where
  99         build (Log_Message x) = build x
 100 instance IsString Log_Message where
 101         fromString = Log_Message . fromString