From 5dedec83dacbacc21eda2c9a3c9983c0308cae22 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Mon, 21 Dec 2020 23:10:07 +1100 Subject: [PATCH] lib: showamountquantity shows directly, rather than parsing string output of show instance for Quantity. --- hledger-lib/Hledger/Data/Amount.hs | 67 ++++++++++++++++-------------- hledger-lib/Hledger/Utils/Text.hs | 22 ++++++++++ 2 files changed, 58 insertions(+), 31 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index e77cb557d..3e3d7638f 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -130,15 +130,16 @@ module Hledger.Data.Amount ( ) where import Control.Monad (foldM) -import Data.Char (isDigit) -import Data.Decimal (decimalPlaces, normalizeDecimal, roundTo) +import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Function (on) import Data.List (genericSplitAt, groupBy, intercalate, mapAccumL, partition, sortBy) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.Map as M import Data.Map (findWithDefault) import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TB import Data.Word (Word8) import Safe (lastDef, lastMay) import Text.Printf (printf) @@ -156,7 +157,6 @@ deriving instance Show MarketPrice -- | Default amount style amountstyle = AmountStyle L False (Precision 0) (Just '.') Nothing - ------------------------------------------------------------------------------- -- Amount @@ -386,7 +386,7 @@ showAmountHelper showzerocommodity a@Amount{acommodity=c, aprice=mp, astyle=Amou L -> printf "%s%s%s%s" (T.unpack c') space quantity' price R -> printf "%s%s%s%s" quantity' space (T.unpack c') price where - quantity = showamountquantity a + quantity = wbUnpack $ showamountquantity a (quantity',c') | amountLooksZero a && not showzerocommodity = ("0","") | otherwise = (quantity, quoteCommoditySymbolIfNeeded c) space = if not (T.null c') && ascommodityspaced then " " else "" :: String @@ -402,35 +402,40 @@ showAmountDebug :: Amount -> String showAmountDebug Amount{acommodity="AUTO"} = "(missing)" showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showAmountPriceDebug aprice) (show astyle) --- | Get the string representation of the number part of of an amount, --- using the display settings from its commodity. -showamountquantity :: Amount -> String +-- | Get a Text Builder for the string representation of the number part of of an amount, +-- using the display settings from its commodity. Also returns the width of the +-- number. +showamountquantity :: Amount -> WideBuilder showamountquantity amt@Amount{astyle=AmountStyle{asdecimalpoint=mdec, asdigitgroups=mgrps}} = - punctuatenumber (fromMaybe '.' mdec) mgrps . show $ amountRoundedQuantity amt - --- | Replace a number string's decimal mark with the specified --- character, and add the specified digit group marks. The last digit --- group will be repeated as needed. -punctuatenumber :: Char -> Maybe DigitGroupStyle -> String -> String -punctuatenumber dec mgrps s = sign ++ reverse (applyDigitGroupStyle mgrps (reverse int)) ++ frac'' - where - (sign,num) = break isDigit s - (int,frac) = break (=='.') num - frac' = dropWhile (=='.') frac - frac'' | null frac' = "" - | otherwise = dec:frac' - -applyDigitGroupStyle :: Maybe DigitGroupStyle -> String -> String -applyDigitGroupStyle Nothing s = s -applyDigitGroupStyle (Just (DigitGroups c gs)) s = addseps (repeatLast gs) s + signB <> intB <> fracB where - addseps [] s = s - addseps (g:gs) s - | toInteger (length s) <= toInteger g = s - | otherwise = let (part,rest) = genericSplitAt g s - in part ++ c : addseps gs rest - repeatLast [] = [] - repeatLast gs = init gs ++ repeat (last gs) + Decimal e n = amountRoundedQuantity amt + + strN = show $ abs n + len = length strN + intLen = max 1 $ len - fromIntegral e + dec = fromMaybe '.' mdec + padded = replicate (fromIntegral e + 1 - len) '0' ++ strN + (intPart, fracPart) = splitAt intLen padded + + intB = applyDigitGroupStyle mgrps intLen $ if e == 0 then strN else intPart + signB = if n < 0 then WideBuilder (TB.singleton '-') 1 else mempty + fracB = if e > 0 then WideBuilder (TB.singleton dec <> TB.fromString fracPart) (fromIntegral e + 1) else mempty + +-- | Split a string representation into chunks according to DigitGroupStyle, +-- returning a Text builder and the number of separators used. +applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> String -> WideBuilder +applyDigitGroupStyle Nothing l s = WideBuilder (TB.fromString s) l +applyDigitGroupStyle (Just (DigitGroups _ [])) l s = WideBuilder (TB.fromString s) l +applyDigitGroupStyle (Just (DigitGroups c (g:gs))) l s = addseps (g:|gs) (toInteger l) s + where + addseps (g:|gs) l s + | l' > 0 = addseps gs' l' rest <> WideBuilder (TB.singleton c <> TB.fromString part) (fromIntegral g + 1) + | otherwise = WideBuilder (TB.fromString s) (fromInteger l) + where + (rest, part) = genericSplitAt l' s + gs' = fromMaybe (g:|[]) $ nonEmpty gs + l' = l - toInteger g -- like journalCanonicaliseAmounts -- | Canonicalise an amount's display style using the provided commodity style map. diff --git a/hledger-lib/Hledger/Utils/Text.hs b/hledger-lib/Hledger/Utils/Text.hs index d38a8a8de..78438d0c7 100644 --- a/hledger-lib/Hledger/Utils/Text.hs +++ b/hledger-lib/Hledger/Utils/Text.hs @@ -46,6 +46,8 @@ module Hledger.Utils.Text -- fitto, fitText, -- -- * wide-character-aware layout + WideBuilder(..), + wbUnpack, textWidth, textTakeWidth, -- fitString, @@ -66,6 +68,8 @@ import Data.Monoid #endif 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 Text.Parsec -- import Text.Printf (printf) @@ -74,6 +78,24 @@ import qualified Data.Text as T import Hledger.Utils.Test import Text.WideString (charWidth, textWidth) + +-- | Helper for constructing Builders while keeping track of text width. +data WideBuilder = WideBuilder + { wbBuilder :: !TB.Builder + , wbWidth :: !Int + } + +instance Semigroup WideBuilder where + WideBuilder x i <> WideBuilder y j = WideBuilder (x <> y) (i + j) + +instance Monoid WideBuilder where + mempty = WideBuilder mempty 0 + +-- | Unpack a WideBuilder to a String. +wbUnpack :: WideBuilder -> String +wbUnpack = TL.unpack . TB.toLazyText . wbBuilder + + -- lowercase, uppercase :: String -> String -- lowercase = map toLower -- uppercase = map toUpper