From e1991be46fe7d31078123ce2bb65d4f247f77ca3 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 18 Jun 2024 09:39:02 +0100 Subject: [PATCH] feat: config file: add a real parser, support command-specific options --- hledger-lib/Hledger/Read/Common.hs | 24 ++--- hledger-lib/Hledger/Utils/String.hs | 2 +- hledger.conf | 41 ++++++-- hledger/Hledger/Cli.hs | 44 ++++++--- hledger/Hledger/Cli/CliOptions.hs | 3 +- hledger/Hledger/Cli/Conf.hs | 140 +++++++++++++++++++++------- 6 files changed, 184 insertions(+), 70 deletions(-) diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 0b5b04bd5..33796df49 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -1275,21 +1275,23 @@ emptyorcommentlinep = do {-# INLINABLE emptyorcommentlinep #-} +dp :: String -> TextParser m () +dp = const $ return () -- no-op +-- dp = dbgparse 1 -- trace parse state at this --debug level + -- | A new comment line parser (from TimedotReader). -- Parse empty lines, all-blank lines, and lines beginning with any of -- the provided comment-beginning characters. emptyorcommentlinep' :: [Char] -> TextParser m () -emptyorcommentlinep' cs = - label ("empty line or comment line beginning with "++cs) $ do - -- traceparse "emptyorcommentlinep" -- XXX possible to combine label and traceparse ? - skipNonNewlineSpaces - void newline <|> void commentp - -- traceparse' "emptyorcommentlinep" - where - commentp = do - choice (map (some.char) cs) - void $ takeWhileP Nothing (/='\n') - void $ optional newline +emptyorcommentlinep' cs = do + dp "emptyorcommentlinep'" + label ("empty line or comment line beginning with "++cs) $ + void commentp <|> void (try $ skipNonNewlineSpaces >> newline) + where + commentp = do + choice (map (some.char) cs) + void $ takeWhileP Nothing (/='\n') + void $ optional newline {-# INLINABLE emptyorcommentlinep' #-} diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index 601382e68..8030f27ab 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -190,7 +190,7 @@ shellchars = "<>(){}[]$7?#!~`" -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. words' :: String -> [String] words' "" = [] -words' s = map stripquotes $ fromparse $ parsewithString p s +words' s = map stripquotes $ fromparse $ parsewithString p s -- PARTIAL where p = (singleQuotedPattern <|> doubleQuotedPattern <|> patterns) `sepBy` skipNonNewlineSpaces1 -- eof diff --git a/hledger.conf b/hledger.conf index ef8d4cb13..f0e25e835 100644 --- a/hledger.conf +++ b/hledger.conf @@ -1,14 +1,35 @@ -# hledger.conf -# Extra general options (for now; and possibly arguments) to be added to hledger commands. +# hledger.conf - extra options(/arguments) to be added to hledger commands. +# This takes effect if found in the current directory when you run hledger. + +# 1. This first, unnamed section is typically used for general options. +# These affect all commands, or when not supported will be ignored. # To see the general options available, run hledger -h -# show prettier tables in terminal reports by default -#--pretty +# don't check balance assertions by default (run with -s to check them) +--ignore-assertions -# don't check these by default (use -s when ready to check) -#--ignore-assertions +# always infer these +--infer-costs +--infer-equity +--infer-market-prices -# infer more stuff by default -#--infer-costs -#--infer-equity -#--infer-market-prices +# always show prettier tables in terminal reports +--pretty + + +# 2. [named] sections define extra command-specific options. +# Options can be written on the same line or separate lines. +# To see a command's options, run hledger CMD -h + +# help: prefer man pages, bypassing info +[help] --man + +# print: show more info by default +[print] --explicit --show-costs + +# balance: use these defaults +[balance] --tree -p 'monthly from 3 months ago' --depth 3 + +# hledger-ui: reload on change (when started via `hledger ui`). +# A -- is needed before addon-specific flags, as on command line. +[ui] -- --watch diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index 9a75c22a3..52f9b5ba7 100644 --- a/hledger/Hledger/Cli.hs +++ b/hledger/Hledger/Cli.hs @@ -113,6 +113,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Control.Monad.Extra (unless) import Data.List.Extra (nubSort) +import Data.Char (isDigit) -- | The overall cmdargs mode describing hledger's command-line options and subcommands. @@ -211,7 +212,8 @@ main = withGhcDebug' $ do -- If no command was provided, or if the command line contains a bad flag -- or a wrongly present/missing flag argument, cmd will be "". let - cmd = parseArgsWithCmdargs cliargswithcmdfirst addons & either (const "") (stringopt "command") + cmd = cmdargsParse cliargswithcmdfirst addons & stringopt "command" + -- XXX may need a better error message when cmdargs fails to parse (eg spaced/quoted/malformed flag values) badcmdprovided = null cmd && not nocmdprovided isaddoncmd = not (null cmd) && cmd `elem` addons -- isbuiltincmd = cmd `elem` builtinCommandNames @@ -225,21 +227,21 @@ main = withGhcDebug' $ do -- And insert them before the user's args, with adjustments, to get the final args. conf <- getConf let - genargsfromconf = confArgsFor "general" conf - cmdargsfromconf = if null cmd then [] else confArgsFor cmd conf + genargsfromconf = confLookup "general" conf + cmdargsfromconf = if null cmd then [] else confLookup cmd conf argsfromcli = drop 1 cliargswithcmdfirst finalargs = -- (avoid breaking vs code haskell highlighting..) (if null clicmdarg then [] else [clicmdarg]) <> genargsfromconf <> cmdargsfromconf <> argsfromcli & replaceNumericFlags -- convert any -NUM opts from the config file -- finalargs' <- expandArgsAt finalargs -- expand any @ARGFILEs from the config file ? don't bother - unless (null genargsfromconf) $ dbgIO ("extra general args from config file") genargsfromconf - unless (null cmdargsfromconf) $ dbgIO ("extra "<>cmd<>" args from config file") cmdargsfromconf + unless (null genargsfromconf) $ dbgIO ("extra general args from config file") genargsfromconf + unless (null cmdargsfromconf) $ dbgIO ("extra command args from config file") cmdargsfromconf dbgIO "final args" finalargs -- Now parse these in full, first to RawOpts with cmdargs, then to hledger CliOpts. -- At this point a bad flag or flag argument will cause the program to exit with an error. - let rawopts = either usageError id $ parseArgsWithCmdargs finalargs addons + let rawopts = cmdargsParse finalargs addons opts0 <- rawOptsToCliOpts rawopts let opts = opts0{progstarttime_=starttime} @@ -318,7 +320,7 @@ main = withGhcDebug' $ do | otherwise -> usageError $ "could not understand the arguments "++show finalargs <> if null genargsfromconf then "" else "\ngeneral arguments added from config file: "++show genargsfromconf - <> if null cmdargsfromconf then "" else "\ncommand "<>cmd<>" arguments added from config file: "++show cmdargsfromconf + <> if null cmdargsfromconf then "" else "\ncommand arguments added from config file: "++show cmdargsfromconf -- And we're done. -- Give ghc-debug a final chance to take control. @@ -327,7 +329,6 @@ main = withGhcDebug' $ do ------------------------------------------------------------------------------ - -- | A helper for addons/scripts: this parses hledger CliOpts from these -- command line arguments and add-on command names, roughly how hledger main does. -- If option parsing/validating fails, it exits the program with usageError. @@ -336,14 +337,31 @@ main = withGhcDebug' $ do argsToCliOpts :: [String] -> [String] -> IO CliOpts argsToCliOpts args addons = do let args' = args & moveFlagsAfterCommand & replaceNumericFlags - let rawopts = either usageError id $ parseArgsWithCmdargs args' addons + let rawopts = cmdargsParse args' addons rawOptsToCliOpts rawopts -- | Parse these command line arguments/options with cmdargs using mainmode. --- The names of known addon commands are provided so they too can be recognised. --- If it fails, exit the program with usageError. -parseArgsWithCmdargs :: [String] -> [String] -> Either String RawOpts -parseArgsWithCmdargs args addons = CmdArgs.process (mainmode addons) args +-- If names of addon commands are provided, those too will be recognised. +-- Also, convert a valueless --debug flag to one with a value. +-- If parsing fails, exit the program with an informative error message. +cmdargsParse :: [String] -> [String] -> RawOpts +cmdargsParse args0 addons = + CmdArgs.process (mainmode addons) args & either + (\err -> error' $ unlines [ + "cmdargs: " <> err + ,"while processing arguments:" + ,show args + ]) + id + where args = ensureDebugHasVal args0 + +-- Convert a valueless --debug flag to one with a value. +-- See also the --debug flag definition in CliOptions.hs. +-- This makes an equals sign unnecessary with this optional-value flag. +ensureDebugHasVal as = case break (=="--debug") as of + (bs,"--debug":c:cs) | null c || not (all isDigit c) -> bs++"--debug=1":c:cs + (bs,["--debug"]) -> bs++["--debug=1"] + _ -> as -- | cmdargs does not allow flags (options) to appear before the subcommand name. -- We prefer to hide this restriction from the user, making the CLI more forgiving. diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 807b6a6fc..5dc7d9d78 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -234,9 +234,10 @@ reportflags = [ ,flagOpt "yes" ["pretty"] (\s opts -> Right $ setopt "pretty" s opts) "YN" "Use box-drawing characters in text output? Can be\n'y'/'yes' or 'n'/'no'.\nIf YN is specified, the equals is required." + -- ,flagOpt "1" ["debug"] (\s opts -> Right $ setopt "debug" s opts) "LVL" "show debug output (levels 1-9, default: 1)" -- flagOpt would be more correct for --debug, showing --debug[=LVL] rather than --debug=[LVL]. -- But because we handle --debug specially, flagReq also works, and it does not need =, removing a source of confusion. - -- ,flagOpt "1" ["debug"] (\s opts -> Right $ setopt "debug" s opts) "LVL" "show debug output (levels 1-9, default: 1)" + -- (This involves specially adding the flag value if missing in Cli.hs.) ,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "[1-9]" "show this level of debug output (default: 1)" ] diff --git a/hledger/Hledger/Cli/Conf.hs b/hledger/Hledger/Cli/Conf.hs index b10a6505c..f4752cb50 100644 --- a/hledger/Hledger/Cli/Conf.hs +++ b/hledger/Hledger/Cli/Conf.hs @@ -1,6 +1,5 @@ {-| Read extra CLI arguments from a hledger config file. -Currently this reads only general options from ./hledger.conf if it exists. -} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,19 +7,23 @@ Currently this reads only general options from ./hledger.conf if it exists. module Hledger.Cli.Conf ( getConf - ,confArgsFor + ,confLookup ) where import Control.Exception (IOException, catch, tryJust) -import Control.Monad (guard) -import Data.Either (fromRight) -import Data.List (isPrefixOf) +import Control.Monad (guard, void) +import Control.Monad.Identity (Identity) import qualified Data.Map as M -import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T (pack) import System.IO.Error (isDoesNotExistError) +import Text.Megaparsec -- hiding (parse) +import Text.Megaparsec.Char -import Hledger (error', strip) +import Hledger (error', strip, words') +import Hledger.Read.Common +import Hledger.Utils.Parse localConfPath = "hledger.conf" @@ -39,7 +42,12 @@ data ConfSection = ConfSection { ,csArgs :: [Arg] } deriving (Eq,Show) +-- | The name of a config file section, with surrounding brackets and whitespace removed. type SectionName = String + +-- | A command line argument to be passed to CmdArgs.process. +-- It seems this should be a single command line argument (or flag or flag value). +-- If it contains spaces, those are treated as part of a single argument, as with CMD a "b c". type Arg = String nullconf = Conf { @@ -49,40 +57,104 @@ nullconf = Conf { ,confSections = [] } +-- config reading + +-- | Fetch all the arguments/options defined in a section with this name, if it exists. +-- This should be "general" for the unnamed first section, or a hledger command name. +confLookup :: SectionName -> Conf -> [Arg] +confLookup cmd Conf{confSections} = + maybe [] (concatMap words') $ -- XXX PARTIAL + M.lookup cmd $ + M.fromList [(csName,csArgs) | ConfSection{csName,csArgs} <- confSections] + -- | Try to read a hledger config file. -- If none is found, this returns a null Conf. -- Any other IO error will cause an exit. getConf :: IO Conf getConf = (do let f = localConfPath - et <- tryJust (guard . isDoesNotExistError) $ readFile f - let f' = either (const "") (const f) et - let t = fromRight "" et - return $ nullconf { - confFile = f' - ,confText = t - ,confFormat = 1 - ,confSections = parseConf t - } + es <- tryJust (guard . isDoesNotExistError) $ readFile f + case es of + Left _ -> return nullconf + Right s -> + case parseConf f (T.pack s) of + Left err -> error' $ errorBundlePretty err -- customErrorBundlePretty err + Right ss -> return nullconf{ + confFile = f + ,confText = s + ,confFormat = 1 + ,confSections = ss + } ) `catch` \(e :: IOException) -> error' $ show e --- | Parse the content of a hledger config file --- (a limited prototype, only reads general options until the first [sectionheading]). -parseConf :: String -> [ConfSection] -parseConf s = - let - conflines = filter (\l -> not $ null l || "#" `isPrefixOf` l) $ map strip $ lines s - (ls1,rest) = break (("[" `isPrefixOf`)) conflines -- XXX also breaks on lines like " [..." - in - ConfSection "general" ls1 : parseConfSections rest +-- config file parsing -parseConfSections :: [String] -> [ConfSection] -parseConfSections _ = [] +parseConf :: FilePath -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) [ConfSection] +parseConf = runParser confp --- | Fetch all the arguments/options defined in a section with this name, if it exists. --- This should be "general" for the unnamed first section, or a hledger command name. -confArgsFor :: SectionName -> Conf -> [Arg] -confArgsFor cmd Conf{confSections} = - fromMaybe [] $ - M.lookup cmd $ - M.fromList [(csName,csArgs) | ConfSection{csName,csArgs} <- confSections] +dp :: String -> TextParser m () +dp = const $ return () -- no-op +-- dp = dbgparse 1 -- trace parse state at this --debug level + +whitespacep, commentlinesp, restoflinep :: TextParser Identity () +whitespacep = void $ {- dp "whitespacep" >> -} many spacenonewline +commentlinesp = void $ {- dp "commentlinesp" >> -} many (emptyorcommentlinep' "#") +restoflinep = void $ {- dp "restoflinep" >> -} whitespacep >> emptyorcommentlinep' "#" + +confp :: TextParser Identity [ConfSection] -- a monadic TextParser to allow reusing other hledger parsers +confp = do + dp "confp" + commentlinesp + genas <- many arglinep + let s = ConfSection "general" genas + ss <- many $ do + (n, ma) <- sectionstartp + as <- many arglinep + return $ ConfSection n (maybe as (:as) ma) + eof + return $ s:ss + +-- parse a section name and possibly arguments written on the same line +sectionstartp :: TextParser Identity (String, Maybe String) +sectionstartp = do + dp "sectionstartp" + char '[' + n <- fmap strip $ some $ noneOf "]#\n" + char ']' + -- dp "sectionstartp2" + whitespacep + -- dp "sectionstartp3" + ma <- fmap (fmap strip) $ optional $ some $ noneOf "#\n" + -- dp "sectionstartp4" + restoflinep + -- dp "sectionstartp5" + commentlinesp + -- dp "sectionstartp6" + return (n, ma) + +arglinep :: TextParser Identity String +arglinep = do + dp "arglinep" + notFollowedBy $ char '[' + -- dp "arglinep2" + whitespacep + -- dp "arglinep3" + a <- some $ noneOf "#\n" + -- dp "arglinep4" + restoflinep + commentlinesp + return $ strip a + + +-- initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts +-- -> FilePath -> Text -> ExceptT String IO Journal +-- initialiseAndParseJournal parser iopts f txt = +-- prettyParseErrors $ runParserT (evalStateT parser initJournal) f txt +-- where +-- y = first3 . toGregorian $ _ioDay iopts +-- initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]} +-- -- Flatten parse errors and final parse errors, and output each as a pretty String. +-- prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text HledgerParseErrorData) a) +-- -> ExceptT String IO a +-- prettyParseErrors = withExceptT customErrorBundlePretty . liftEither +-- <=< withExceptT (finalErrorBundlePretty . attachSource f txt)