rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

push multiple loglevel changes at once

Browse source
This commit is contained in:
rhiannon morris 2024-04-11 22:09:49 +02:00
parent fca75377a0
commit f56f594839
1 changed files with 21 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
lib/Quox/Log.idr
View file

@ -138,18 +138,21 @@ mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
public export public export
data PushArg = SetDefault LogLevel | SetCats LevelMap | SetAll LogLevel data PushArg =
SetDefault LogLevel
| SetCat LogCategory LogLevel
| SetAll LogLevel
%name PushArg push %name PushArg push
export %inline export %inline
applyPush : PushArg -> LogLevels -> LogLevels applyPush : LogLevels -> PushArg -> LogLevels
applyPush (SetDefault def) = {defLevel := def} applyPush lvls (SetDefault def) = {defLevel := def} lvls
applyPush (SetCats map) = {levels $= mergeLeft map} applyPush lvls (SetCat cat lvl) = {levels $= replace cat lvl} lvls
applyPush (SetAll lvl) = const $ MkLogLevels lvl [] applyPush lvls (SetAll lvl) = MkLogLevels lvl []
export %inline export %inline
fromPush : PushArg -> LogLevels fromPush : PushArg -> LogLevels
fromPush p = applyPush p defaultLogLevels fromPush = applyPush defaultLogLevels
public export public export
@ -167,7 +170,7 @@ data LogL : (lbl : tag) -> Type -> Type where
SayMany : (cat : LogCategory) -> (loc : Loc) -> SayMany : (cat : LogCategory) -> (loc : Loc) ->
(msgs : List LogMsg) -> LogL lbl () (msgs : List LogMsg) -> LogL lbl ()
||| set some verbosity levels ||| set some verbosity levels
Push : (push : PushArg) -> LogL lbl () Push : (push : List PushArg) -> LogL lbl ()
||| restore the previous verbosity levels. ||| restore the previous verbosity levels.
||| returns False if the stack was already empty ||| returns False if the stack was already empty
Pop : LogL lbl Bool Pop : LogL lbl Bool
@ -192,9 +195,13 @@ parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs}
sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg] sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg]
public export %inline public export %inline
pushAt : PushArg -> Eff fs () pushAt : List PushArg -> Eff fs ()
pushAt lvls = send $ Push {lbl} lvls pushAt lvls = send $ Push {lbl} lvls
public export %inline
push1At : PushArg -> Eff fs ()
push1At lvl = pushAt [lvl]
public export %inline public export %inline
popAt : Eff fs Bool popAt : Eff fs Bool
popAt = send $ Pop {lbl} popAt = send $ Pop {lbl}
@ -216,9 +223,13 @@ parameters {auto _ : Has Log fs}
say = sayAt () say = sayAt ()
public export %inline public export %inline
push : PushArg -> Eff fs () push : List PushArg -> Eff fs ()
push = pushAt () push = pushAt ()
public export %inline
push1 : PushArg -> Eff fs ()
push1 = push1At ()
public export %inline public export %inline
pop : Eff fs Bool pop : Eff fs Bool
pop = popAt () pop = popAt ()
@ -235,7 +246,7 @@ handleLogSW : (0 s : ts) -> (0 w : tw) ->
LogL tag a -> Eff fs a LogL tag a -> Eff fs a
handleLogSW s w = \case handleLogSW s w = \case
Push push => modifyAt s $ \lst => Push push => modifyAt s $ \lst =>
applyPush push (fromMaybe defaultLogLevels (head' lst)) :: lst foldl applyPush (fromMaybe defaultLogLevels (head' lst)) push :: lst
Pop => stateAt s $ maybe (False, []) (True,) . tail' Pop => stateAt s $ maybe (False, []) (True,) . tail'
SayMany cat loc msgs => do SayMany cat loc msgs => do
catLvl <- getsAt s $ fst . getLevel cat catLvl <- getsAt s $ fst . getLevel cat