From 07a7c3d3a82c10dc7e18ee1d0bf01840442d5678 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Fri, 25 Dec 2020 16:38:26 +1100 Subject: [PATCH] lib: Use Text and Text builder only in postingAsLines. --- hledger-lib/Hledger/Data/Amount.hs | 1 + hledger-lib/Hledger/Data/Journal.hs | 20 ++--- hledger-lib/Hledger/Data/Timeclock.hs | 13 ++-- hledger-lib/Hledger/Data/Transaction.hs | 74 +++++++++++-------- .../Hledger/Data/TransactionModifier.hs | 3 +- hledger-lib/Hledger/Read/Common.hs | 16 ++-- hledger-lib/Hledger/Utils/String.hs | 13 ---- hledger-lib/Hledger/Utils/Text.hs | 13 ++++ hledger/Hledger/Cli/Commands/Add.hs | 2 +- .../Cli/Commands/Check/Ordereddates.hs | 18 ++--- hledger/Hledger/Cli/Commands/Close.hs | 4 +- hledger/Hledger/Cli/Commands/Diff.hs | 14 ++-- 12 files changed, 102 insertions(+), 89 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index c2411092e..ef9444f39 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -125,6 +125,7 @@ module Hledger.Data.Amount ( showMixedAmountElided, showMixedAmountWithZeroCommodity, showMixed, + showMixedLines, setMixedAmountPrecision, canonicaliseMixedAmount, -- * misc. diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index c9fdee2fd..5351ca9c4 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -87,20 +87,20 @@ module Hledger.Data.Journal ( tests_Journal, ) where -import Control.Monad -import Control.Monad.Except -import Control.Monad.Extra + +import Control.Monad.Except (ExceptT(..), runExceptT, throwError) +import Control.Monad.Extra (whenM) import Control.Monad.Reader as R -import Control.Monad.ST -import Data.Array.ST +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STArray, getElems, newListArray, writeArray) import Data.Default (Default(..)) import Data.Function ((&)) import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H -import Data.List +import Data.List (find, sortOn) import Data.List.Extra (groupSort, nubSort) import qualified Data.Map as M -import Data.Maybe +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif @@ -108,10 +108,10 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Safe (headMay, headDef) -import Data.Time.Calendar -import Data.Tree +import Data.Time.Calendar (Day, addDays, fromGregorian) +import Data.Tree (Tree, flatten) import System.Time (ClockTime(TOD)) -import Text.Printf +import Text.Printf (printf) import Hledger.Utils import Hledger.Data.Types diff --git a/hledger-lib/Hledger/Data/Timeclock.hs b/hledger-lib/Hledger/Data/Timeclock.hs index 06072df9b..9b51ad8b1 100644 --- a/hledger-lib/Hledger/Data/Timeclock.hs +++ b/hledger-lib/Hledger/Data/Timeclock.hs @@ -14,14 +14,15 @@ module Hledger.Data.Timeclock ( ) where -import Data.Maybe +import Data.Maybe (fromMaybe) -- import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format -import Data.Time.LocalTime -import Text.Printf +import Data.Time.Calendar (addDays) +import Data.Time.Clock (addUTCTime, getCurrentTime) +import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM) +import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), getCurrentTimeZone, + localTimeToUTC, midnight, utc, utcToLocalTime) +import Text.Printf (printf) import Hledger.Utils import Hledger.Data.Types diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 4042ee49e..c65de1823 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -44,8 +44,6 @@ module Hledger.Data.Transaction ( -- * rendering showTransaction, showTransactionOneLineAmounts, - showTransactionUnelided, - showTransactionUnelidedOneLineAmounts, -- showPostingLine, showPostingLines, -- * GenericSourcePos @@ -58,11 +56,14 @@ module Hledger.Data.Transaction ( ) where +import Data.Default (def) import Data.List (intercalate, partition) import Data.List.Extra (nubSort) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day, fromGregorian) import qualified Data.Map as M @@ -72,6 +73,8 @@ import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Amount import Hledger.Data.Valuation +import Text.Tabular +import Text.Tabular.AsciiWide sourceFilePath :: GenericSourcePos -> FilePath sourceFilePath = \case @@ -149,30 +152,21 @@ are displayed as multiple similar postings, one per commodity. (Normally does not happen with this function). -} showTransaction :: Transaction -> Text -showTransaction = showTransactionHelper False - --- | Deprecated alias for 'showTransaction' -showTransactionUnelided :: Transaction -> Text -showTransactionUnelided = showTransaction -- TODO: drop it +showTransaction = TL.toStrict . TB.toLazyText . showTransactionHelper False -- | Like showTransaction, but explicit multi-commodity amounts -- are shown on one line, comma-separated. In this case the output will -- not be parseable journal syntax. showTransactionOneLineAmounts :: Transaction -> Text -showTransactionOneLineAmounts = showTransactionHelper True - --- | Deprecated alias for 'showTransactionOneLineAmounts' -showTransactionUnelidedOneLineAmounts :: Transaction -> Text -showTransactionUnelidedOneLineAmounts = showTransactionOneLineAmounts -- TODO: drop it +showTransactionOneLineAmounts = TL.toStrict . TB.toLazyText . showTransactionHelper True -- | Helper for showTransaction*. -showTransactionHelper :: Bool -> Transaction -> Text +showTransactionHelper :: Bool -> Transaction -> TB.Builder showTransactionHelper onelineamounts t = - T.unlines $ - descriptionline - : newlinecomments - ++ (postingsAsLines onelineamounts (tpostings t)) - ++ [""] + TB.fromText descriptionline <> newline + <> foldMap ((<> newline) . TB.fromText) newlinecomments + <> foldMap ((<> newline) . TB.fromText) (postingsAsLines onelineamounts $ tpostings t) + <> newline where descriptionline = T.stripEnd $ T.concat [date, status, code, desc, samelinecomment] date = showDate (tdate t) <> maybe "" (("="<>) . showDate) (tdate2 t) @@ -184,6 +178,7 @@ showTransactionHelper onelineamounts t = (samelinecomment, newlinecomments) = case renderCommentLines (tcomment t) of [] -> ("",[]) c:cs -> (c,cs) + newline = TB.singleton '\n' -- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. @@ -238,15 +233,24 @@ postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamoun -- This is used to align the amounts of a transaction's postings. -- postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [Text] -postingAsLines elideamount onelineamounts pstoalignwith p = concat [ - postingblock - ++ newlinecomments - | postingblock <- postingblocks] +postingAsLines elideamount onelineamounts pstoalignwith p = + concatMap (++ newlinecomments) postingblocks where - postingblocks = [map (T.stripEnd . T.pack) . lines $ - concatTopPadded [T.unpack statusandaccount, " ", amt, assertion, T.unpack samelinecomment] + -- This needs to be converted to strict Text in order to strip trailing + -- spaces. This adds a small amount of inefficiency, and the only difference + -- is whether there are trailing spaces in print (and related) reports. This + -- could be removed and we could just keep everything as a Text Builder, but + -- would require adding trailing spaces to 42 failing tests. + postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ + render [ alignCell BottomLeft statusandaccount + , alignCell BottomLeft " " + , Cell BottomLeft [amt] + , Cell BottomLeft [assertion] + , alignCell BottomLeft samelinecomment + ] | amt <- shownAmounts] - assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p + render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header + assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p statusandaccount = lineIndent . fitText (Just $ minwidth) Nothing False True $ pstatusandacct p where -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned @@ -259,8 +263,8 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [ -- currently prices are considered part of the amount string when right-aligning amounts shownAmounts - | elideamount || null (amounts $ pamount p) = [""] - | otherwise = lines . wbUnpack . showMixed displayopts $ pamount p + | elideamount || null (amounts $ pamount p) = [mempty] + | otherwise = showMixedLines displayopts $ pamount p where displayopts = noColour{displayOneLine=onelineamounts, displayMinWidth = Just amtwidth, displayNormalised=False} amtwidth = maximum $ 12 : map (wbWidth . showMixed displayopts{displayMinWidth=Nothing} . pamount) pstoalignwith -- min. 12 for backwards compatibility @@ -270,9 +274,13 @@ postingAsLines elideamount onelineamounts pstoalignwith p = concat [ c:cs -> (c,cs) -- | Render a balance assertion, as the =[=][*] symbol and expected amount. -showBalanceAssertion :: BalanceAssertion -> [Char] +showBalanceAssertion :: BalanceAssertion -> WideBuilder showBalanceAssertion BalanceAssertion{..} = - "=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount + singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True} baamount + where + eq = if batotal then singleton '=' else mempty + ast = if bainclusive then singleton '*' else mempty + singleton c = WideBuilder (TB.singleton c) 1 -- | Render a posting, simply. Used in balance assertion errors. -- showPostingLine p = @@ -423,7 +431,9 @@ transactionBalanceError t errs = annotateErrorWithTransaction :: Transaction -> String -> String annotateErrorWithTransaction t s = - unlines [showGenericSourcePos $ tsourcepos t, s, T.unpack . T.stripEnd $ showTransaction t] + unlines [ showGenericSourcePos $ tsourcepos t, s + , T.unpack . T.stripEnd $ showTransaction t + ] -- | Infer up to one missing amount for this transactions's real postings, and -- likewise for its balanced virtual postings, if needed; or return an error @@ -769,7 +779,7 @@ tests_Transaction = [posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?= (T.unlines ["2007-01-28 coopportunity", " expenses:food:groceries", ""]) , test "show a transaction with a priced commodityless amount" $ - (T.unpack $ showTransaction + (showTransaction (txnTieKnot $ Transaction 0 @@ -785,7 +795,7 @@ tests_Transaction = [ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` Precision 0)]} , posting {paccount = "b", pamount = missingmixedamt} ])) @?= - (unlines ["2010-01-01 x", " a 1 @ $2", " b", ""]) + (T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""]) ] , tests "balanceTransaction" [ test "detect unbalanced entry, sign error" $ diff --git a/hledger-lib/Hledger/Data/TransactionModifier.hs b/hledger-lib/Hledger/Data/TransactionModifier.hs index cabe79b7d..f11dbf5ce 100644 --- a/hledger-lib/Hledger/Data/TransactionModifier.hs +++ b/hledger-lib/Hledger/Data/TransactionModifier.hs @@ -62,7 +62,8 @@ modifyTransactions d tmods ts = do -- postings when certain other postings are present. -- -- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]} --- >>> test = either putStr (putStr.T.unpack.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate +-- >>> import qualified Data.Text.IO as T +-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate -- >>> test $ TransactionModifier "" ["pong" `post` usd 2] -- 0000-01-01 -- ping $1.00 diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index d938e8c73..363b89e03 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -379,11 +379,11 @@ journalCheckPayeesDeclared j = sequence_ $ map checkpayee $ jtxns j where checkpayee t | p `elem` ps = Right () - | otherwise = Left $ + | otherwise = Left $ printf "undeclared payee \"%s\"\nat: %s\n\n%s" - (T.unpack p) + (T.unpack p) (showGenericSourcePos $ tsourcepos t) - (linesPrepend2 "> " " " $ chomp1 $ showTransaction t) + (linesPrepend2 "> " " " . (<>"\n") . textChomp $ showTransaction t) where p = transactionPayee t ps = journalPayeesDeclared j @@ -397,11 +397,11 @@ journalCheckAccountsDeclared j = sequence_ $ map checkacct $ journalPostings j | paccount `elem` as = Right () | otherwise = Left $ (printf "undeclared account \"%s\"\n" (T.unpack paccount)) - ++ case ptransaction of + ++ case ptransaction of Nothing -> "" Just t -> printf "in transaction at: %s\n\n%s" (showGenericSourcePos $ tsourcepos t) - (linesPrepend " " $ chomp1 $ showTransaction t) + (linesPrepend " " . (<>"\n") . textChomp $ showTransaction t) where as = journalAccountNamesDeclared j @@ -416,13 +416,13 @@ journalCheckCommoditiesDeclared j = Nothing -> Right () Just c -> Left $ (printf "undeclared commodity \"%s\"\n" (T.unpack c)) - ++ case ptransaction of + ++ case ptransaction of Nothing -> "" Just t -> printf "in transaction at: %s\n\n%s" (showGenericSourcePos $ tsourcepos t) - (linesPrepend " " $ chomp1 $ showTransaction t) + (linesPrepend " " . (<>"\n") . textChomp $ showTransaction t) where - mfirstundeclaredcomm = + mfirstundeclaredcomm = headMay $ filter (not . (`elem` cs)) $ catMaybes $ (acommodity . baamount <$> pbalanceassertion) : (map (Just . acommodity) . filter (/= missingamt) $ amounts pamount) diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index bdbe65402..281a5cd7c 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -38,8 +38,6 @@ module Hledger.Utils.String ( padright, cliptopleft, fitto, - linesPrepend, - linesPrepend2, -- * wide-character-aware layout charWidth, strWidth, @@ -352,14 +350,3 @@ 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 diff --git a/hledger-lib/Hledger/Utils/Text.hs b/hledger-lib/Hledger/Utils/Text.hs index 35c5d12b8..fe1eb894c 100644 --- a/hledger-lib/Hledger/Utils/Text.hs +++ b/hledger-lib/Hledger/Utils/Text.hs @@ -45,6 +45,8 @@ module Hledger.Utils.Text -- cliptopleft, -- fitto, fitText, + linesPrepend, + linesPrepend2, -- -- * wide-character-aware layout WideBuilder(..), wbToText, @@ -358,6 +360,17 @@ textTakeWidth w t | not (T.null t), = T.cons c $ textTakeWidth (w-cw) (T.tail t) | otherwise = "" +-- | Add a prefix to each line of a string. +linesPrepend :: Text -> Text -> Text +linesPrepend prefix = T.unlines . map (prefix<>) . T.lines + +-- | Add a prefix to the first line of a string, +-- and a different prefix to the remaining lines. +linesPrepend2 :: Text -> Text -> Text -> Text +linesPrepend2 prefix1 prefix2 s = T.unlines $ case T.lines s of + [] -> [] + l:ls -> (prefix1<>l) : map (prefix2<>) ls + -- | Read a decimal number from a Text. Assumes the input consists only of digit -- characters. diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index 52ab691a3..284d831ea 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -469,7 +469,7 @@ ensureOneNewlineTerminated :: Text -> Text ensureOneNewlineTerminated = (<>"\n") . T.dropWhileEnd (=='\n') -- | Convert a string of journal data into a register report. -registerFromString :: Text -> IO TL.Text +registerFromString :: T.Text -> IO TL.Text registerFromString s = do j <- readJournal' s return . postingsReportAsText opts $ postingsReport rspec j diff --git a/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs b/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs index 9ef255027..d867649c4 100755 --- a/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs +++ b/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs @@ -3,9 +3,9 @@ module Hledger.Cli.Commands.Check.Ordereddates ( ) where +import qualified Data.Text as T import Hledger import Hledger.Cli.CliOptions -import Text.Printf journalCheckOrdereddates :: CliOpts -> Journal -> Either String () journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do @@ -22,16 +22,16 @@ journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do FoldAcc{fa_previous=Nothing} -> return () FoldAcc{fa_error=Nothing} -> return () FoldAcc{fa_error=Just error, fa_previous=Just previous} -> do - let + let + datestr = if date2_ ropts then "2" else "" uniquestr = if checkunique then " and/or not unique" else "" positionstr = showGenericSourcePos $ tsourcepos error - txn1str = linesPrepend " " $ showTransaction previous - txn2str = linesPrepend2 "> " " " $ showTransaction error - Left $ printf "transaction date%s is out of order%s\nat %s:\n\n%s" - (if date2_ ropts then "2" else "") - uniquestr - positionstr - (txn1str ++ txn2str) + txn1str = T.unpack . linesPrepend (T.pack " ") $ showTransaction previous + txn2str = T.unpack . linesPrepend2 (T.pack "> ") (T.pack " ") $ showTransaction error + Left $ + "Error: transaction date" <> datestr <> " is out of order" + <> uniquestr <> "\nat " <> positionstr <> ":\n\n" + <> txn1str <> txn2str data FoldAcc a b = FoldAcc { fa_error :: Maybe a diff --git a/hledger/Hledger/Cli/Commands/Close.hs b/hledger/Hledger/Cli/Commands/Close.hs index 9f019d595..fa1b78122 100755 --- a/hledger/Hledger/Cli/Commands/Close.hs +++ b/hledger/Hledger/Cli/Commands/Close.hs @@ -10,10 +10,10 @@ where import Control.Monad (when) import Data.Function (on) import Data.List (groupBy) -import Data.Maybe +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Calendar +import Data.Time.Calendar (addDays) import System.Console.CmdArgs.Explicit as C import Hledger diff --git a/hledger/Hledger/Cli/Commands/Diff.hs b/hledger/Hledger/Cli/Commands/Diff.hs index a4afce195..3b99eb080 100644 --- a/hledger/Hledger/Cli/Commands/Diff.hs +++ b/hledger/Hledger/Cli/Commands/Diff.hs @@ -12,15 +12,15 @@ module Hledger.Cli.Commands.Diff ( ,diff ) where -import Data.List -import Data.Function -import Data.Ord -import Data.Maybe -import Data.Time -import Data.Either +import Data.List ((\\), groupBy, nubBy, sortBy) +import Data.Function (on) +import Data.Ord (comparing) +import Data.Maybe (fromJust) +import Data.Time (diffDays) +import Data.Either (partitionEithers) import qualified Data.Text as T import qualified Data.Text.IO as T -import System.Exit +import System.Exit (exitFailure) import Hledger import Prelude hiding (putStrLn)