add Q.Log

lib/Control/Monad/ST/Extra.idr

@@ -62,3 +62,21 @@ export %inline HasST (STErr e) where liftST = STE . map Right
 export
 stLeft : e -> STErr e s a
 stLeft e = STE $ pure $ Left e
+
+
+parameters {auto _ : HasST m}
+  export %inline
+  newSTRef' : a -> m s (STRef s a)
+  newSTRef' x = liftST $ newSTRef x
+
+  export %inline
+  readSTRef' : STRef s a -> m s a
+  readSTRef' r = liftST $ readSTRef r
+
+  export %inline
+  writeSTRef' : STRef s a -> a -> m s ()
+  writeSTRef' r x = liftST $ writeSTRef r x
+
+  export %inline
+  modifySTRef' : STRef s a -> (a -> a) -> m s ()
+  modifySTRef' r f = liftST $ modifySTRef r f

lib/Quox/EffExtra.idr

@@ -97,6 +97,10 @@ export
 handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a
 handleReaderConst x Ask = pure x
 
+export
+handleWriterST : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a
+handleWriterST ref (Tell w) = liftST $ modifySTRef ref (:< w)
+
 
 public export
 record IOErr e a where

lib/Quox/Log.idr

@@ -0,0 +1,240 @@
+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
+
+
+public export
+maxLogLevel : Nat
+maxLogLevel = 100
+
+public export
+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
+
+
+public export
+LogLevel : Type
+LogLevel = Subset Nat IsLogLevel
+
+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
+
+
+public export
+LevelMap : Type
+LevelMap = List (LogCategory, LogLevel)
+-- i tried SortedMap first, but it is too much overhead for LevelMaps
+
+public export
+record LogLevels where
+  constructor MkLogLevels
+  defLevel : LogLevel
+  levels   : LevelMap
+%name LogLevels lvls
+%runElab derive "LogLevels" [Eq, Show]
+
+public export
+LevelStack : Type
+LevelStack = List1 LogLevels
+
+export %inline
+defaultLogLevels : LogLevels
+defaultLogLevels = MkLogLevels (Element 0 Oh) []
+
+export %inline
+initStack : LevelStack
+initStack = singleton defaultLogLevels
+
+||| right biased for the default and for overlapping elements
+public export %inline
+mergeLevels : LogLevels -> LogLevels -> LogLevels
+mergeLevels (MkLogLevels _ map1) (MkLogLevels def map2) =
+  MkLogLevels def $ map1 ++ map2
+
+export %inline
+getLevel : LogCategory -> LogLevels -> LogLevel
+getLevel cat lvls = fromMaybe lvls.defLevel $ lookup cat lvls.levels
+
+
+public export
+LogDoc : Type
+LogDoc = Doc (Opts {lineLength = 80})
+
+
+public export
+data PushArg = SetDefault LogLevel | SetCats LevelMap
+%name PushArg push
+
+export %inline
+mergePush : PushArg -> LogLevels -> LogLevels
+mergePush (SetDefault def) = {defLevel := def}
+mergePush (SetCats    map) = {levels   $= (map ++)}
+
+
+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
+  SayMany   : (cat : LogCategory) -> (loc : Loc) ->
+              (msgs : List LogMsg) -> LogL lbl ()
+  Push      : (push : PushArg) -> LogL lbl ()
+  Pop       : LogL lbl ()
+  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
+  popAt : Eff fs ()
+  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
+  pop : Eff fs ()
+  pop = popAt ()
+
+  public export %inline
+  curLevels : Eff fs LogLevels
+  curLevels = curLevelsAt ()
+
+
+export %inline
+doPush : PushArg -> LevelStack -> LevelStack
+doPush push list = mergePush push (head list) `cons` list
+
+export %inline
+doPop : List1 a -> List1 a
+doPop (_ ::: x :: xs) = x ::: xs
+doPop (x ::: [])      = x ::: []
+
+export %inline
+doSayMany : Applicative m =>
+            LevelStack -> (LogDoc -> m ()) ->
+            LogCategory -> Loc -> List LogMsg -> m ()
+doSayMany (lvls ::: _) act cat loc msgs = do
+  let Element catLvl _ = getLevel cat lvls
+      loc              = runPretty $ prettyLoc loc
+  for_ msgs $ \msg => when (msg.level <= catLvl) $
+    act $ hcat [loc, text cat.fst, "@", pshow msg.level, ":"] <++>
+          msg.message
+
+export %inline
+handleLogIO : HasIO m => (FileError -> m ()) ->
+              IORef LevelStack -> File -> LogL tag a -> m a
+handleLogIO th lvls h = \case
+  Push push            => modifyIORef lvls $ doPush push
+  Pop                  => modifyIORef lvls doPop
+  SayMany cat loc msgs => doSayMany !(readIORef lvls) printMsg cat loc msgs
+  CurLevels            => head <$> readIORef lvls
+where printMsg : LogDoc -> m ()
+      printMsg msg = fPutStr h (render _ msg) >>= either th pure
+
+export %inline
+handleLogST : (HasST m, Monad (m s)) =>
+              STRef s (SnocList LogDoc) -> STRef s LevelStack ->
+              LogL tag a -> m s a
+handleLogST docs lvls = \case
+  Push push            => modifySTRef' lvls $ doPush push
+  Pop                  => modifySTRef' lvls doPop
+  SayMany cat loc msgs => doSayMany !(readSTRef' lvls) printMsg cat loc msgs
+  CurLevels            => head <$> readSTRef' lvls
+where printMsg : LogDoc -> m s ()
+      printMsg msg = modifySTRef' docs (:< msg)
+
+export %inline
+handleLogDiscard : Applicative m => LogL tag a -> m a
+handleLogDiscard = \case
+  SayMany {} => pure ()
+  Push    {} => pure ()
+  Pop        => pure ()
+  CurLevels  => pure defaultLogLevels

lib/quox-lib.ipkg

@@ -19,6 +19,7 @@ modules =
   Quox.PrettyValExtra,
   Quox.Decidable,
   Quox.No,
+  Quox.Log,
   Quox.Loc,
   Quox.Var,
   Quox.Scoped,