From e6ad16813ec07d3b377248fd03a9de56c67f8f2c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 18:13:45 +0200 Subject: [PATCH] add log effects to executable --- exe/CompileMonad.idr | 35 ++++++++++++++++---- exe/Main.idr | 1 + exe/Options.idr | 79 +++++++++++++++++++++++++++++++++++--------- 3 files changed, 93 insertions(+), 22 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index 80fa2d3..4ec2a76 100644 --- a/exe/CompileMonad.idr +++ b/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 diff --git a/exe/Main.idr b/exe/Main.idr index 192ce42..e23184b 100644 --- a/exe/Main.idr +++ b/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 diff --git a/exe/Options.idr b/exe/Options.idr index b92b668..f1788df 100644 --- a/exe/Options.idr +++ b/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}) "") "output file (\"-\" for stdout, \"\" for no output)", MkOpt ['P'] ["phase"] (ReqArg toPhase "") - "stop after the given phase" + "stop after the given phase", + MkOpt ['l'] ["log"] (ReqArg logFlag "[=]:...") + "set log level", + MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "") + "set log output file" ] private