feat: config file: add a real parser, support command-specific options

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 =
+emptyorcommentlinep' cs = do
-  label ("empty line or comment line beginning with "++cs) $ do
+  dp "emptyorcommentlinep'"
-    -- traceparse "emptyorcommentlinep" -- XXX possible to combine label and traceparse ?
+  label ("empty line or comment line beginning with "++cs) $
-    skipNonNewlineSpaces
+    void commentp <|> void (try $ skipNonNewlineSpaces >> newline)
-    void newline <|> void commentp
+  where
-    -- traceparse' "emptyorcommentlinep"
+    commentp = do
-    where
+      choice (map (some.char) cs)
-      commentp = do
+      void $ takeWhileP Nothing (/='\n')
-        choice (map (some.char) cs)
+      void $ optional newline
-        void $ takeWhileP Nothing (/='\n')
-        void $ optional newline
 
 {-# INLINABLE emptyorcommentlinep' #-}
 

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

hledger.conf

@@ -1,14 +1,35 @@
-# hledger.conf
+# hledger.conf - extra options(/arguments) to be added to hledger commands.
-# Extra general options (for now; and possibly 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
+# don't check balance assertions by default (run with -s to check them)
-#--pretty
+--ignore-assertions
 
-# don't check these by default (use -s when ready to check)
+# always infer these
-#--ignore-assertions
+--infer-costs
+--infer-equity
+--infer-market-prices
 
-# infer more stuff by default
+# always show prettier tables in terminal reports
-#--infer-costs
+--pretty
-#--infer-equity
+
-#--infer-market-prices
+
+# 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

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
+    genargsfromconf = confLookup "general" conf
-    cmdargsfromconf = if null cmd then [] else confArgsFor cmd 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 genargsfromconf) $ dbgIO ("extra general args from config file") genargsfromconf
-  unless (null cmdargsfromconf) $ dbgIO ("extra "<>cmd<>" args from config file") cmdargsfromconf
+  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 names of addon commands are provided, those too will be recognised.
--- If it fails, exit the program with usageError.
+-- Also, convert a valueless --debug flag to one with a value.
-parseArgsWithCmdargs :: [String] -> [String] -> Either String RawOpts
+-- If parsing fails, exit the program with an informative error message.
-parseArgsWithCmdargs args addons = CmdArgs.process (mainmode addons) args
+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.

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)"
  ]
 

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 Control.Monad (guard, void)
-import Data.Either (fromRight)
+import Control.Monad.Identity (Identity)
-import Data.List (isPrefixOf)
 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
+  es <- tryJust (guard . isDoesNotExistError) $ readFile f
-  let f' = either (const "") (const f) et
+  case es of
-  let t  = fromRight "" et
+    Left _ -> return nullconf
-  return $ nullconf {
+    Right s ->
-     confFile = f'
+      case parseConf f (T.pack s) of
-    ,confText = t
+        Left err -> error' $ errorBundlePretty err -- customErrorBundlePretty err
-    ,confFormat = 1
+        Right ss -> return nullconf{
-    ,confSections = parseConf t
+           confFile     = f
-    }
+          ,confText     = s
+          ,confFormat   = 1
+          ,confSections = ss
+          }
   ) `catch` \(e :: IOException) -> error' $ show e
 
--- | Parse the content of a hledger config file
+-- config file parsing
--- (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
 
-parseConfSections :: [String] -> [ConfSection]
+parseConf :: FilePath -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) [ConfSection]
-parseConfSections _ = []
+parseConf = runParser confp
 
--- | Fetch all the arguments/options defined in a section with this name, if it exists.
+dp :: String -> TextParser m ()
--- This should be "general" for the unnamed first section, or a hledger command name.
+dp = const $ return ()  -- no-op
-confArgsFor :: SectionName -> Conf -> [Arg]
+-- dp = dbgparse 1  -- trace parse state at this --debug level
-confArgsFor cmd Conf{confSections} =
+
-  fromMaybe [] $ 
+whitespacep, commentlinesp, restoflinep :: TextParser Identity ()
-  M.lookup cmd $ 
+whitespacep   = void $ {- dp "whitespacep"   >> -} many spacenonewline
-  M.fromList [(csName,csArgs) | ConfSection{csName,csArgs} <- confSections]
+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)