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,16 +54,36 @@ 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
+  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]
 

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
@@ -51,6 +52,8 @@ record Options where
   hlType    : HLType
   flavor    : Pretty.Flavor
   width     : Nat
+  logLevels : LogLevels
+  logFile   : OutFile
 %name Options opts
 %runElab derive "Options" [Show]
 
@@ -69,7 +72,9 @@ defaultOpts = pure $ MkOpts {
   until     = Nothing,
   hlType    = Guess,
   flavor    = Unicode,
-  width   = !defaultWidth
+  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