ref: consolidate most checks under Hledger.Read.Checks
and error message helpers in Hledger.Read.Error.
This commit is contained in:
		
							parent
							
								
									211680da86
								
							
						
					
					
						commit
						810a868c88
					
				| @ -42,6 +42,7 @@ module Hledger.Read ( | |||||||
|   findReader, |   findReader, | ||||||
|   splitReaderPrefix, |   splitReaderPrefix, | ||||||
|   runJournalParser, |   runJournalParser, | ||||||
|  |   module Hledger.Read.Checks, | ||||||
|   module Hledger.Read.Common, |   module Hledger.Read.Common, | ||||||
|   module Hledger.Read.InputOptions, |   module Hledger.Read.InputOptions, | ||||||
| 
 | 
 | ||||||
| @ -75,6 +76,7 @@ import System.IO (hPutStr, stderr) | |||||||
| 
 | 
 | ||||||
| import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate) | import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate) | ||||||
| import Hledger.Data.Types | import Hledger.Data.Types | ||||||
|  | import Hledger.Read.Checks | ||||||
| import Hledger.Read.Common | import Hledger.Read.Common | ||||||
| import Hledger.Read.InputOptions | import Hledger.Read.InputOptions | ||||||
| import Hledger.Read.JournalReader as JournalReader | import Hledger.Read.JournalReader as JournalReader | ||||||
|  | |||||||
							
								
								
									
										125
									
								
								hledger-lib/Hledger/Read/Checks.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										125
									
								
								hledger-lib/Hledger/Read/Checks.hs
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,125 @@ | |||||||
|  | {-| | ||||||
|  | Various additional validation checks that can be performed on a Journal. | ||||||
|  | Some are called as part of reading a file in strict mode, | ||||||
|  | others can be called only via the check command. | ||||||
|  | -} | ||||||
|  | 
 | ||||||
