imp: check commodities: also check commodities used in P directives [#2280]

hledger-lib/Hledger/Data/Errors.hs

@@ -7,6 +7,7 @@ Helpers for making error messages.
 
 module Hledger.Data.Errors (
   makeAccountTagErrorExcerpt,
+  makePriceDirectiveErrorExcerpt,
   makeTransactionErrorExcerpt,
   makePostingErrorExcerpt,
   makePostingAccountErrorExcerpt,
@@ -27,6 +28,9 @@ import Hledger.Utils
 import Data.Maybe
 import Safe (headMay)
 import Hledger.Data.Posting (isVirtual)
+import Hledger.Data.Dates (showDate)
+import Hledger.Data.Amount (showCommoditySymbol, showAmount)
+
 
 -- | Given an account name and its account directive, and a problem tag within the latter:
 -- render it as a megaparsec-style excerpt, showing the original line number and
@@ -38,10 +42,10 @@ makeAccountTagErrorExcerpt :: (AccountName, AccountDeclarationInfo) -> TagName -
 makeAccountTagErrorExcerpt (a, adi) _t = (f, l, merrcols, ex)
   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form
   where
-    (SourcePos f pos _) = adisourcepos adi
+    SourcePos f pos _ = adisourcepos adi
     l = unPos pos
     txt   = showAccountDirective (a, adi) & textChomp & (<>"\n")
-    ex = decorateTagErrorExcerpt l merrcols txt
+    ex = decorateExcerpt l merrcols txt
     -- Calculate columns which will help highlight the region in the excerpt
     -- (but won't exactly match the real data, so won't be shown in the main error line)
     merrcols = Nothing
@@ -55,9 +59,10 @@ showAccountDirective (a, AccountDeclarationInfo{..}) =
   "account " <> a
   <> (if not $ T.null adicomment then "    ; " <> adicomment else "")
 
--- | Add megaparsec-style left margin, line number, and optional column marker(s).
+-- | Decorate a data excerpt with megaparsec-style left margin, line number,
-decorateTagErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text
+-- and marker/underline for the column(s) if known, for inclusion in an error message.
-decorateTagErrorExcerpt l mcols txt =
+decorateExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text
+decorateExcerpt l mcols txt =
   T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms
   where
     (ls,ms) = splitAt 1 $ T.lines txt
@@ -70,7 +75,27 @@ decorateTagErrorExcerpt l mcols txt =
     lineprefix = T.replicate marginw " " <> "| "
       where  marginw = length (show l) + 1
 
-_showAccountDirective = undefined
+-- | Given a problem price directive,
+-- and maybe a function to calculate the error region's column(s) (currently ignored):
+-- generate a megaparsec-style error message with highlighted excerpt.
+-- Returns the source file path, line number, column(s) if known, and the rendered excerpt,
+-- or as much of these as possible.
+-- Columns will be accurate for the rendered error message, not for the original journal entry.
+makePriceDirectiveErrorExcerpt :: PriceDirective -> Maybe (PriceDirective -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text)
+makePriceDirectiveErrorExcerpt pd _finderrorcolumns = (file, line, merrcols, excerpt)
+  where
+    SourcePos file pos _ = pdsourcepos pd
+    line = unPos pos
+    merrcols = Nothing
+    excerpt = decorateExcerpt line merrcols $ showPriceDirective pd <> "\n"
+
+showPriceDirective :: PriceDirective -> Text
+showPriceDirective PriceDirective{..} = T.unwords [
+   "P"
+  ,showDate pddate
+  ,showCommoditySymbol pdcommodity
+  ,T.pack $ showAmount pdamount 
+  ]
 
 -- | Given a problem transaction and a function calculating the best
 -- column(s) for marking the error region:
@@ -83,7 +108,7 @@ makeTransactionErrorExcerpt :: Transaction -> (Transaction -> Maybe (Int, Maybe
 makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex)
   -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form
   where
-    (SourcePos f tpos _) = fst $ tsourcepos t
+    SourcePos f tpos _ = fst $ tsourcepos t
     tl = unPos tpos
     txntxt = showTransaction t & textChomp & (<>"\n")
     merrcols = findtxnerrorcolumns t

hledger-lib/Hledger/Data/JournalChecks.hs

@@ -77,44 +77,53 @@ journalCheckAccounts j = mapM_ checkacct (journalPostings j)
 journalCheckBalanceAssertions :: Journal -> Either String ()
 journalCheckBalanceAssertions = fmap (const ()) . journalBalanceTransactions defbalancingopts
 
--- | Check that all the commodities used in this journal's postings have been declared
+-- | Check that all the commodities used in this journal's postings and P directives
--- by commodity directives, returning an error message otherwise.
+-- have been declared by commodity directives, returning an error message otherwise.
 journalCheckCommodities :: Journal -> Either String ()
-journalCheckCommodities j = mapM_ checkcommodities (journalPostings j)
+journalCheckCommodities j = do
+  mapM_ checkPriceDirectiveCommodities $ jpricedirectives j
+  mapM_ checkPostingCommodities $ journalPostings j
   where
-    checkcommodities p =
+    firstUndeclaredOf comms = find (`M.notMember` jcommodities j) comms
-      case findundeclaredcomm p of
+
-        Nothing -> Right ()
+    errmsg = unlines [
-        Just (comm, _) ->
+        "%s:%d:"
-          Left $ printf (unlines [
+      ,"%s"
-           "%s:%d:"
+      ,"Strict commodity checking is enabled, and"
-          ,"%s"
+      ,"commodity %s has not been declared."
-          ,"Strict commodity checking is enabled, and"
+      ,"Consider adding a commodity directive. Examples:"
-          ,"commodity %s has not been declared."
+      ,""
-          ,"Consider adding a commodity directive. Examples:"
+      ,"commodity %s1000.00"
-          ,""
+      ,"commodity 1.000,00 %s"
-          ,"commodity %s1000.00"
+      ]
-          ,"commodity 1.000,00 %s"
+
-          ]) f l ex (show comm) comm comm
+    checkPriceDirectiveCommodities pd@PriceDirective{pdcommodity=c, pdamount=amt} =
+      case firstUndeclaredOf [c, acommodity amt] of
+        Nothing   -> Right ()
+        Just comm -> Left $ printf errmsg f l ex (show comm) comm comm
+          where (f,l,_mcols,ex) = makePriceDirectiveErrorExcerpt pd Nothing
+
+    checkPostingCommodities p =
+      case firstundeclaredcomm p of
+        Nothing                    -> Right ()
+        Just (comm, _inpostingamt) -> Left $ printf errmsg f l ex (show comm) comm comm
           where
             (f,l,_mcols,ex) = makePostingErrorExcerpt p finderrcols
       where
-        -- Find the first undeclared commodity symbol in this posting's amount
+        -- Find the first undeclared commodity symbol in this posting's amount or balance assertion amount, if any.
-        -- or balance assertion amount, if any. The boolean will be true if
+        -- and whether it was in the posting amount.
-        -- the undeclared symbol was in the posting amount.
+        -- XXX The latter is currently unused, could be used to refine the error highlighting ?
-        findundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool)
+        firstundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool)
-        findundeclaredcomm Posting{pamount=amt,pbalanceassertion} =
+        firstundeclaredcomm Posting{pamount=amt,pbalanceassertion} =
-          case (findundeclared postingcomms, findundeclared assertioncomms) of
+          case (firstUndeclaredOf postingcomms, firstUndeclaredOf assertioncomms) of
             (Just c, _) -> Just (c, True)
             (_, Just c) -> Just (c, False)
             _           -> Nothing
           where
+            assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]
             postingcomms = map acommodity $ filter (not . isIgnorable) $ amountsRaw amt
               where
-                -- Ignore missing amounts and zero amounts without commodity (#1767)
+                isIgnorable a = a==missingamt || (amountIsZero a && T.null (acommodity a))  -- #1767
-                isIgnorable a = (T.null (acommodity a) && amountIsZero a) || a == missingamt
-            assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]]
-            findundeclared = find (`M.notMember` jcommodities j)
 
         -- Calculate columns suitable for highlighting the excerpt.
         -- We won't show these in the main error line as they aren't