;check: ordereddates/uniqueleafnames: print on stderr, refactor

hledger/Hledger/Cli/Commands/Check.hs

@@ -41,6 +41,16 @@ check copts@CliOpts{rawopts_} j = do
     (unknowns@(_:_), _) -> error' $ "These checks are unknown: "++unwords unknowns
     ([], checks) -> forM_ checks $ runCheck copts' j
       
+-- | 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.
+cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts
+cliOptsUpdateReportSpecWith roptsupdate copts@CliOpts{reportspec_} =
+  case updateReportSpecWith roptsupdate reportspec_ of
+    Left e   -> error' e  -- PARTIAL:
+    Right rs -> copts{reportspec_=rs}
+
 -- | A type of error check that we can perform on the data.
 -- (Currently, just the optional checks that only the check command
 -- can do; not the checks done by default or with --strict.)
@@ -74,32 +84,23 @@ parseCheckArgument s =
 -- | 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
-    Accounts -> case journalCheckAccountsDeclared j of
-      Right () -> return ()
-      Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure
-    Commodities -> case journalCheckCommoditiesDeclared j of
-      Right () -> return ()
-      Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure
-    Ordereddates -> journalCheckOrdereddates copts' j
-    Payees -> case journalCheckPayeesDeclared j of
-      Right () -> return ()
-      Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure
-    Uniqueleafnames -> journalCheckUniqueleafnames j
-  where
-    -- Hack: append the provided args to the raw opts,
-    -- in case the check can use them (like checkdates --unique). 
+runCheck copts@CliOpts{rawopts_} j (check,args) = do
+  let
+    -- XXX drop this ?
+    -- Hack: append the provided args to the raw opts, for checks 
+    -- which can use them (just journalCheckOrdereddates rignt now
+    -- which has some flags from the old checkdates command). 
     -- 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.
-cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts
-cliOptsUpdateReportSpecWith roptsupdate copts@CliOpts{reportspec_} =
-  case updateReportSpecWith roptsupdate reportspec_ of
-    Left e   -> error' e  -- PARTIAL:
-    Right rs -> copts{reportspec_=rs}
+    results = case check of
+      Accounts        -> journalCheckAccountsDeclared j
+      Commodities     -> journalCheckCommoditiesDeclared j
+      Ordereddates    -> journalCheckOrdereddates copts' j
+      Payees          -> journalCheckPayeesDeclared j
+      Uniqueleafnames -> journalCheckUniqueleafnames j
+
+  case results of
+    Right () -> return ()
+    Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure

hledger/Hledger/Cli/Commands/Check/Ordereddates.hs

@@ -5,16 +5,14 @@ where
 
 import Hledger
 import Hledger.Cli.CliOptions
-import System.Exit
 import Text.Printf
 
-journalCheckOrdereddates :: CliOpts -> Journal -> IO ()
+journalCheckOrdereddates :: CliOpts -> Journal -> Either String ()
 journalCheckOrdereddates 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  -- TEMP: it's this for hledger check dates
-            || boolopt "unique" rawopts    -- and this for hledger check-dates (for some reason)
+  let unique = boolopt "--unique" rawopts
   let date = transactionDateFn ropts
   let compare a b =
         if unique
@@ -29,26 +27,18 @@ journalCheckOrdereddates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
         positionstr = showGenericSourcePos $ tsourcepos error
         txn1str = linesPrepend  "  "      $ showTransaction previous
         txn2str = linesPrepend2 "> " "  " $ showTransaction error
-      printf "Error: transaction date is out of order%s\nat %s:\n\n%s"
+      Left $ printf "transaction date is out of order%s\nat %s:\n\n%s"
         uniquestr
         positionstr
         (txn1str ++ txn2str)
-      exitFailure
 
 data FoldAcc a b = FoldAcc
  { fa_error    :: Maybe a
  , fa_previous :: Maybe b
  }
 
-foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
-foldWhile _ acc [] = acc
-foldWhile fold acc (a:as) =
-  case fold a acc of
-   acc@FoldAcc{fa_error=Just _} -> acc
-   acc -> foldWhile fold acc as
-
 checkTransactions :: (Transaction -> Transaction -> Bool)
- -> [Transaction] -> FoldAcc Transaction Transaction
+  -> [Transaction] -> FoldAcc Transaction Transaction
 checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}
   where
     f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
@@ -56,3 +46,10 @@ checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=No
       if compare previous current
       then acc{fa_previous=Just current}
       else acc{fa_error=Just current}
+
+foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
+foldWhile _ acc [] = acc
+foldWhile fold acc (a:as) =
+  case fold a acc of
+   acc@FoldAcc{fa_error=Just _} -> acc
+   acc -> foldWhile fold acc as

hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs

@@ -9,21 +9,18 @@ import Data.List.Extra (nubSort)
 import qualified Data.Text as T
 import Hledger
 import Text.Printf
-import System.Exit (exitFailure)
-import Control.Monad (when)
 
+journalCheckUniqueleafnames :: Journal -> Either String ()
 journalCheckUniqueleafnames j = do
   let dupes = checkdupes' $ accountsNames j
-  when (not $ null dupes) $ do
+  if null dupes
+  then Right ()
+  else Left $ 
     -- XXX make output more like Checkdates.hs, Check.hs etc.
-    mapM_ render dupes
-    exitFailure
-
-accountsNames :: Journal -> [(String, AccountName)]
-accountsNames j = map leafAndAccountName as
-  where leafAndAccountName a = (T.unpack $ accountLeafName a, a)
-        ps = journalPostings j
-        as = nubSort $ map paccount ps
+    concatMap render dupes
+    where
+      render (leafName, accountNameL) = 
+        printf "%s as %s\n" leafName (intercalate ", " (map T.unpack accountNameL))
 
 checkdupes' :: (Ord k, Eq k) => [(k, v)] -> [(k, [v])]
 checkdupes' l = zip dupLeafs dupAccountNames
@@ -34,5 +31,8 @@ checkdupes' l = zip dupLeafs dupAccountNames
           . groupBy ((==) `on` fst)
           . sortBy (compare `on` fst)
 
-render :: (String, [AccountName]) -> IO ()
-render (leafName, accountNameL) = printf "%s as %s\n" leafName (intercalate ", " (map T.unpack accountNameL))
+accountsNames :: Journal -> [(String, AccountName)]
+accountsNames j = map leafAndAccountName as
+  where leafAndAccountName a = (T.unpack $ accountLeafName a, a)
+        ps = journalPostings j
+        as = nubSort $ map paccount ps

hledger/test/check-ordereddates.test

@@ -12,10 +12,9 @@ $ hledger -f- check ordereddates
 2020-01-01
   (a)  1
 $ hledger -f- check ordereddates
-> /transaction date is out of order/
+>2 /transaction date is out of order/
 >=1
 # XXX 
-# make it >2
 # With --date2, it checks secondary dates instead.
 # With --strict, dates must also be unique.
 # With a query, only matched transactions' dates are checked.

hledger/test/check-uniqueleafnames.test

@@ -11,10 +11,10 @@ $ hledger -f- check uniqueleafnames
   (a)     1
   (b:a)   1
 $ hledger -f- check uniqueleafnames
-> /a as a, b:a/
+>2 /a as a, b:a/
 >=1
 # XXX
-# make it >2; improve message
+# improve message
 # Reports account names having the same leaf but different prefixes. 
 # In other words, two or more leaves that are categorized differently.
 # Reads the default journal file, or another specified as an argument.