|  | {-# LANGUAGE OverloadedStrings #-} | ||||||
|  | {-# LANGUAGE NamedFieldPuns #-} | ||||||
|  | 
 | ||||||
|  | module Hledger.Read.Checks ( | ||||||
|  |   journalCheckAccountsDeclared, | ||||||
|  |   journalCheckCommoditiesDeclared, | ||||||
|  |   journalCheckPayeesDeclared, | ||||||
|  |   module Hledger.Read.Checks.Uniqueleafnames, | ||||||
|  | ) | ||||||
|  | where | ||||||
|  | 
 | ||||||
|  | import Data.Char (isSpace) | ||||||
|  | import Data.List (find) | ||||||
|  | import Data.Maybe | ||||||
|  | import qualified Data.Map.Strict as M | ||||||
|  | import qualified Data.Text as T | ||||||
|  | import Safe (atMay) | ||||||
|  | import Text.Printf (printf) | ||||||
|  | 
 | ||||||
|  | import Hledger.Data | ||||||
|  | import Hledger.Read.Checks.Uniqueleafnames | ||||||
|  | import Hledger.Read.Error | ||||||
|  | 
 | ||||||
|  | -- | Check that all the journal's postings are to accounts declared with | ||||||
|  | -- account directives, returning an error message otherwise. | ||||||
|  | journalCheckAccountsDeclared :: Journal -> Either String () | ||||||
|  | journalCheckAccountsDeclared j = mapM_ checkacct (journalPostings j) | ||||||
|  |   where | ||||||
|  |     checkacct p@Posting{paccount=a} | ||||||
|  |       | a `elem` journalAccountNamesDeclared j = Right () | ||||||
|  |       | otherwise = Left $  | ||||||
|  |         printf "%s:%d:%d-%d:\n%sundeclared account \"%s\"\n" f l col col2 ex a | ||||||
|  |         where | ||||||
|  |           (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols | ||||||
|  |           col  = maybe 0 fst mcols | ||||||
|  |           col2 = maybe 0 (fromMaybe 0 . snd) mcols | ||||||
|  |           finderrcols p _ _ = Just (col, Just col2) | ||||||
|  |             where | ||||||
|  |               col = 5 + if isVirtual p then 1 else 0 | ||||||
|  |               col2 = col + T.length a - 1 | ||||||
|  | 
 | ||||||
|  | -- | Check that all the commodities used in this journal's postings have been declared | ||||||
|  | -- by commodity directives, returning an error message otherwise. | ||||||
|  | journalCheckCommoditiesDeclared :: Journal -> Either String () | ||||||
|  | journalCheckCommoditiesDeclared j = mapM_ checkcommodities (journalPostings j) | ||||||
|  |   where | ||||||
|  |     checkcommodities p = | ||||||
|  |       case findundeclaredcomm p of | ||||||
|  |         Nothing -> Right () | ||||||
|  |         Just (comm, _) -> | ||||||
|  |           Left $ printf "%s:%d:%d-%d:\n%sundeclared commodity \"%s\"\n" f l col col2 ex comm | ||||||
|  |           where | ||||||
|  |             (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols | ||||||
|  |             col  = maybe 0 fst mcols | ||||||
|  |             col2 = maybe 0 (fromMaybe 0 . snd) mcols | ||||||
|  |       where | ||||||
|  |         -- Find the first undeclared commodity symbol in this posting's amount | ||||||
|  |         -- or balance assertion amount, if any. The boolean will be true if | ||||||
|  |         -- the undeclared symbol was in the posting amount. | ||||||
|  |         findundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool) | ||||||
|  |         findundeclaredcomm Posting{pamount=amt,pbalanceassertion} = | ||||||
|  |           case (findundeclared postingcomms, findundeclared assertioncomms) of | ||||||
|  |             (Just c, _) -> Just (c, True) | ||||||
|  |             (_, Just c) -> Just (c, False) | ||||||
|  |             _           -> Nothing | ||||||
|  |           where | ||||||
|  |             postingcomms = map acommodity $ filter (not . isIgnorable) $ amountsRaw amt | ||||||
|  |               where | ||||||
|  |                 -- Ignore missing amounts and zero amounts without commodity (#1767) | ||||||
|  |                 isIgnorable a = (T.null (acommodity a) && amountIsZero a) || a == missingamt | ||||||
|  |             assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]] | ||||||
|  |             findundeclared = find (`M.notMember` jcommodities j) | ||||||
|  | 
 | ||||||
|  |         -- Find the best position for an error column marker when this posting | ||||||
|  |         -- is rendered by showTransaction. | ||||||
|  |         -- Reliably locating a problem commodity symbol in showTransaction output | ||||||
|  |         -- is really tricky. Some examples: | ||||||
|  |         -- | ||||||
|  |         --     assets      "C $" -1 @ $ 2 | ||||||
|  |         --                            ^ | ||||||
|  |         --     assets      $1 = $$1 | ||||||
|  |         --                      ^ | ||||||
|  |         --     assets   [ANSI RED]$-1[ANSI RESET] | ||||||
|  |         --              ^ | ||||||
|  |         -- | ||||||
|  |         -- To simplify, we will mark the whole amount + balance assertion region, like: | ||||||
|  |         --     assets      "C $" -1 @ $ 2 | ||||||
|  |         --                 ^^^^^^^^^^^^^^ | ||||||
|  |         -- XXX refine this region when it's easy | ||||||
|  |         finderrcols p t txntxt = | ||||||
|  |           case transactionFindPostingIndex (==p) t of | ||||||
|  |             Nothing     -> Nothing | ||||||
|  |             Just pindex -> Just (amtstart, Just amtend) | ||||||
|  |               where | ||||||
|  |                 tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) | ||||||
|  |                 errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines | ||||||
|  |                 errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1)) | ||||||
|  |                 acctend = 4 + T.length (paccount p) + if isVirtual p then 2 else 0 | ||||||
|  |                 amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1 | ||||||
|  |                 amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline) | ||||||
|  | 
 | ||||||
