Merge pull request #1435 into master (add "payees" check)

Second attempt, repaired version.

examples/sample.journal

@@ -15,6 +15,19 @@
 ; liabilities
 ;   debts
 
+; declare accounts:
+; account assets:bank:checking
+; account income:salary
+; account income:gifts
+; account assets:bank:saving
+; account assets:cash
+; account expenses:food
+; account expenses:supplies
+; account liabilities:debts
+
+; declare commodities:
+; commodity $
+
 2008/01/01 income
     assets:bank:checking  $1
     income:salary

hledger-lib/Hledger/Data/Journal.hs

@@ -52,6 +52,7 @@ module Hledger.Data.Journal (
   -- overJournalAmounts,
   -- traverseJournalAmounts,
   -- journalCanonicalCommodities,
+  journalPayeesDeclared,
   journalCommoditiesDeclared,
   journalDateSpan,
   journalStartDate,
@@ -183,6 +184,7 @@ instance Semigroup Journal where
     -- ,jparsetransactioncount     = jparsetransactioncount     j1 +  jparsetransactioncount     j2
     ,jparsetimeclockentries     = jparsetimeclockentries     j1 <> jparsetimeclockentries     j2
     ,jincludefilestack          = jincludefilestack j2
+    ,jdeclaredpayees            = jdeclaredpayees            j1 <> jdeclaredpayees            j2
     ,jdeclaredaccounts          = jdeclaredaccounts          j1 <> jdeclaredaccounts          j2
     ,jdeclaredaccounttypes      = jdeclaredaccounttypes      j1 <> jdeclaredaccounttypes      j2
     ,jglobalcommoditystyles     = jglobalcommoditystyles     j1 <> jglobalcommoditystyles     j2
@@ -211,6 +213,7 @@ nulljournal = Journal {
   -- ,jparsetransactioncount     = 0
   ,jparsetimeclockentries     = []
   ,jincludefilestack          = []
+  ,jdeclaredpayees            = []
   ,jdeclaredaccounts          = []
   ,jdeclaredaccounttypes      = M.empty
   ,jglobalcommoditystyles     = M.empty
@@ -273,6 +276,10 @@ journalPostings = concatMap tpostings . jtxns
 journalCommoditiesDeclared :: Journal -> [AccountName]
 journalCommoditiesDeclared = nubSort . M.keys . jcommodities
 
+-- | Sorted unique payees declared by payee directives in this journal.
+journalPayeesDeclared :: Journal -> [Payee]
+journalPayeesDeclared = nubSort . map fst . jdeclaredpayees
+
 -- | Sorted unique account names posted to by this journal's transactions.
 journalAccountNamesUsed :: Journal -> [AccountName]
 journalAccountNamesUsed = accountNamesFromPostings . journalPostings

hledger-lib/Hledger/Data/Json.hs

@@ -126,6 +126,7 @@ instance ToJSON AccountAlias
 instance ToJSON AccountType
 instance ToJSONKey AccountType
 instance ToJSON AccountDeclarationInfo
+instance ToJSON PayeeDeclarationInfo
 instance ToJSON Commodity
 instance ToJSON TimeclockCode
 instance ToJSON TimeclockEntry

hledger-lib/Hledger/Data/Types.hs

@@ -132,6 +132,8 @@ data Interval =
 
 instance Default Interval where def = NoInterval
 
+type Payee = Text
+
 type AccountName = Text
 
 data AccountType =
@@ -453,6 +455,7 @@ data Journal = Journal {
   ,jparsetimeclockentries :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out
   ,jincludefilestack      :: [FilePath]
   -- principal data
+  ,jdeclaredpayees        :: [(Payee,PayeeDeclarationInfo)]         -- ^ Payees declared by payee directives, in parse order (after journal finalisation)
   ,jdeclaredaccounts      :: [(AccountName,AccountDeclarationInfo)] -- ^ Accounts declared by account directives, in parse order (after journal finalisation)
   ,jdeclaredaccounttypes  :: M.Map AccountType [AccountName]        -- ^ Accounts whose type has been declared in account directives (usually 5 top-level accounts)
   ,jglobalcommoditystyles :: M.Map CommoditySymbol AmountStyle      -- ^ per-commodity display styles declared globally, eg by command line option or import command
@@ -482,6 +485,17 @@ type ParsedJournal = Journal
 -- The --output-format option selects one of these for output.
 type StorageFormat = String
 
+-- | Extra information found in a payee directive.
+data PayeeDeclarationInfo = PayeeDeclarationInfo {
+   pdicomment :: Text   -- ^ any comment lines following the payee directive
+  ,pditags    :: [Tag]  -- ^ tags extracted from the comment, if any
+} deriving (Eq,Show,Generic)
+
+nullpayeedeclarationinfo = PayeeDeclarationInfo {
+   pdicomment          = ""
+  ,pditags             = []
+}
+
 -- | Extra information about an account that can be derived from
 -- its account directive (and the other account directives).
 data AccountDeclarationInfo = AccountDeclarationInfo {

hledger-lib/Hledger/Read/Common.hs

@@ -45,6 +45,7 @@ module Hledger.Read.Common (
   parseAndFinaliseJournal,
   parseAndFinaliseJournal',
   journalFinalise,
+  journalCheckPayeesDeclared,
   setYear,
   getYear,
   setDefaultCommodityAndStyle,
@@ -149,6 +150,7 @@ import Text.Megaparsec.Custom
 import Hledger.Data
 import Hledger.Utils
 import Safe (headMay)
+import Text.Printf (printf)
 
 --- ** doctest setup
 -- $setup
@@ -368,6 +370,22 @@ journalFinalise InputOpts{auto_,ignore_assertions_,commoditystyles_,strict_} f t
                 )
             & fmap journalInferMarketPricesFromTransactions  -- infer market prices from commodity-exchanging transactions
 
+-- | Check that all the journal's transactions have payees declared with
+-- payee directives, returning an error message otherwise.
+journalCheckPayeesDeclared :: Journal -> Either String ()
+journalCheckPayeesDeclared j = sequence_ $ map checkpayee $ jtxns j
+  where
+    checkpayee t
+      | p `elem` ps = Right ()
+      | otherwise = Left $ 
+          printf "undeclared payee \"%s\"\nat: %s\n\n%s"
+            (T.unpack p) 
+            (showGenericSourcePos $ tsourcepos t)
+            (linesPrepend2 "> " "  " $ chomp1 $ showTransaction t)
+      where
+        p  = transactionPayee t
+        ps = journalPayeesDeclared j
+
 -- | Check that all the journal's postings are to accounts declared with
 -- account directives, returning an error message otherwise.
 journalCheckAccountsDeclared :: Journal -> Either String ()
@@ -375,11 +393,13 @@ journalCheckAccountsDeclared j = sequence_ $ map checkacct $ journalPostings j
   where
     checkacct Posting{paccount,ptransaction}
       | paccount `elem` as = Right ()
-      | otherwise          = 
-          Left $ "\nstrict mode: undeclared account \""++T.unpack paccount++"\""
-            ++ case ptransaction of
-                Just Transaction{tsourcepos} -> "\nin transaction at: "++showGenericSourcePos tsourcepos
-                Nothing -> ""
+      | otherwise = Left $
+          (printf "undeclared account \"%s\"\n" (T.unpack paccount))
+          ++ case ptransaction of 
+              Nothing -> ""
+              Just t  -> printf "in transaction at: %s\n\n%s"
+                          (showGenericSourcePos $ tsourcepos t)
+                          (linesPrepend "  " $ chomp1 $ showTransaction t)
       where
         as = journalAccountNamesDeclared j
 
@@ -392,11 +412,13 @@ journalCheckCommoditiesDeclared j =
     checkcommodities Posting{..} =
       case mfirstundeclaredcomm of
         Nothing -> Right ()
-        Just c  -> Left $ 
-          "\nstrict mode: undeclared commodity \""++T.unpack c++"\""
-          ++ case ptransaction of
-                Just Transaction{tsourcepos} -> "\nin transaction at: "++showGenericSourcePos tsourcepos
-                Nothing -> ""      
+        Just c  -> Left $
+          (printf "undeclared commodity \"%s\"\n" (T.unpack c))
+          ++ case ptransaction of 
+              Nothing -> ""
+              Just t  -> printf "in transaction at: %s\n\n%s"
+                          (showGenericSourcePos $ tsourcepos t)
+                          (linesPrepend "  " $ chomp1 $ showTransaction t)
       where
         mfirstundeclaredcomm = 
           headMay $ filter (not . (`elem` cs)) $ catMaybes $
@@ -404,6 +426,7 @@ journalCheckCommoditiesDeclared j =
           (map (Just . acommodity) $ amounts pamount)
         cs = journalCommoditiesDeclared j
 
+
 setYear :: Year -> JournalParser m ()
 setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
 

hledger-lib/Hledger/Read/JournalReader.hs

@@ -226,6 +226,7 @@ directivep = (do
    ,applyaccountdirectivep
    ,commoditydirectivep
    ,endapplyaccountdirectivep
+   ,payeedirectivep
    ,tagdirectivep
    ,endtagdirectivep
    ,defaultyeardirectivep
@@ -396,6 +397,17 @@ addAccountDeclaration (a,cmt,tags) =
              in
                j{jdeclaredaccounts = d:decls})
 
+-- Add a payee declaration to the journal.
+addPayeeDeclaration :: (Payee,Text,[Tag]) -> JournalParser m ()
+addPayeeDeclaration (p, cmt, tags) =
+  modify' (\j@Journal{jdeclaredpayees} -> j{jdeclaredpayees=d:jdeclaredpayees})
+             where
+               d = (p
+                   ,nullpayeedeclarationinfo{
+                     pdicomment = cmt
+                    ,pditags    = tags
+                    })
+
 indentedlinep :: JournalParser m String
 indentedlinep = lift skipNonNewlineSpaces1 >> (rstrip <$> lift restofline)
 
@@ -519,6 +531,15 @@ endtagdirectivep = do
   lift restofline
   return ()
 
+payeedirectivep :: JournalParser m ()
+payeedirectivep = do
+  string "payee" <?> "payee directive"
+  lift skipNonNewlineSpaces1
+  payee <- lift descriptionp  -- all text until ; or \n
+  (comment, tags) <- lift transactioncommentp
+  addPayeeDeclaration (payee, comment, tags)
+  return ()
+
 defaultyeardirectivep :: JournalParser m ()
 defaultyeardirectivep = do
   char 'Y' <?> "default year"
@@ -985,6 +1006,11 @@ tests_JournalReader = tests "JournalReader" [
       pdamount    = usd 922.83
       }
 
+  ,tests "payeedirectivep" [
+       test "simple"             $ assertParse payeedirectivep "payee foo\n"
+       ,test "with-comment"       $ assertParse payeedirectivep "payee foo ; comment\n"
+       ]
+
   ,test "tagdirectivep" $ do
      assertParse tagdirectivep "tag foo \n"
 

hledger-lib/Hledger/Utils/String.hs

@@ -21,6 +21,7 @@ module Hledger.Utils.String (
  lstrip,
  rstrip,
  chomp,
+ chomp1,
  singleline,
  elideLeft,
  elideRight,
@@ -37,6 +38,8 @@ module Hledger.Utils.String (
  padright,
  cliptopleft,
  fitto,
+ linesPrepend,
+ linesPrepend2,
  -- * wide-character-aware layout
  charWidth,
  strWidth,
@@ -86,10 +89,14 @@ lstrip = dropWhile isSpace
 rstrip :: String -> String
 rstrip = reverse . lstrip . reverse
 
--- | Remove trailing newlines/carriage returns.
+-- | Remove all trailing newlines/carriage returns.
 chomp :: String -> String
 chomp = reverse . dropWhile (`elem` "\r\n") . reverse
 
+-- | Remove all trailing newline/carriage returns, leaving just one trailing newline.
+chomp1 :: String -> String
+chomp1 = (++"\n") . chomp
+
 -- | Remove consecutive line breaks, replacing them with single space
 singleline :: String -> String
 singleline = unwords . filter (/="") . (map strip) . lines
@@ -343,3 +350,14 @@ stripAnsi s = either err id $ regexReplace ansire "" s
  where
    err    = error "stripAnsi: invalid replacement pattern"      -- PARTIAL, shouldn't happen
    ansire = toRegex' "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]"  -- PARTIAL, should succeed
+
+-- | Add a prefix to each line of a string.
+linesPrepend :: String -> String -> String
+linesPrepend prefix = unlines . map (prefix++) . lines
+
+-- | Add a prefix to the first line of a string, 
+-- and a different prefix to the remaining lines.
+linesPrepend2 :: String -> String -> String -> String
+linesPrepend2 prefix1 prefix2 s =
+  unlines $ (prefix1++l) : map (prefix2++) ls
+  where l:ls = lines s

hledger/Hledger/Cli/Commands/Check.hs

@@ -18,6 +18,8 @@ import Data.Either (partitionEithers)
 import Data.Char (toUpper)
 import Safe (readMay)
 import Control.Monad (forM_)
+import System.IO (stderr, hPutStrLn)
+import System.Exit (exitFailure)
 
 checkmode :: Mode RawOpts
 checkmode = hledgerCommandMode
@@ -40,8 +42,11 @@ check copts@CliOpts{rawopts_} j = do
     ([], checks) -> forM_ checks $ runCheck copts' j
       
 -- | 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.)
 data Check =
     Ordereddates
+  | Payees
   | Uniqueleafnames
   deriving (Read,Show,Eq)
 
@@ -63,13 +68,18 @@ parseCheckArgument s =
   where
     (checkname:checkargs) = words' s
 
+-- XXX do all of these print on stderr ?
 -- | 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
-    Ordereddates     -> checkdates copts' j
+    Ordereddates    -> checkdates copts' j
     Uniqueleafnames -> checkdupes copts' j
+    Payees          ->
+      case journalCheckPayeesDeclared j of
+        Right () -> return ()
+        Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure
   where
     -- Hack: append the provided args to the raw opts,
     -- in case the check can use them (like checkdates --unique). 

hledger/Hledger/Cli/Commands/Check.md

@@ -50,6 +50,8 @@ These checks can be run by specifying their names as arguments to the check comm
 
 - **ordereddates** - transactions are ordered by date (similar to the old `check-dates` command)
 
+- **payees** - all payees used by transactions have been declared
+
 - **uniqueleafnames** - all account leaf names are unique (similar to the old `check-dupes` command)
 
 ### Add-on checks

hledger/Hledger/Cli/Commands/Checkdates.hs

@@ -37,13 +37,15 @@ checkdates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
     FoldAcc{fa_previous=Nothing} -> return ()
     FoldAcc{fa_error=Nothing}    -> return ()
     FoldAcc{fa_error=Just error, fa_previous=Just previous} -> do
-      putStrLn $ printf 
-          ("Error: transaction's date is not in date order%s,\n"
-        ++ "at %s:\n\n%sPrevious transaction's date was: %s")
-        (if unique then " and/or not unique" else "")
-        (showGenericSourcePos $ tsourcepos error)
-        (showTransaction error)
-        (show $ date previous)
+      let 
+        uniquestr = if unique then " and/or not unique" else ""
+        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"
+        uniquestr
+        positionstr
+        (txn1str ++ txn2str)
       exitFailure
 
 data FoldAcc a b = FoldAcc

hledger/Hledger/Cli/Commands/Checkdupes.hs

@@ -28,6 +28,7 @@ checkdupesmode = hledgerCommandMode
 checkdupes _opts j = do
   let dupes = checkdupes' $ accountsNames j
   when (not $ null dupes) $ do
+    -- XXX make output more like Checkdates.hs, Check.hs etc.
     mapM_ render dupes
     exitFailure
 

hledger/test/check-payees.test

@@ -0,0 +1,23 @@
+# check payees
+
+# check payees succeeds when all payees are declared:
+<
+payee foo
+2020-01-01 foo
+2020-01-02 foo | some description
+$ hledger -f - check payees
+
+# and otherwise fails, eg:
+<
+2020-01-01 foo
+$ hledger -f - check payees
+>2 /undeclared payee "foo"/
+>=1
+
+# or:
+<
+payee foo
+2020-01-01 the payee | foo
+$ hledger -f - check payees
+>2 /undeclared payee "the payee"/
+>=1