diff --git a/hledger-lib/Hledger/Data/Errors.hs b/hledger-lib/Hledger/Data/Errors.hs index f1964d3e1..32d37021c 100644 --- a/hledger-lib/Hledger/Data/Errors.hs +++ b/hledger-lib/Hledger/Data/Errors.hs @@ -3,8 +3,10 @@ Helpers for making error messages. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Hledger.Data.Errors ( + makeAccountTagErrorExcerpt, makeTransactionErrorExcerpt, makePostingErrorExcerpt, makePostingAccountErrorExcerpt, @@ -25,13 +27,57 @@ import Data.Maybe import Safe (headMay) import Hledger.Data.Posting (isVirtual) +-- | 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 +-- marked column or region. +-- Returns the file path, line number, column(s) if known, +-- and the rendered excerpt, or as much of these as is possible. +-- The returned columns will be accurate for the rendered error message but not for the original journal data. +makeAccountTagErrorExcerpt :: (AccountName, AccountDeclarationInfo) -> TagName -> (FilePath, Int, Maybe (Int, Maybe Int), Text) +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 + l = unPos pos + txt = showAccountDirective (a, adi) & textChomp & (<>"\n") + ex = decorateTagErrorExcerpt 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 + -- don't bother for now + -- Just (col, Just col2) + -- where + -- col = undefined -- T.length (showTransactionLineFirstPart t') + 2 + -- col2 = undefined -- col + T.length tagname - 1 + +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). +decorateTagErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text +decorateTagErrorExcerpt l mcols txt = + T.unlines $ ls' <> colmarkerline <> map (lineprefix<>) ms + where + (ls,ms) = splitAt 1 $ T.lines txt + ls' = map ((T.pack (show l) <> " | ") <>) ls + colmarkerline = + [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^" + | Just (col, mendcol) <- [mcols] + , let regionw = maybe 1 (subtract col) mendcol + 1 + ] + lineprefix = T.replicate marginw " " <> "| " + where marginw = length (show l) + 1 + +_showAccountDirective = undefined + -- | Given a problem transaction and a function calculating the best -- column(s) for marking the error region: -- render it as a megaparsec-style excerpt, showing the original line number -- on the transaction line, and a column(s) marker. -- Returns the file path, line number, column(s) if known, -- and the rendered excerpt, or as much of these as is possible. --- A limitation: columns will be accurate for the rendered error message but not for the original journal data. +-- The returned columns will be accurate for the rendered error message but not for the original journal data. makeTransactionErrorExcerpt :: Transaction -> (Transaction -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) makeTransactionErrorExcerpt t findtxnerrorcolumns = (f, tl, merrcols, ex) -- XXX findtxnerrorcolumns is awkward, I don't think this is the final form diff --git a/hledger-lib/Hledger/Data/JournalChecks.hs b/hledger-lib/Hledger/Data/JournalChecks.hs index 0b1e85bfe..ff868b9df 100644 --- a/hledger-lib/Hledger/Data/JournalChecks.hs +++ b/hledger-lib/Hledger/Data/JournalChecks.hs @@ -14,12 +14,14 @@ module Hledger.Data.JournalChecks ( journalCheckPayees, journalCheckPairedConversionPostings, journalCheckRecentAssertions, + journalCheckTags, module Hledger.Data.JournalChecks.Ordereddates, module Hledger.Data.JournalChecks.Uniqueleafnames, ) where import Data.Char (isSpace) +import Data.List.Extra import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -30,13 +32,12 @@ import Hledger.Data.Errors import Hledger.Data.Journal import Hledger.Data.JournalChecks.Ordereddates import Hledger.Data.JournalChecks.Uniqueleafnames -import Hledger.Data.Posting (isVirtual, postingDate, postingStatus) +import Hledger.Data.Posting (isVirtual, postingDate, postingStatus, transactionAllTags) import Hledger.Data.Types import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt) import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart, partitionAndCheckConversionPostings) import Data.Time (Day, diffDays) -import Data.List.Extra -import Hledger.Utils (chomp, textChomp, sourcePosPretty) +import Hledger.Utils -- | Check that all the journal's postings are to accounts with -- account directives, returning an error message otherwise. @@ -157,6 +158,44 @@ journalCheckPayees j = mapM_ checkpayee (jtxns j) col = T.length (showTransactionLineFirstPart t') + 2 col2 = col + T.length (transactionPayee t') - 1 +-- | Check that all the journal's tags (on accounts, transactions, postings..) +-- have been declared with tag directives, returning an error message otherwise. +journalCheckTags :: Journal -> Either String () +journalCheckTags j = do + mapM_ checkaccttags $ jdeclaredaccounts j + mapM_ checktxntags $ jtxns j + where + checkaccttags (a, adi) = mapM_ (checkaccttag.fst) $ aditags adi + where + checkaccttag tagname + | tagname `elem` declaredtags = Right () + | otherwise = Left $ printf msg f l ex (show tagname) tagname + where (f,l,_mcols,ex) = makeAccountTagErrorExcerpt (a, adi) tagname + checktxntags txn = mapM_ (checktxntag . fst) $ transactionAllTags txn + where + checktxntag tagname + | tagname `elem` declaredtags = Right () + | otherwise = Left $ printf msg f l ex (show tagname) tagname + where + (f,l,_mcols,ex) = makeTransactionErrorExcerpt txn finderrcols + where + finderrcols _txn' = Nothing + -- don't bother for now + -- Just (col, Just col2) + -- where + -- col = T.length (showTransactionLineFirstPart txn') + 2 + -- col2 = col + T.length tagname - 1 + declaredtags = journalTagsDeclared j + msg = (unlines [ + "%s:%d:" + ,"%s" + ,"Strict tag checking is enabled, and" + ,"tag %s has not been declared." + ,"Consider adding a tag directive. Examples:" + ,"" + ,"tag %s" + ]) + -- | In each tranaction, check that any conversion postings occur in adjacent pairs. journalCheckPairedConversionPostings :: Journal -> Either String () journalCheckPairedConversionPostings j = diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index b6266ca94..49ac21e87 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -573,8 +573,8 @@ nullpayeedeclarationinfo = PayeeDeclarationInfo { } -- | Extra information found in a tag directive. -data TagDeclarationInfo = TagDeclarationInfo { - tdicomment :: Text -- ^ any comment lines following the tag directive +newtype TagDeclarationInfo = TagDeclarationInfo { + tdicomment :: Text -- ^ any comment lines following the tag directive. No tags allowed here. } deriving (Eq,Show,Generic) nulltagdeclarationinfo = TagDeclarationInfo { diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index d1143b7de..d4120485a 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -454,6 +454,13 @@ addPayeeDeclaration (p, cmt, tags) = ,pditags = tags }) +-- Add a tag declaration to the journal. +addTagDeclaration :: (TagName,Text) -> JournalParser m () +addTagDeclaration (t, cmt) = + modify' (\j@Journal{jdeclaredtags} -> j{jdeclaredtags=tagandinfo:jdeclaredtags}) + where + tagandinfo = (t, nulltagdeclarationinfo{tdicomment=cmt}) + indentedlinep :: JournalParser m String indentedlinep = lift skipNonNewlineSpaces1 >> (rstrip <$> lift restofline) @@ -598,9 +605,10 @@ tagdirectivep :: JournalParser m () tagdirectivep = do string "tag" "tag directive" lift skipNonNewlineSpaces1 - _ <- lift $ some nonspace - lift restofline + tagname <- lift $ T.pack <$> some nonspace + (comment, _) <- lift transactioncommentp skipMany indentedlinep + addTagDeclaration (tagname,comment) return () -- end tag or end apply tag diff --git a/hledger/Hledger/Cli/Commands/Check.hs b/hledger/Hledger/Cli/Commands/Check.hs index 3304105bc..3ce187cbf 100644 --- a/hledger/Hledger/Cli/Commands/Check.hs +++ b/hledger/Hledger/Cli/Commands/Check.hs @@ -66,6 +66,7 @@ data Check = | Ordereddates | Payees | Recentassertions + | Tags | Uniqueleafnames deriving (Read,Show,Eq,Enum,Bounded) @@ -105,6 +106,7 @@ runCheck CliOpts{reportspec_=ReportSpec{_rsReportOpts=ropts}} j (chck,_) = do Ordereddates -> journalCheckOrdereddates (whichDate ropts) j Payees -> journalCheckPayees j Recentassertions -> journalCheckRecentAssertions d j + Tags -> journalCheckTags j Uniqueleafnames -> journalCheckUniqueleafnames j -- the other checks have been done earlier during withJournalDo _ -> Right () diff --git a/hledger/Hledger/Cli/Commands/Check.md b/hledger/Hledger/Cli/Commands/Check.md index e1c1c95f2..47cfce4d5 100644 --- a/hledger/Hledger/Cli/Commands/Check.md +++ b/hledger/Hledger/Cli/Commands/Check.md @@ -64,7 +64,7 @@ They are more specialised and not desirable for everyone, therefore optional: - **recentassertions** - all accounts with balance assertions have a balance assertion no more than 7 days before their latest posting -- **tags** - all tags used by transactions [have been declared](#tags) +- **tags** - all tags used by transactions [have been declared](#tag-directive) - **uniqueleafnames** - all account leaf names are unique diff --git a/hledger/hledger.m4.md b/hledger/hledger.m4.md index 7ba8a4c92..8bd9de1be 100644 --- a/hledger/hledger.m4.md +++ b/hledger/hledger.m4.md @@ -2363,6 +2363,10 @@ tag item-id ``` Any indented subdirectives are currently ignored. +The ["tags" check](#check) will report an error if any undeclared tag name is used. +It is quite easy to accidentally create a tag through normal use of colons in [comments](#comments]; +if you want to prevent this, you can declare and check your tags . + ## Periodic transactions The `~` directive declares recurring transactions. diff --git a/hledger/test/check-tags.test b/hledger/test/check-tags.test new file mode 100644 index 000000000..48caadc0d --- /dev/null +++ b/hledger/test/check-tags.test @@ -0,0 +1,40 @@ +# 1. tags can be declared +< +tag atag ; this is atag. tags: on tags are not allowed and will be ignored. + indented subdirectives are ignored. +$ hledger -f - check + +# 2. check tags succeeds when all tags are declared +< +tag atag +tag ttag +tag ptag + +account a ; atag: + +2023-01-01 ; ttag: + (a) 0 ; ptag: + +$ hledger -f - check tags + +# 3. it detects an undeclared account tag +< +account a ; atag: +$ hledger -f - check tags +>2 /tag "atag" has not been declared/ +>=1 + +# 4. it detects an undeclared transaction tag +< +2023-01-01 ; ttag: +$ hledger -f - check tags +>2 /tag "ttag" has not been declared/ +>=1 + +# 5. it detects an undeclared posting tag +< +2023-01-01 + (a) 0 ; ptag: +$ hledger -f - check tags +>2 /tag "ptag" has not been declared/ +>=1