|  | -- | Check that all the journal's transactions have payees declared with | ||||||
|  | -- payee directives, returning an error message otherwise. | ||||||
|  | journalCheckPayeesDeclared :: Journal -> Either String () | ||||||
|  | journalCheckPayeesDeclared j = mapM_ checkpayee (jtxns j) | ||||||
|  |   where | ||||||
|  |     checkpayee t | ||||||
|  |       | payee `elem` journalPayeesDeclared j = Right () | ||||||
|  |       | otherwise = Left $ | ||||||
|  |         printf "%s:%d:%d-%d:\n%sundeclared payee \"%s\"\n" f l col col2 ex payee | ||||||
|  |       where | ||||||
|  |         payee = transactionPayee t | ||||||
|  |         (f,l,mcols,ex) = makeTransactionErrorExcerpt t finderrcols | ||||||
|  |         col  = maybe 0 fst mcols | ||||||
|  |         col2 = maybe 0 (fromMaybe 0 . snd) mcols | ||||||
|  |         finderrcols t = Just (col, Just col2) | ||||||
|  |           where | ||||||
|  |             col = T.length (showTransactionLineFirstPart t) + 2 | ||||||
|  |             col2 = col + T.length (transactionPayee t) - 1 | ||||||
| @ -1,7 +1,7 @@ | |||||||
| {-# LANGUAGE NamedFieldPuns    #-} | {-# LANGUAGE NamedFieldPuns    #-} | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| 
 | 
 | ||||||
| module Hledger.Cli.Commands.Check.Uniqueleafnames ( | module Hledger.Read.Checks.Uniqueleafnames ( | ||||||
|   journalCheckUniqueleafnames |   journalCheckUniqueleafnames | ||||||
| ) | ) | ||||||
| where | where | ||||||
| @ -10,10 +10,12 @@ import Data.Function (on) | |||||||
| import Data.List (groupBy, sortBy) | import Data.List (groupBy, sortBy) | ||||||
| import Data.Text (Text) | import Data.Text (Text) | ||||||
| import qualified Data.Text as T | import qualified Data.Text as T | ||||||
| import Hledger |  | ||||||
| import Text.Printf (printf) | import Text.Printf (printf) | ||||||
| import Data.Maybe (fromMaybe) | import Data.Maybe (fromMaybe) | ||||||
| 
 | 
 | ||||||
|  | import Hledger.Data | ||||||
|  | import Hledger.Read.Error | ||||||
|  | 
 | ||||||
| -- | Check that all the journal's postings are to accounts with a unique leaf name. | -- | Check that all the journal's postings are to accounts with a unique leaf name. | ||||||
| -- Otherwise, return an error message for the first offending posting. | -- Otherwise, return an error message for the first offending posting. | ||||||
| journalCheckUniqueleafnames :: Journal -> Either String () | journalCheckUniqueleafnames :: Journal -> Either String () | ||||||
| @ -37,9 +37,6 @@ module Hledger.Read.Common ( | |||||||
|   parseAndFinaliseJournal, |   parseAndFinaliseJournal, | ||||||
|   initialiseAndParseJournal, |   initialiseAndParseJournal, | ||||||
|   journalFinalise, |   journalFinalise, | ||||||
|   journalCheckAccountsDeclared, |  | ||||||
|   journalCheckCommoditiesDeclared, |  | ||||||
|   journalCheckPayeesDeclared, |  | ||||||
|   journalAddForecast, |   journalAddForecast, | ||||||
|   journalAddAutoPostings, |   journalAddAutoPostings, | ||||||
|   setYear, |   setYear, | ||||||
| @ -112,8 +109,6 @@ module Hledger.Read.Common ( | |||||||
|   skipNonNewlineSpaces, |   skipNonNewlineSpaces, | ||||||
|   skipNonNewlineSpaces1, |   skipNonNewlineSpaces1, | ||||||
|   aliasesFromOpts, |   aliasesFromOpts, | ||||||
|   makeTransactionErrorExcerpt, |  | ||||||
|   makePostingErrorExcerpt, |  | ||||||
| 
 | 
 | ||||||
|   -- * tests |   -- * tests | ||||||
|   tests_Common, |   tests_Common, | ||||||
| @ -152,9 +147,8 @@ import Hledger.Data | |||||||
| import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery) | import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery) | ||||||
| import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts) | import Hledger.Reports.ReportOptions (ReportOpts(..), queryFromFlags, rawOptsToReportOpts) | ||||||
| import Hledger.Utils | import Hledger.Utils | ||||||
| import Text.Printf (printf) |  | ||||||
| import Hledger.Read.InputOptions | import Hledger.Read.InputOptions | ||||||
| import Safe (atMay) | import Hledger.Read.Checks (journalCheckAccountsDeclared, journalCheckCommoditiesDeclared) | ||||||
| 
 | 
 | ||||||
| --- ** doctest setup | --- ** doctest setup | ||||||
| -- $setup | -- $setup | ||||||
| @ -359,180 +353,6 @@ journalAddForecast (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns} | |||||||
|       . concatMap (`runPeriodicTransaction` forecastspan) |       . concatMap (`runPeriodicTransaction` forecastspan) | ||||||
|       $ jperiodictxns j |       $ jperiodictxns j | ||||||
| 
 | 
 | ||||||
