quox/lib/Quox/Log.idr

305 lines
8.2 KiB
Idris
Raw Normal View History

2024-04-04 12:11:26 -04:00
module Quox.Log
import Quox.Loc
import Quox.Pretty
import Data.So
import Data.DPair
import Data.Maybe
import Data.List1
import Control.Eff
import Control.Monad.ST.Extra
import Data.IORef
import System.File
import Derive.Prelude
%default total
%language ElabReflection
2024-04-04 19:57:18 -04:00
public export %inline
2024-04-04 12:11:26 -04:00
maxLogLevel : Nat
maxLogLevel = 100
2024-04-04 19:57:18 -04:00
public export %inline
2024-04-04 12:11:26 -04:00
logCategories : List String
logCategories = ["whnf", "equal", "check"]
public export %inline
isLogLevel : Nat -> Bool
isLogLevel l = l <= maxLogLevel
public export
IsLogLevel : Nat -> Type
IsLogLevel l = So $ isLogLevel l
public export %inline
isLogCategory : String -> Bool
isLogCategory cat = cat `elem` logCategories
public export
IsLogCategory : String -> Type
IsLogCategory cat = So $ isLogCategory cat
2024-04-04 19:57:18 -04:00
-- Q: why are you using `So` instead of `LT` and `Elem`
-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100``
-- (i.e. `LTESucc⁹⁹ LTEZero`)
-- ② the proofs aren't looked at in any way, i just wanted to make sure the
-- list of categories was consistent everywhere
2024-04-04 12:11:26 -04:00
2024-04-04 19:57:18 -04:00
||| a verbosity level from 0100. higher is noisier. each log entry has a
||| verbosity level above which it will be printed, chosen, uh, based on vibes.
2024-04-04 12:11:26 -04:00
public export
LogLevel : Type
LogLevel = Subset Nat IsLogLevel
2024-04-04 19:57:18 -04:00
||| a logging category, like "check" (type checking), "whnf", or whatever.
2024-04-04 12:11:26 -04:00
public export
LogCategory : Type
LogCategory = Subset String IsLogCategory
public export %inline
toLogLevel : Nat -> Maybe LogLevel
toLogLevel l =
case choose $ isLogLevel l of
Left y => Just $ Element l y
Right _ => Nothing
public export %inline
toLogCategory : String -> Maybe LogCategory
toLogCategory c =
case choose $ isLogCategory c of
Left y => Just $ Element c y
Right _ => Nothing
2024-04-04 19:57:18 -04:00
||| verbosity levels for each category, if they differ from the default
2024-04-04 12:11:26 -04:00
public export
LevelMap : Type
LevelMap = List (LogCategory, LogLevel)
2024-04-04 19:57:18 -04:00
-- Q: why `List` instead of `SortedMap`
-- A: oof ouch my constant factors (maybe this one was more obvious)
2024-04-04 12:11:26 -04:00
public export
record LogLevels where
constructor MkLogLevels
defLevel : LogLevel
levels : LevelMap
%name LogLevels lvls
%runElab derive "LogLevels" [Eq, Show]
public export
LevelStack : Type
2024-04-04 19:57:18 -04:00
LevelStack = List LogLevels
public export %inline
defaultLevel : LogLevel
defaultLevel = Element 0 Oh
2024-04-04 12:11:26 -04:00
export %inline
defaultLogLevels : LogLevels
2024-04-04 19:57:18 -04:00
defaultLogLevels = MkLogLevels defaultLevel []
2024-04-04 12:11:26 -04:00
export %inline
initStack : LevelStack
2024-04-04 19:57:18 -04:00
initStack = []
2024-04-04 12:11:26 -04:00
2024-04-04 19:57:18 -04:00
export %inline
getLevel1 : LogCategory -> LogLevels -> LogLevel
getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls
export %inline
getLevel : LogCategory -> LevelStack -> LogLevel
getLevel cat (lvls :: _) = getLevel1 cat lvls
getLevel cat [] = defaultLevel
2024-04-04 12:11:26 -04:00
export %inline
2024-04-04 19:57:18 -04:00
getCurLevels : LevelStack -> LogLevels
getCurLevels (lvls :: _) = lvls
getCurLevels [] = defaultLogLevels
2024-04-04 12:11:26 -04:00
public export
LogDoc : Type
LogDoc = Doc (Opts {lineLength = 80})
2024-04-04 19:57:18 -04:00
private %inline
replace : Eq a => a -> b -> List (a, b) -> List (a, b)
replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs
private %inline
mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b)
mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l
2024-04-04 12:11:26 -04:00
public export
2024-04-04 19:57:18 -04:00
data PushArg = SetDefault LogLevel | SetCats LevelMap | SetAll LogLevel
2024-04-04 12:11:26 -04:00
%name PushArg push
export %inline
2024-04-04 19:57:18 -04:00
applyPush : PushArg -> LogLevels -> LogLevels
applyPush (SetDefault def) = {defLevel := def}
applyPush (SetCats map) = {levels $= mergeLeft map}
applyPush (SetAll lvl) = const $ MkLogLevels lvl []
export %inline
fromPush : PushArg -> LogLevels
fromPush p = applyPush p defaultLogLevels
2024-04-04 12:11:26 -04:00
public export
record LogMsg where
constructor (:>)
level : Nat
{auto 0 levelOk : IsLogLevel level}
message : Lazy LogDoc
infix 0 :>
%name Log.LogMsg msg
public export
data LogL : (lbl : tag) -> Type -> Type where
2024-04-04 19:57:18 -04:00
||| print some log messages
SayMany : (cat : LogCategory) -> (loc : Loc) ->
(msgs : List LogMsg) -> LogL lbl ()
||| set some verbosity levels
Push : (push : PushArg) -> LogL lbl ()
||| restore the previous verbosity levels.
||| returns False if the stack was already empty
Pop : LogL lbl Bool
||| returns the current verbosity levels
2024-04-04 12:11:26 -04:00
CurLevels : LogL lbl LogLevels
public export
Log : Type -> Type
Log = LogL ()
parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs}
public export %inline
sayManyAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
Loc -> List LogMsg -> Eff fs ()
sayManyAt cat loc msgs {catOk} =
send $ SayMany {lbl} (Element cat catOk) loc msgs
public export %inline
sayAt : (cat : String) -> (0 catOk : IsLogCategory cat) =>
(lvl : Nat) -> (0 lvlOk : IsLogLevel lvl) =>
Loc -> Lazy LogDoc -> Eff fs ()
sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg]
public export %inline
pushAt : PushArg -> Eff fs ()
pushAt lvls = send $ Push {lbl} lvls
public export %inline
2024-04-04 19:57:18 -04:00
popAt : Eff fs Bool
2024-04-04 12:11:26 -04:00
popAt = send $ Pop {lbl}
public export %inline
curLevelsAt : Eff fs LogLevels
curLevelsAt = send $ CurLevels {lbl}
parameters {auto _ : Has Log fs}
public export %inline
sayMany : (cat : String) -> (0 catOk : IsLogCategory cat) =>
Loc -> List LogMsg -> Eff fs ()
sayMany = sayManyAt ()
public export %inline
say : (cat : String) -> (0 _ : IsLogCategory cat) =>
(lvl : Nat) -> (0 _ : IsLogLevel lvl) =>
Loc -> Lazy LogDoc -> Eff fs ()
say = sayAt ()
public export %inline
push : PushArg -> Eff fs ()
push = pushAt ()
public export %inline
2024-04-04 19:57:18 -04:00
pop : Eff fs Bool
2024-04-04 12:11:26 -04:00
pop = popAt ()
public export %inline
curLevels : Eff fs LogLevels
curLevels = curLevelsAt ()
2024-04-04 19:57:18 -04:00
||| handles a `Log` effect with an existing `State` and `Writer`
2024-04-04 12:11:26 -04:00
export %inline
2024-04-04 19:57:18 -04:00
handleLogSW : (0 s : ts) -> (0 w : tw) ->
Has (StateL s LevelStack) fs => Has (WriterL w LogDoc) fs =>
LogL tag a -> Eff fs a
handleLogSW s w = \case
Push push => modifyAt s $ \lst =>
applyPush push (fromMaybe defaultLogLevels (head' lst)) :: lst
Pop => stateAt s $ maybe (False, []) (True,) . tail'
SayMany cat loc msgs => do
catLvl <- getsAt s $ fst . getLevel cat
let loc = runPretty $ prettyLoc loc
for_ msgs $ \(lvl :> msg) => when (lvl <= catLvl) $ tellAt w $
hcat [loc, text cat.fst, "@", pshow lvl, ":"] <++> msg
CurLevels =>
getsAt s getCurLevels
2024-04-04 12:11:26 -04:00
export %inline
2024-04-04 19:57:18 -04:00
handleLogSW_ : LogL tag a -> Eff [State LevelStack, Writer LogDoc] a
handleLogSW_ = handleLogSW () ()
2024-04-04 12:11:26 -04:00
export %inline
2024-04-04 19:57:18 -04:00
handleLogIO : HasIO m => MonadRec m =>
(FileError -> m ()) -> IORef LevelStack -> File ->
LogL tag a -> m a
handleLogIO th lvls h act =
runEff (handleLogSW_ act) [handleStateIORef lvls, handleWriter {m} printMsg]
2024-04-04 12:11:26 -04:00
where printMsg : LogDoc -> m ()
printMsg msg = fPutStr h (render _ msg) >>= either th pure
export %inline
2024-04-04 19:57:18 -04:00
handleLogST : HasST m => MonadRec (m s) =>
2024-04-04 12:11:26 -04:00
STRef s (SnocList LogDoc) -> STRef s LevelStack ->
LogL tag a -> m s a
2024-04-04 19:57:18 -04:00
handleLogST docs lvls act =
runEff (handleLogSW_ act) [handleStateSTRef lvls, handleWriterSTRef docs]
2024-04-04 12:11:26 -04:00
export %inline
2024-04-04 19:57:18 -04:00
handleLogDiscard : (0 s : ts) -> Has (StateL s Nat) fs =>
LogL tag a -> Eff fs a
handleLogDiscard s = \case
Push _ => modifyAt s S
Pop => stateAt s $ \k => (k > 0, pred k)
2024-04-04 12:11:26 -04:00
SayMany {} => pure ()
CurLevels => pure defaultLogLevels
2024-04-04 19:57:18 -04:00
export %inline
handleLogDiscard_ : LogL tag a -> Eff [State Nat] a
handleLogDiscard_ = handleLogDiscard ()
export %inline
handleLogDiscardST : HasST m => MonadRec (m s) => STRef s Nat ->
LogL tag a -> m s a
handleLogDiscardST ref act =
runEff (handleLogDiscard_ act) [handleStateSTRef ref]
export %inline
handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat ->
LogL tag a -> m a
handleLogDiscardIO ref act =
runEff (handleLogDiscard_ act) [handleStateIORef ref]
||| approximate the push/pop effects in a discarded log by trimming a stack or
||| repeating its most recent element
export %inline
fixupDiscardedLog : Nat -> LevelStack -> LevelStack
fixupDiscardedLog want lvls =
let len = length lvls in
case compare len want of
EQ => lvls
GT => drop (len `minus` want) lvls
LT => let new = fromMaybe defaultLogLevels $ head' lvls in
replicate (want `minus` len) new ++ lvls