From 6905e40c4d902ae7df616526805ae8fda121039d Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 30 Aug 2021 00:25:11 +1000 Subject: [PATCH] pkg!: cli: Add --today option to explicitly set the current date. (#1674) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit rawOptsTo* in hledger-lib now takes a day as an argument, and does not live in the IO monad, since it's now pure. This is so that we can run tests containing future transactions that won't fail as soon as ‘the future’ actually arrives. --- hledger-lib/Hledger/Read/Common.hs | 15 +++++++-------- hledger-lib/Hledger/Reports/ReportOptions.hs | 10 ++++------ hledger/Hledger/Cli/CliOptions.hs | 10 +++++++--- hledger/Hledger/Cli/Commands/Add.hs | 5 +++-- hledger/Hledger/Cli/Commands/Close.hs | 2 +- hledger/Hledger/Cli/Commands/Rewrite.hs | 4 ++-- hledger/Hledger/Cli/Commands/Roi.hs | 5 ++--- hledger/Hledger/Cli/Commands/Stats.hs | 6 +++--- hledger/Hledger/Cli/Commands/Tags.hs | 6 +++--- 9 files changed, 32 insertions(+), 31 deletions(-) diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 8fa4cc146..115e4519a 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -228,21 +228,20 @@ parseCommodity optStr = Left _ -> Left optStr Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle) --- | Parse an InputOpts from a RawOpts and the current date. +-- | Parse an InputOpts from a RawOpts and a provided date. -- This will fail with a usage error if the forecast period expression cannot be parsed. -rawOptsToInputOpts :: RawOpts -> IO InputOpts -rawOptsToInputOpts rawopts = do - d <- getCurrentDay +rawOptsToInputOpts :: Day -> RawOpts -> InputOpts +rawOptsToInputOpts day rawopts = let noinferprice = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion" -- Do we really need to do all this work just to get the requested end date? This is duplicating -- much of reportOptsToSpec. - ropts = rawOptsToReportOpts d rawopts - argsquery = lefts . rights . map (parseQueryTerm d) $ querystring_ ropts + ropts = rawOptsToReportOpts day rawopts + argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery - return InputOpts{ + in InputOpts{ -- files_ = listofstringopt "file" rawopts mformat_ = Nothing ,mrules_file_ = maybestringopt "rules-file" rawopts @@ -251,7 +250,7 @@ rawOptsToInputOpts rawopts = do ,new_ = boolopt "new" rawopts ,new_save_ = True ,pivot_ = stringopt "pivot" rawopts - ,forecast_ = forecastPeriodFromRawOpts d rawopts + ,forecast_ = forecastPeriodFromRawOpts day rawopts ,reportspan_ = DateSpan (queryStartDate False datequery) (queryEndDate False datequery) ,auto_ = boolopt "auto" rawopts ,balancingopts_ = defbalancingopts{ diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index ae16d9451..8fe1dd745 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -777,9 +777,7 @@ updateReportSpec = setEither reportOpts updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec updateReportSpecWith = overEither reportOpts --- | Generate a ReportSpec from RawOpts and the current date. -rawOptsToReportSpec :: RawOpts -> IO ReportSpec -rawOptsToReportSpec rawopts = do - d <- getCurrentDay - let ropts = rawOptsToReportOpts d rawopts - either fail return $ reportOptsToSpec d ropts +-- | Generate a ReportSpec from RawOpts and a provided day, or return an error +-- string if there are regular expression errors. +rawOptsToReportSpec :: Day -> RawOpts -> Either String ReportSpec +rawOptsToReportSpec day = reportOptsToSpec day . rawOptsToReportOpts day diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 340d6444b..37e7bae06 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -118,7 +118,8 @@ helpflags = [ ,flagNone ["man"] (setboolopt "man") "Show user manual with man" ,flagNone ["info"] (setboolopt "info") "Show info manual with info" -- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line" - ,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "[N]" "show debug output (levels 1-9, default: 1)" + ,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "[N]" "show debug output (levels 1-9, default: 1)" + ,flagReq ["today"] (\s opts -> Right $ setopt "today" s opts) "DATE" "generate reports treating DATE as the current day (for testing purposes)" ,flagNone ["version"] (setboolopt "version") "show version information" ] @@ -466,8 +467,11 @@ replaceNumericFlags = map replace -- Also records the terminal width, if supported. rawOptsToCliOpts :: RawOpts -> IO CliOpts rawOptsToCliOpts rawopts = do - iopts <- rawOptsToInputOpts rawopts - rspec <- rawOptsToReportSpec rawopts + day <- case maybestringopt "today" rawopts of + Nothing -> getCurrentDay + Just d -> maybe (fail $ "Unable to parse date \"" ++ d ++ "\"") pure $ parsedateM d -- PARTIAL: + let iopts = rawOptsToInputOpts day rawopts + rspec <- either fail pure $ rawOptsToReportSpec day rawopts -- PARTIAL: mcolumns <- readMay <$> getEnvSafe "COLUMNS" mtermwidth <- #ifdef mingw32_HOST_OS diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index 8963b4016..9527e8e8a 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -33,6 +33,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL import Data.Time.Calendar (Day) import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) +import Lens.Micro ((^.)) import Safe (headDef, headMay, atMay) import System.Console.CmdArgs.Explicit (flagNone) import System.Console.Haskeline (runInputT, defaultSettings, setComplete) @@ -93,8 +94,8 @@ add opts j | otherwise = do hPutStrLn stderr $ "Adding transactions to journal file " <> journalFilePath j showHelp - today <- getCurrentDay - let es = defEntryState{esOpts=opts + let today = opts^.rsDay + es = defEntryState{esOpts=opts ,esArgs=listofstringopt "args" $ rawopts_ opts ,esToday=today ,esDefDate=today diff --git a/hledger/Hledger/Cli/Commands/Close.hs b/hledger/Hledger/Cli/Commands/Close.hs index c1750e2a3..0cc65b794 100755 --- a/hledger/Hledger/Cli/Commands/Close.hs +++ b/hledger/Hledger/Cli/Commands/Close.hs @@ -49,8 +49,8 @@ closemode = hledgerCommandMode -- debugger, beware: close is incredibly devious. simple rules combine to make a horrid maze. -- tests are in hledger/test/close.test. close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do - today <- getCurrentDay let + today = _rsDay rspec -- show opening entry, closing entry, or (default) both ? (opening, closing) = case (boolopt "open" rawopts, boolopt "close" rawopts) of diff --git a/hledger/Hledger/Cli/Commands/Rewrite.hs b/hledger/Hledger/Cli/Commands/Rewrite.hs index 4213acf4c..ef27cdf24 100755 --- a/hledger/Hledger/Cli/Commands/Rewrite.hs +++ b/hledger/Hledger/Cli/Commands/Rewrite.hs @@ -39,9 +39,9 @@ rewritemode = hledgerCommandMode rewrite opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j@Journal{jtxns=ts} = do -- rewrite matched transactions - d <- getCurrentDay + let today = _rsDay rspec let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j - let j' = j{jtxns=either error' id $ modifyTransactions mempty d modifiers ts} -- PARTIAL: + let j' = j{jtxns=either error' id $ modifyTransactions mempty today modifiers ts} -- PARTIAL: -- run the print command, showing all transactions, or show diffs printOrDiff rawopts opts{reportspec_=rspec{_rsQuery=Any}} j j' diff --git a/hledger/Hledger/Cli/Commands/Roi.hs b/hledger/Hledger/Cli/Commands/Roi.hs index babcab296..c29b2f2f6 100644 --- a/hledger/Hledger/Cli/Commands/Roi.hs +++ b/hledger/Hledger/Cli/Commands/Roi.hs @@ -59,12 +59,11 @@ data OneSpan = OneSpan roi :: CliOpts -> Journal -> IO () roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{_rsReportOpts=ReportOpts{..}}} j = do - d <- getCurrentDay -- We may be converting posting amounts to value, per hledger_options.m4.md "Effect of --value on reports". let + today = _rsDay rspec priceOracle = journalPriceOracle infer_value_ j styles = journalCommodityStyles j - today = _rsDay rspec mixedAmountValue periodlast date = maybe id (mixedAmountApplyValuation priceOracle styles periodlast today date) value_ . mixedAmountToCost cost_ styles @@ -74,7 +73,7 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{_rsReportOpts=ReportO showCashFlow = boolopt "cashflow" rawopts prettyTables = pretty_tables_ makeQuery flag = do - q <- either usageError (return . fst) . parseQuery d . T.pack $ stringopt flag rawopts + q <- either usageError (return . fst) . parseQuery today . T.pack $ stringopt flag rawopts return . simplifyQuery $ And [queryFromFlags ropts{period_=PeriodAll}, q] investmentsQuery <- makeQuery "investment" diff --git a/hledger/Hledger/Cli/Commands/Stats.hs b/hledger/Hledger/Cli/Commands/Stats.hs index 21e6576d7..e6bf93315 100644 --- a/hledger/Hledger/Cli/Commands/Stats.hs +++ b/hledger/Hledger/Cli/Commands/Stats.hs @@ -43,12 +43,12 @@ statsmode = hledgerCommandMode -- | Print various statistics for the journal. stats :: CliOpts -> Journal -> IO () stats opts@CliOpts{reportspec_=rspec} j = do - d <- getCurrentDay - let q = _rsQuery rspec + let today = _rsDay rspec + q = _rsQuery rspec l = ledgerFromJournal q j reportspan = ledgerDateSpan l `spanDefaultsFrom` queryDateSpan False q intervalspans = splitSpan (interval_ $ _rsReportOpts rspec) reportspan - showstats = showLedgerStats l d + showstats = showLedgerStats l today s = unlinesB $ map showstats intervalspans writeOutputLazyText opts $ TB.toLazyText s diff --git a/hledger/Hledger/Cli/Commands/Tags.hs b/hledger/Hledger/Cli/Commands/Tags.hs index 3aa55fecb..b61f72a5f 100755 --- a/hledger/Hledger/Cli/Commands/Tags.hs +++ b/hledger/Hledger/Cli/Commands/Tags.hs @@ -27,8 +27,8 @@ tagsmode = hledgerCommandMode tags :: CliOpts -> Journal -> IO () tags CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do - d <- getCurrentDay - let args = listofstringopt "args" rawopts + let today = _rsDay rspec + args = listofstringopt "args" rawopts mtagpat <- mapM (either Fail.fail pure . toRegexCI . T.pack) $ headMay args let querystring = map T.pack $ drop 1 args @@ -36,7 +36,7 @@ tags CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do parsed = boolopt "parsed" rawopts empty = empty_ $ _rsReportOpts rspec - argsquery <- either usageError (return . fst) $ parseQueryList d querystring + argsquery <- either usageError (return . fst) $ parseQueryList today querystring let q = simplifyQuery $ And [queryFromFlags $ _rsReportOpts rspec, argsquery] txns = filter (q `matchesTransaction`) $ jtxns $ journalApplyValuationFromOpts rspec j