| -- | Check that all the journal's transactions have payees declared with |  | ||||||
| -- payee directives, returning an error message otherwise. |  | ||||||
| journalCheckPayeesDeclared :: Journal -> Either String () |  | ||||||
| journalCheckPayeesDeclared j = mapM_ checkpayee (jtxns j) |  | ||||||
|   where |  | ||||||
|     checkpayee t |  | ||||||
|       | payee `elem` journalPayeesDeclared j = Right () |  | ||||||
|       | otherwise = Left $ |  | ||||||
|         printf "%s:%d:%d-%d:\n%sundeclared payee \"%s\"\n" f l col col2 ex payee |  | ||||||
|       where |  | ||||||
|         payee = transactionPayee t |  | ||||||
|         (f,l,mcols,ex) = makeTransactionErrorExcerpt t finderrcols |  | ||||||
|         col  = maybe 0 fst mcols |  | ||||||
|         col2 = maybe 0 (fromMaybe 0 . snd) mcols |  | ||||||
|         finderrcols t = Just (col, Just col2) |  | ||||||
|           where |  | ||||||
|             col = T.length (showTransactionLineFirstPart t) + 2 |  | ||||||
|             col2 = col + T.length (transactionPayee t) - 1 |  | ||||||
| 
 |  | ||||||
| -- | Check that all the journal's postings are to accounts declared with |  | ||||||
| -- account directives, returning an error message otherwise. |  | ||||||
| journalCheckAccountsDeclared :: Journal -> Either String () |  | ||||||
| journalCheckAccountsDeclared j = mapM_ checkacct (journalPostings j) |  | ||||||
|   where |  | ||||||
|     checkacct p@Posting{paccount=a} |  | ||||||
|       | a `elem` journalAccountNamesDeclared j = Right () |  | ||||||
|       | otherwise = Left $  |  | ||||||
|         printf "%s:%d:%d-%d:\n%sundeclared account \"%s\"\n" f l col col2 ex a |  | ||||||
|         where |  | ||||||
|           (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols |  | ||||||
|           col  = maybe 0 fst mcols |  | ||||||
|           col2 = maybe 0 (fromMaybe 0 . snd) mcols |  | ||||||
|           finderrcols p _ _ = Just (col, Just col2) |  | ||||||
|             where |  | ||||||
|               col = 5 + if isVirtual p then 1 else 0 |  | ||||||
|               col2 = col + T.length a - 1 |  | ||||||
| 
 |  | ||||||
| -- | Check that all the commodities used in this journal's postings have been declared |  | ||||||
| -- by commodity directives, returning an error message otherwise. |  | ||||||
| journalCheckCommoditiesDeclared :: Journal -> Either String () |  | ||||||
| journalCheckCommoditiesDeclared j = mapM_ checkcommodities (journalPostings j) |  | ||||||
|   where |  | ||||||
|     checkcommodities p = |  | ||||||
|       case findundeclaredcomm p of |  | ||||||
|         Nothing -> Right () |  | ||||||
|         Just (comm, _) -> |  | ||||||
|           Left $ printf "%s:%d:%d-%d:\n%sundeclared commodity \"%s\"\n" f l col col2 ex comm |  | ||||||
|           where |  | ||||||
|             (f,l,mcols,ex) = makePostingErrorExcerpt p finderrcols |  | ||||||
|             col  = maybe 0 fst mcols |  | ||||||
|             col2 = maybe 0 (fromMaybe 0 . snd) mcols |  | ||||||
|       where |  | ||||||
|         -- Find the first undeclared commodity symbol in this posting's amount |  | ||||||
|         -- or balance assertion amount, if any. The boolean will be true if |  | ||||||
|         -- the undeclared symbol was in the posting amount. |  | ||||||
|         findundeclaredcomm :: Posting -> Maybe (CommoditySymbol, Bool) |  | ||||||
|         findundeclaredcomm Posting{pamount=amt,pbalanceassertion} = |  | ||||||
|           case (findundeclared postingcomms, findundeclared assertioncomms) of |  | ||||||
|             (Just c, _) -> Just (c, True) |  | ||||||
|             (_, Just c) -> Just (c, False) |  | ||||||
|             _           -> Nothing |  | ||||||
|           where |  | ||||||
|             postingcomms = map acommodity $ filter (not . isIgnorable) $ amountsRaw amt |  | ||||||
|               where |  | ||||||
|                 -- Ignore missing amounts and zero amounts without commodity (#1767) |  | ||||||
|                 isIgnorable a = (T.null (acommodity a) && amountIsZero a) || a == missingamt |  | ||||||
|             assertioncomms = [acommodity a | Just a <- [baamount <$> pbalanceassertion]] |  | ||||||
|             findundeclared = find (`M.notMember` jcommodities j) |  | ||||||
| 
 |  | ||||||
|         -- Find the best position for an error column marker when this posting |  | ||||||
|         -- is rendered by showTransaction. |  | ||||||
|         -- Reliably locating a problem commodity symbol in showTransaction output |  | ||||||
|         -- is really tricky. Some examples: |  | ||||||
|         -- |  | ||||||
|         --     assets      "C $" -1 @ $ 2 |  | ||||||
|         --                            ^ |  | ||||||
|         --     assets      $1 = $$1 |  | ||||||
|         --                      ^ |  | ||||||
|         --     assets   [ANSI RED]$-1[ANSI RESET] |  | ||||||
|         --              ^ |  | ||||||
|         -- |  | ||||||
|         -- To simplify, we will mark the whole amount + balance assertion region, like: |  | ||||||
|         --     assets      "C $" -1 @ $ 2 |  | ||||||
|         --                 ^^^^^^^^^^^^^^ |  | ||||||
|         finderrcols p t txntxt = |  | ||||||
|           case transactionFindPostingIndex (==p) t of |  | ||||||
|             Nothing     -> Nothing |  | ||||||
|             Just pindex -> Just (amtstart, Just amtend) |  | ||||||
|               where |  | ||||||
|                 tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) |  | ||||||
|                 errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines |  | ||||||
|                 errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1)) |  | ||||||
|                 acctend = 4 + T.length (paccount p) + if isVirtual p then 2 else 0 |  | ||||||
|                 amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1 |  | ||||||
|                 amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline) |  | ||||||
| 
 |  | ||||||
