1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Hsm.Log
( Severity (Attention, Info, Trace)
, Log
, Logs
, LogOptionPrefix
, getLevel
, logMsg
, makeLoggerIO
, runLog
, runLogOpt
, runLogs
, runLogsOpt
)
where
import Control.Monad (when)
import Data.Function (applyWhen)
import Data.Kind (Constraint)
import Data.List (intercalate)
import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock (getCurrentTime)
import Data.Time.ISO8601 (formatISO8601Millis)
import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>))
import Effectful.Dispatch.Static
( SideEffects (WithSideEffects)
, StaticRep
, evalStaticRep
, getStaticRep
, unEff
, unsafeEff
, unsafeEff_
)
import GHC.Conc.Sync (fromThreadId, myThreadId)
import GHC.Records (HasField, getField)
import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)
import String.ANSI (blue, green, red, white)
data Severity
= Attention
| Info
| Trace
deriving (Enum, Eq, Ord, Read, Show)
coloredShow :: Severity -> String
coloredShow Attention = red "ATTENTION"
coloredShow Info = green "INFO"
coloredShow Trace = blue "TRACE"
data Log (d :: Symbol) (a :: * -> *) (b :: *)
type instance DispatchOf (Log d) = Static WithSideEffects
newtype instance StaticRep (Log d)
= Log Severity
-- Constraint combinator for multiple logger effects
-- Simplifies effect constraints for functions requiring multiple loggers.
--
-- Example:
-- >>> :kind! Logs '["log1", "log2"] es
-- (Log "log1" :> es, Log "log2" :> es)
type family Logs ls es :: Constraint where
Logs '[] es = ()
Logs (l : ls) es = (Log l :> es, Logs ls es)
type LogOptionPrefix = "logLevel_"
getLevel :: Log d :> es => Eff es Severity
getLevel = getStaticRep >>= \(Log level) -> return level
logMsg
:: forall d es
. (KnownSymbol d, Log d :> es)
=> Severity
-> String
-> Eff es ()
logMsg severity message = do
level <- getLevel
when (severity <= level) . unsafeEff_ $ do
time <- formatISO8601Millis <$> getCurrentTime
domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid)
putStrLn $
unwords
[ time
, domainAndThreadId
, coloredShow severity
, applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message
]
makeLoggerIO
:: forall d es
. (KnownSymbol d, Log d :> es)
=> Eff es (Severity -> String -> IO ())
makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env
runLog
:: forall d es a
. IOE :> es
=> Severity
-> Eff (Log d : es) a
-> Eff es a
runLog = evalStaticRep . Log
runLogOpt
:: forall d f o es a
. (AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
=> o
-> Eff (Log d : es) a
-> Eff es a
runLogOpt = runLog . getField @f
class LogsClass (o :: *) (ds :: [Symbol]) (es :: [Effect]) where
type Insert ds es :: [Effect]
runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a
runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a
instance LogsClass (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
type Insert '[] es = es
runLogs = const id
runLogsOpt = const id
instance
(AppendSymbol LogOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, LogsClass o ds es)
=> LogsClass (o :: *) (d : ds :: [Symbol]) (es :: [Effect])
where
type Insert (d : ds) es = Log d : Insert ds es
runLogs level = runLogs @o @ds level . runLog @d level
runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts
|
