pkg!: cli: Add --today option to explicitly set the current date. (#1674)

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

@@ -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{

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

hledger/Hledger/Cli/CliOptions.hs

@@ -119,6 +119,7 @@ helpflags = [
  ,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  ["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

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

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

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'
 

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"

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
 

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