| -- | 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. |  | ||||||
| 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 |  | ||||||
|   where |  | ||||||
|     (SourcePos f tpos _) = fst $ tsourcepos t |  | ||||||
|     tl = unPos tpos |  | ||||||
|     txntxt = showTransaction t & textChomp & (<>"\n") |  | ||||||
|     merrcols = findtxnerrorcolumns t |  | ||||||
|     ex = decorateTransactionErrorExcerpt tl merrcols txntxt |  | ||||||
| 
 |  | ||||||
| -- | Add megaparsec-style left margin, line number, and optional column marker(s). |  | ||||||
| decorateTransactionErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text |  | ||||||
| decorateTransactionErrorExcerpt 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 |  | ||||||
| 
 |  | ||||||
| -- | Given a problem posting and a function calculating the best |  | ||||||
| -- column(s) for marking the error region: |  | ||||||
| -- look up error info from the parent transaction, and render the transaction |  | ||||||
| -- as a megaparsec-style excerpt, showing the original line number |  | ||||||
| -- on the problem posting's line, and a column indicator. |  | ||||||
| -- Returns the file path, line number, column(s) if known, |  | ||||||
| -- and the rendered excerpt, or as much of these as is possible. |  | ||||||
| makePostingErrorExcerpt :: Posting -> (Posting -> Transaction -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) |  | ||||||
| makePostingErrorExcerpt p findpostingerrorcolumns = |  | ||||||
|   case ptransaction p of |  | ||||||
|     Nothing -> ("-", 0, Nothing, "") |  | ||||||
|     Just t  -> (f, errabsline, merrcols, ex) |  | ||||||
|       where |  | ||||||
|         (SourcePos f tl _) = fst $ tsourcepos t |  | ||||||
|         tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) |  | ||||||
|         mpindex = transactionFindPostingIndex (==p) t |  | ||||||
|         errrelline = maybe 0 (tcommentlines+) mpindex   -- XXX doesn't count posting coment lines |  | ||||||
|         errabsline = unPos tl + errrelline |  | ||||||
|         txntxt = showTransaction t & textChomp & (<>"\n") |  | ||||||
|         merrcols = findpostingerrorcolumns p t txntxt |  | ||||||
|         ex = decoratePostingErrorExcerpt errabsline errrelline merrcols txntxt |  | ||||||
| 
 |  | ||||||
