add log effects to executable

exe/CompileMonad.idr

@@ -7,6 +7,7 @@ import Quox.Parser
 import Quox.Untyped.Erase
 import Quox.Untyped.Scheme
 import Quox.Pretty
+import Quox.Log
 import Options
 import Output
 import Error
@@ -53,18 +54,38 @@ public export
 Compile : List (Type -> Type)
 Compile =
   [Except Error,
-   ReaderL STATE State, ReaderL OPTS Options,
+   ReaderL STATE State, ReaderL OPTS Options, Log,
    LoadFile, IO]
 
+export %inline
+handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a
+handleLog lvls f l = case f of
+  OConsole ch => handleLogIO (const $ pure ()) lvls (consoleHandle ch) l
+  OFile _ h   => handleLogIO (const $ pure ()) lvls h l
+  ONone       => handleLogDiscard l
+
+private %inline
+withLogFile : Options ->
+              (IORef LevelStack -> OpenFile -> IO (Either Error a)) ->
+              IO (Either Error a)
+withLogFile opts act = do
+  lvlStack <- newIORef $ singleton opts.logLevels
+  withOutFile CErr opts.logFile fromError $ act lvlStack
+where
+  fromError : String -> FileError -> IO (Either Error a)
+  fromError file err = pure $ Left $ WriteError file err
+
 export covering %inline
 runCompile : Options -> State -> Eff Compile a -> IO (Either Error a)
 runCompile opts state act = do
-  fromIOErr $ runEff act $ with Union.(::)
-    [handleExcept (\e => ioLeft e),
-     handleReaderConst state,
-     handleReaderConst opts,
-     handleLoadFileIOE loadError ParseError state.seen opts.include,
-     liftIO]
+  withLogFile opts $ \lvls, logFile =>
+    fromIOErr $ runEff act $ with Union.(::)
+      [handleExcept (\e => ioLeft e),
+       handleReaderConst state,
+       handleReaderConst opts,
+       handleLog lvls logFile,
+       handleLoadFileIOE loadError ParseError state.seen opts.include,
+       liftIO]
 
 private %inline
 rethrowFileC : String -> Either FileError a -> Eff Compile a

exe/Main.idr

@@ -7,6 +7,7 @@ import Quox.Parser
 import Quox.Untyped.Erase
 import Quox.Untyped.Scheme
 import Quox.Pretty
+import Quox.Log
 import Options
 import Output
 import Error

exe/Options.idr

@@ -1,6 +1,7 @@
 module Options
 
 import Quox.Pretty
+import Quox.Log
 import Data.DPair
 import Data.SortedMap
 import System
@@ -44,13 +45,15 @@ record Dump where
 public export
 record Options where
   constructor MkOpts
-  include : List String
-  dump    : Dump
-  outFile : OutFile
-  until   : Maybe Phase
-  hlType  : HLType
-  flavor  : Pretty.Flavor
-  width   : Nat
+  include   : List String
+  dump      : Dump
+  outFile   : OutFile
+  until     : Maybe Phase
+  hlType    : HLType
+  flavor    : Pretty.Flavor
+  width     : Nat
+  logLevels : LogLevels
+  logFile   : OutFile
 %name Options opts
 %runElab derive "Options" [Show]
 
@@ -63,13 +66,15 @@ defaultWidth = do
 export
 defaultOpts : IO Options
 defaultOpts = pure $ MkOpts {
-  include = ["."],
-  dump    = MkDump NoOut NoOut NoOut NoOut,
-  outFile = Console,
-  until   = Nothing,
-  hlType  = Guess,
-  flavor  = Unicode,
-  width   = !defaultWidth
+  include   = ["."],
+  dump      = MkDump NoOut NoOut NoOut NoOut,
+  outFile   = Console,
+  until     = Nothing,
+  hlType    = Guess,
+  flavor    = Unicode,
+  width     = !defaultWidth,
+  logLevels = defaultLogLevels,
+  logFile   = Console
 }
 
 private
@@ -127,6 +132,46 @@ dirListFlag : String -> List String -> List String
 dirListFlag ""   val = []
 dirListFlag dirs val = val ++ toList (split (== ':') dirs)
 
+private
+splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel))
+splitLogFlag = traverse flag1 . toList . split (== ':') where
+  parseLogCategory : String -> Either String LogCategory
+  parseLogCategory cat = do
+    let Just cat = toLogCategory cat
+      | _ => let catList = joinBy ", " logCategories in
+             Left "unknown log category. categories are:\n\{catList}"
+    pure cat
+
+  parseLogLevel : String -> Either String LogLevel
+  parseLogLevel lvl = do
+    let Just lvl = parsePositive lvl
+      | _ => Left "log level \{lvl} not a number"
+    let Just lvl = toLogLevel lvl
+      | _ => Left "log level \{show lvl} out of range 0–\{show maxLogLevel}"
+    pure lvl
+
+  flag1 : String -> Either String (Maybe LogCategory, LogLevel)
+  flag1 str = do
+    let (first, second) = break (== '=') str
+    case strM second of
+      StrCons '=' lvl => do
+        cat <- parseLogCategory first
+        lvl <- parseLogLevel lvl
+        pure (Just cat, lvl)
+      StrNil => (Nothing,) <$> parseLogLevel first
+      _      => Left "invalid log flag \{str}"
+
+private
+setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels
+setLogFlag lvls (Nothing,   lvl) = {defLevel := lvl} lvls
+setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls
+
+private
+logFlag : String -> OptAction
+logFlag str = case splitLogFlag str of
+  Left  err   => Err err
+  Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o
+
 private
 commonOptDescrs' : List (OptDescr OptAction)
 commonOptDescrs' = [
@@ -136,7 +181,11 @@ commonOptDescrs' = [
   MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "<file>")
     "output file (\"-\" for stdout, \"\" for no output)",
   MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
-    "stop after the given phase"
+    "stop after the given phase",
+  MkOpt ['l'] ["log"] (ReqArg logFlag "[<cat>=]<n>:...")
+    "set log level",
+  MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "<file>")
+    "set log output file"
 ]
 
 private