diff --git a/hledger-lib/Hledger/Data/RawOptions.hs b/hledger-lib/Hledger/Data/RawOptions.hs index 0c5a55086..0a6438438 100644 --- a/hledger-lib/Hledger/Data/RawOptions.hs +++ b/hledger-lib/Hledger/Data/RawOptions.hs @@ -11,6 +11,7 @@ module Hledger.Data.RawOptions ( RawOpts, setopt, setboolopt, + appendopts, inRawOpts, boolopt, choiceopt, @@ -22,7 +23,8 @@ module Hledger.Data.RawOptions ( posintopt, maybeintopt, maybeposintopt, - maybecharopt + maybecharopt, + overRawOpts ) where @@ -47,6 +49,9 @@ setopt name val = overRawOpts (++ [(name, val)]) setboolopt :: String -> RawOpts -> RawOpts setboolopt name = overRawOpts (++ [(name,"")]) +appendopts :: [(String,String)] -> RawOpts -> RawOpts +appendopts new = overRawOpts $ \old -> concat [old,new] + -- | Is the named option present ? inRawOpts :: String -> RawOpts -> Bool inRawOpts name = isJust . lookup name . unRawOpts diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index dd0e52de3..5dde22496 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -245,7 +245,10 @@ reportOptsToSpec day ropts = do , rsQueryOpts = queryopts } --- | Regenerate a ReportSpec after updating ReportOpts. +-- | Regenerate a ReportSpec after updating ReportOpts, or return an error +-- message if there is a problem such as missing or unparseable options data. +-- This helps keep the ReportSpec, its underlying ReportOpts, and the ReportOpts' +-- data fields like querystring_ all in sync. updateReportSpecFromOpts :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec updateReportSpecFromOpts f rspec = reportOptsToSpec (rsToday rspec) . f $ rsOpts rspec diff --git a/hledger/Hledger/Cli/Commands/Check.hs b/hledger/Hledger/Cli/Commands/Check.hs index abb824355..253bc7fd0 100644 --- a/hledger/Hledger/Cli/Commands/Check.hs +++ b/hledger/Hledger/Cli/Commands/Check.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -26,18 +28,14 @@ checkmode = hledgerCommandMode ([], Just $ argsFlag "[CHECKS]") check :: CliOpts -> Journal -> IO () -check copts@CliOpts{..} j = do +check copts@CliOpts{rawopts_} j = do let args = listofstringopt "args" rawopts_ - -- we must reset the report spec generated by argsToCliOpts - -- since we are not using arguments as a query in the usual way, - copts' = - case updateReportSpecFromOpts update reportspec_ of - Left e -> error' e - Right rs -> copts{reportspec_=rs} - where update ropts = ropts{querystring_=[]} + -- reset the report spec that was generated by argsToCliOpts, + -- since we are not using arguments as a query in the usual way + copts' = cliOptsUpdateReportSpec (\ropts -> ropts{querystring_=[]}) copts - case partitionEithers (map parseCheck args) of + case partitionEithers (map parseCheckArgument args) of (unknowns@(_:_), _) -> error' $ "These checks are unknown: "++unwords unknowns ([], checks) -> forM_ checks $ runCheck copts' j @@ -47,6 +45,15 @@ data Check = | Leafnames deriving (Read,Show,Eq) +-- | Parse a check argument: a string which is the lower-case name of an error check, +-- followed by zero or more space-separated arguments for that check. +parseCheckArgument :: String -> Either String (Check,[String]) +parseCheckArgument s = + dbg3 "check argument" $ + ((,checkargs)) <$> parseCheck checkname + where + (checkname:checkargs) = words' s + -- | Parse the lower-case name of an error check, or return the name unparsed. parseCheck :: String -> Either String Check parseCheck s = maybe (Left s) Right $ readMay $ capitalise s @@ -55,13 +62,26 @@ capitalise :: String -> String capitalise (c:cs) = toUpper c : cs capitalise s = s --- | Parse a check argument: a string which is the lower-case name of an error check, --- followed by zero or more space-separated arguments for that check. --- parseCheckArgument :: String -> Either String (Check,[String]) - -runCheck :: CliOpts -> Journal -> Check -> IO () -runCheck copts j = - \case - Dates -> checkdates copts j - Leafnames -> checkdupes copts j +-- | Run the named error check, possibly with some arguments, +-- on this journal with these options. +runCheck :: CliOpts -> Journal -> (Check,[String]) -> IO () +runCheck copts@CliOpts{rawopts_} j (check,args) = + case check of + Dates -> checkdates copts' j + Leafnames -> checkdupes copts' j + where + -- Hack: append the provided args to the raw opts, + -- in case the check can use them (like checkdates --unique). + -- Does not bother to regenerate the derived data (ReportOpts, ReportSpec..), + -- so those may be inconsistent. + copts' = copts{rawopts_=appendopts (map (,"") args) rawopts_} +-- | Regenerate this CliOpts' report specification, after updating its +-- underlying report options with the given update function. +-- This can raise an error if there is a problem eg due to missing or +-- unparseable options data. See also updateReportSpecFromOpts. +cliOptsUpdateReportSpec :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts +cliOptsUpdateReportSpec roptsupdate copts@CliOpts{reportspec_} = + case updateReportSpecFromOpts roptsupdate reportspec_ of + Left e -> error' e -- PARTIAL: + Right rs -> copts{reportspec_=rs} diff --git a/hledger/Hledger/Cli/Commands/Checkdates.hs b/hledger/Hledger/Cli/Commands/Checkdates.hs index 49b950e46..3f3033d0c 100755 --- a/hledger/Hledger/Cli/Commands/Checkdates.hs +++ b/hledger/Hledger/Cli/Commands/Checkdates.hs @@ -25,7 +25,9 @@ checkdates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do let ropts = (rsOpts rspec){accountlistmode_=ALFlat} let ts = filter (rsQuery rspec `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts ropts j - let unique = boolopt "unique" rawopts + -- pprint rawopts + let unique = boolopt "--unique" rawopts -- TEMP: it's this for hledger check dates + || boolopt "unique" rawopts -- and this for hledger check-dates (for some reason) let date = transactionDateFn ropts let compare a b = if unique