| -- | Add megaparsec-style left margin, line number, and optional column marker(s). |  | ||||||
| decoratePostingErrorExcerpt :: Int -> Int -> Maybe (Int, Maybe Int) -> Text -> Text |  | ||||||
| decoratePostingErrorExcerpt absline relline mcols txt = |  | ||||||
|   T.unlines $ js' <> ks' <> colmarkerline <> ms' |  | ||||||
|   where |  | ||||||
|     (ls,ms) = splitAt (relline+1) $ T.lines txt |  | ||||||
|     (js,ks) = splitAt (length ls - 1) ls |  | ||||||
|     (js',ks') = case ks of |  | ||||||
|       [k] -> (map (lineprefix<>) js, [T.pack (show absline) <> " | " <> k]) |  | ||||||
|       _   -> ([], []) |  | ||||||
|     ms' = map (lineprefix<>) ms |  | ||||||
|     colmarkerline = |  | ||||||
|       [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^" |  | ||||||
|       | Just (col, mendcol) <- [mcols] |  | ||||||
|       , let regionw = 1 + maybe 0 (subtract col) mendcol |  | ||||||
|       ] |  | ||||||
|     lineprefix = T.replicate marginw " " <> "| " |  | ||||||
|       where  marginw = length (show absline) + 1 |  | ||||||
| 
 |  | ||||||
| -- | Find the 1-based index of the first posting in this transaction |  | ||||||
| -- satisfying the given predicate. |  | ||||||
| transactionFindPostingIndex :: (Posting -> Bool) -> Transaction -> Maybe Int |  | ||||||
| transactionFindPostingIndex ppredicate =  |  | ||||||
|   fmap fst . find (ppredicate.snd) . zip [1..] . tpostings |  | ||||||
| 
 |  | ||||||
| setYear :: Year -> JournalParser m () | setYear :: Year -> JournalParser m () | ||||||
| setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) | setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) | ||||||
| 
 | 
 | ||||||
|  | |||||||
							
								
								
									
										99
									
								
								hledger-lib/Hledger/Read/Error.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										99
									
								
								hledger-lib/Hledger/Read/Error.hs
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,99 @@ | |||||||
|  | {-| | ||||||
|  | Helpers for making error messages. | ||||||
|  | -} | ||||||
|  | 
 | ||||||
|  | {-# LANGUAGE OverloadedStrings #-} | ||||||
|  | 
 | ||||||
|  | module Hledger.Read.Error ( | ||||||
|  |   makeTransactionErrorExcerpt, | ||||||
|  |   makePostingErrorExcerpt, | ||||||
|  |   transactionFindPostingIndex, | ||||||
|  | ) | ||||||
|  | where | ||||||
|  | 
 | ||||||
|  | import Data.Function ((&)) | ||||||
|  | import Data.List (find) | ||||||
|  | import Data.Text (Text) | ||||||
|  | import qualified Data.Text as T | ||||||
|  | 
 | ||||||
|  | import Hledger.Data | ||||||
|  | import Hledger.Utils | ||||||
|  | 
 | ||||||
|  | -- | 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. | ||||||
|  | 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 | ||||||
|  |   where | ||||||
|  |     (SourcePos f tpos _) = fst $ tsourcepos t | ||||||
|  |     tl = unPos tpos | ||||||
|  |     txntxt = showTransaction t & textChomp & (<>"\n") | ||||||
|  |     merrcols = findtxnerrorcolumns t | ||||||
|  |     ex = decorateTransactionErrorExcerpt tl merrcols txntxt | ||||||
|  | 
 | ||||||
|  | -- | Add megaparsec-style left margin, line number, and optional column marker(s). | ||||||
|  | decorateTransactionErrorExcerpt :: Int -> Maybe (Int, Maybe Int) -> Text -> Text | ||||||
|  | decorateTransactionErrorExcerpt 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 | ||||||
|  | 
 | ||||||
|  | -- | Given a problem posting and a function calculating the best | ||||||
|  | -- column(s) for marking the error region: | ||||||
|  | -- look up error info from the parent transaction, and render the transaction | ||||||
|  | -- as a megaparsec-style excerpt, showing the original line number | ||||||
|  | -- on the problem posting's line, and a column indicator. | ||||||
|  | -- Returns the file path, line number, column(s) if known, | ||||||
|  | -- and the rendered excerpt, or as much of these as is possible. | ||||||
|  | makePostingErrorExcerpt :: Posting -> (Posting -> Transaction -> Text -> Maybe (Int, Maybe Int)) -> (FilePath, Int, Maybe (Int, Maybe Int), Text) | ||||||
|  | makePostingErrorExcerpt p findpostingerrorcolumns = | ||||||
|  |   case ptransaction p of | ||||||
|  |     Nothing -> ("-", 0, Nothing, "") | ||||||
|  |     Just t  -> (f, errabsline, merrcols, ex) | ||||||
|  |       where | ||||||
|  |         (SourcePos f tl _) = fst $ tsourcepos t | ||||||
|  |         tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) | ||||||
|  |         mpindex = transactionFindPostingIndex (==p) t | ||||||
|  |         errrelline = maybe 0 (tcommentlines+) mpindex   -- XXX doesn't count posting coment lines | ||||||
|  |         errabsline = unPos tl + errrelline | ||||||
|  |         txntxt = showTransaction t & textChomp & (<>"\n") | ||||||
|  |         merrcols = findpostingerrorcolumns p t txntxt | ||||||
|  |         ex = decoratePostingErrorExcerpt errabsline errrelline merrcols txntxt | ||||||
|  | 
 | ||||||
