]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/Expr/Log.hs
Adapte hcompta-cli.
[comptalang.git] / 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