|  | -- | Add megaparsec-style left margin, line number, and optional column marker(s). | ||||||
|  | decoratePostingErrorExcerpt :: Int -> Int -> Maybe (Int, Maybe Int) -> Text -> Text | ||||||
|  | decoratePostingErrorExcerpt absline relline mcols txt = | ||||||
|  |   T.unlines $ js' <> ks' <> colmarkerline <> ms' | ||||||
|  |   where | ||||||
|  |     (ls,ms) = splitAt (relline+1) $ T.lines txt | ||||||
|  |     (js,ks) = splitAt (length ls - 1) ls | ||||||
|  |     (js',ks') = case ks of | ||||||
|  |       [k] -> (map (lineprefix<>) js, [T.pack (show absline) <> " | " <> k]) | ||||||
|  |       _   -> ([], []) | ||||||
|  |     ms' = map (lineprefix<>) ms | ||||||
|  |     colmarkerline = | ||||||
|  |       [lineprefix <> T.replicate (col-1) " " <> T.replicate regionw "^" | ||||||
|  |       | Just (col, mendcol) <- [mcols] | ||||||
|  |       , let regionw = 1 + maybe 0 (subtract col) mendcol | ||||||
|  |       ] | ||||||
|  |     lineprefix = T.replicate marginw " " <> "| " | ||||||
|  |       where  marginw = length (show absline) + 1 | ||||||
|  | 
 | ||||||
|  | -- | Find the 1-based index of the first posting in this transaction | ||||||
|  | -- satisfying the given predicate. | ||||||
|  | transactionFindPostingIndex :: (Posting -> Bool) -> Transaction -> Maybe Int | ||||||
|  | transactionFindPostingIndex ppredicate =  | ||||||
|  |   fmap fst . find (ppredicate.snd) . zip [1..] . tpostings | ||||||
|  | 
 | ||||||
| @ -63,6 +63,8 @@ library | |||||||
|       Hledger.Data.Valuation |       Hledger.Data.Valuation | ||||||
|       Hledger.Query |       Hledger.Query | ||||||
|       Hledger.Read |       Hledger.Read | ||||||
|  |       Hledger.Read.Checks | ||||||
|  |       Hledger.Read.Checks.Uniqueleafnames | ||||||
|       Hledger.Read.Common |       Hledger.Read.Common | ||||||
|       Hledger.Read.CsvReader |       Hledger.Read.CsvReader | ||||||
|       Hledger.Read.JournalReader |       Hledger.Read.JournalReader | ||||||
| @ -86,6 +88,7 @@ library | |||||||
|       Hledger.Utils.Text |       Hledger.Utils.Text | ||||||
|       Text.Tabular.AsciiWide |       Text.Tabular.AsciiWide | ||||||
|   other-modules: |   other-modules: | ||||||
|  |       Hledger.Read.Error | ||||||
|       Text.Megaparsec.Custom |       Text.Megaparsec.Custom | ||||||
|       Text.WideString |       Text.WideString | ||||||
|       Paths_hledger_lib |       Paths_hledger_lib | ||||||
|  | |||||||
| @ -115,6 +115,8 @@ library: | |||||||
|   - Hledger.Data.Valuation |   - Hledger.Data.Valuation | ||||||
|   - Hledger.Query |   - Hledger.Query | ||||||
|   - Hledger.Read |   - Hledger.Read | ||||||
|  |   - Hledger.Read.Checks | ||||||
|  |   - Hledger.Read.Checks.Uniqueleafnames | ||||||
|   - Hledger.Read.Common |   - Hledger.Read.Common | ||||||
|   - Hledger.Read.CsvReader |   - Hledger.Read.CsvReader | ||||||
|   - Hledger.Read.JournalReader |   - Hledger.Read.JournalReader | ||||||
|  | |||||||
| @ -18,7 +18,6 @@ import System.Console.CmdArgs.Explicit | |||||||
| import Hledger | import Hledger | ||||||
| import Hledger.Cli.CliOptions | import Hledger.Cli.CliOptions | ||||||
| import Hledger.Cli.Commands.Check.Ordereddates (journalCheckOrdereddates) | import Hledger.Cli.Commands.Check.Ordereddates (journalCheckOrdereddates) | ||||||
| import Hledger.Cli.Commands.Check.Uniqueleafnames (journalCheckUniqueleafnames) |  | ||||||
| 
 | 
 | ||||||
| checkmode :: Mode RawOpts | checkmode :: Mode RawOpts | ||||||
| checkmode = hledgerCommandMode | checkmode = hledgerCommandMode | ||||||
|  | |||||||
| @ -9,7 +9,9 @@ import Control.Monad (forM) | |||||||
| import Data.List (groupBy) | import Data.List (groupBy) | ||||||
| import Text.Printf (printf) | import Text.Printf (printf) | ||||||
| import Data.Maybe (fromMaybe) | import Data.Maybe (fromMaybe) | ||||||
|  | import Hledger.Read.Error (makeTransactionErrorExcerpt) | ||||||
| 
 | 
 | ||||||
|  | -- XXX does this need CliOpts ? Can it move to Hledger.Read.Checks ? | ||||||
| journalCheckOrdereddates :: CliOpts -> Journal -> Either String () | journalCheckOrdereddates :: CliOpts -> Journal -> Either String () | ||||||
| journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do | journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do | ||||||
|   let  |   let  | ||||||
| @ -18,7 +20,7 @@ journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do | |||||||
|     filets =  |     filets =  | ||||||
|       groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ |       groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ | ||||||
|       filter (_rsQuery rspec `matchesTransaction`) $ |       filter (_rsQuery rspec `matchesTransaction`) $ | ||||||
|       jtxns $ journalApplyValuationFromOpts rspec j |       jtxns $ journalApplyValuationFromOpts rspec j  -- XXX why apply valuation ? | ||||||
|     checkunique = False -- boolopt "unique" rawopts  XXX was supported by checkdates command |     checkunique = False -- boolopt "unique" rawopts  XXX was supported by checkdates command | ||||||
|     compare a b = if checkunique then getdate a < getdate b else getdate a <= getdate b |     compare a b = if checkunique then getdate a < getdate b else getdate a <= getdate b | ||||||
|       where getdate = transactionDateFn ropts |       where getdate = transactionDateFn ropts | ||||||
|  | |||||||
| @ -111,7 +111,6 @@ library | |||||||
|       Hledger.Cli.Commands.Cashflow |       Hledger.Cli.Commands.Cashflow | ||||||
|       Hledger.Cli.Commands.Check |       Hledger.Cli.Commands.Check | ||||||
|       Hledger.Cli.Commands.Check.Ordereddates |       Hledger.Cli.Commands.Check.Ordereddates | ||||||
|       Hledger.Cli.Commands.Check.Uniqueleafnames |  | ||||||
|       Hledger.Cli.Commands.Close |       Hledger.Cli.Commands.Close | ||||||
|       Hledger.Cli.Commands.Codes |       Hledger.Cli.Commands.Codes | ||||||
|       Hledger.Cli.Commands.Commodities |       Hledger.Cli.Commands.Commodities | ||||||
|  | |||||||
| @ -158,7 +158,6 @@ library: | |||||||
|   - Hledger.Cli.Commands.Cashflow |   - Hledger.Cli.Commands.Cashflow | ||||||
|   - Hledger.Cli.Commands.Check |   - Hledger.Cli.Commands.Check | ||||||
|   - Hledger.Cli.Commands.Check.Ordereddates |   - Hledger.Cli.Commands.Check.Ordereddates | ||||||
|   - Hledger.Cli.Commands.Check.Uniqueleafnames |  | ||||||
|   - Hledger.Cli.Commands.Close |   - Hledger.Cli.Commands.Close | ||||||
|   - Hledger.Cli.Commands.Codes |   - Hledger.Cli.Commands.Codes | ||||||
|   - Hledger.Cli.Commands.Commodities |   - Hledger.Cli.Commands.Commodities | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user