slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib,cli: Use Text Builder for Balance commands.

Browse Source
This commit is contained in:
Stephen Morgan 2020-11-09 16:54:28 +11:00
parent 089564b04b
commit 462a13cad7
28 changed files with 270 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
hledger-lib/Hledger/Data/StringFormat.hs
View File

@ -2,7 +2,10 @@
-- hledger's report item fields. The formats are used by -- hledger's report item fields. The formats are used by
-- report-specific renderers like renderBalanceReportItem. -- report-specific renderers like renderBalanceReportItem.
{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies, PackageImports #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
module Hledger.Data.StringFormat ( module Hledger.Data.StringFormat (
parseStringFormat parseStringFormat
@ -21,12 +24,13 @@ import Numeric (readDec)
import Data.Char (isPrint) import Data.Char (isPrint)
import Data.Default (Default(..)) import Data.Default (Default(..))
import Data.Maybe (isJust) import Data.Maybe (isJust)
-- import qualified Data.Text as T import Data.Text (Text)
import qualified Data.Text as T
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char (char, digitChar, string) import Text.Megaparsec.Char (char, digitChar, string)
import Hledger.Utils.Parse (SimpleStringParser) import Hledger.Utils.Parse (SimpleTextParser)
import Hledger.Utils.String (formatString) import Hledger.Utils.Text (formatText)
import Hledger.Utils.Test import Hledger.Utils.Test
-- | A format specification/template to use when rendering a report line item as text. -- | A format specification/template to use when rendering a report line item as text.
@ -53,7 +57,7 @@ data StringFormat =
deriving (Show, Eq) deriving (Show, Eq)
data StringFormatComponent = data StringFormatComponent =
FormatLiteral String -- ^ Literal text to be rendered as-is FormatLiteral Text -- ^ Literal text to be rendered as-is
| FormatField Bool | FormatField Bool
(Maybe Int) (Maybe Int)
(Maybe Int) (Maybe Int)
@ -102,14 +106,14 @@ defaultBalanceLineFormat = BottomAligned (Just 20) [
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- | Parse a string format specification, or return a parse error. -- | Parse a string format specification, or return a parse error.
parseStringFormat :: String -> Either String StringFormat parseStringFormat :: Text -> Either String StringFormat
parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of
Left y -> Left $ show y Left y -> Left $ show y
Right x -> Right x Right x -> Right x
defaultStringFormatStyle = BottomAligned defaultStringFormatStyle = BottomAligned
stringformatp :: SimpleStringParser StringFormat stringformatp :: SimpleTextParser StringFormat
stringformatp = do stringformatp = do
alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String)) alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String))
let constructor = let constructor =
@ -120,19 +124,19 @@ stringformatp = do
_ -> defaultStringFormatStyle Nothing _ -> defaultStringFormatStyle Nothing
constructor <$> many componentp constructor <$> many componentp
componentp :: SimpleStringParser StringFormatComponent componentp :: SimpleTextParser StringFormatComponent
componentp = formatliteralp <|> formatfieldp componentp = formatliteralp <|> formatfieldp
formatliteralp :: SimpleStringParser StringFormatComponent formatliteralp :: SimpleTextParser StringFormatComponent
formatliteralp = do formatliteralp = do
s <- some c s <- T.pack <$> some c
return $ FormatLiteral s return $ FormatLiteral s
where where
isPrintableButNotPercentage x = isPrint x && x /= '%' isPrintableButNotPercentage x = isPrint x && x /= '%'
c = (satisfy isPrintableButNotPercentage <?> "printable character") c = (satisfy isPrintableButNotPercentage <?> "printable character")
<|> try (string "%%" >> return '%') <|> try (string "%%" >> return '%')
formatfieldp :: SimpleStringParser StringFormatComponent formatfieldp :: SimpleTextParser StringFormatComponent
formatfieldp = do formatfieldp = do
char '%' char '%'
leftJustified <- optional (char '-') leftJustified <- optional (char '-')
@ -147,7 +151,7 @@ formatfieldp = do
Just text -> Just m where ((m,_):_) = readDec text Just text -> Just m where ((m,_):_) = readDec text
_ -> Nothing _ -> Nothing
fieldp :: SimpleStringParser ReportItemField fieldp :: SimpleTextParser ReportItemField
fieldp = do fieldp = do
try (string "account" >> return AccountField) try (string "account" >> return AccountField)
<|> try (string "depth_spacer" >> return DepthSpacerField) <|> try (string "depth_spacer" >> return DepthSpacerField)
@ -161,8 +165,8 @@ fieldp = do
formatStringTester fs value expected = actual @?= expected formatStringTester fs value expected = actual @?= expected
where where
actual = case fs of actual = case fs of
FormatLiteral l -> formatString False Nothing Nothing l FormatLiteral l -> formatText False Nothing Nothing l
FormatField leftJustify min max _ -> formatString leftJustify min max value FormatField leftJustify min max _ -> formatText leftJustify min max value
tests_StringFormat = tests "StringFormat" [ tests_StringFormat = tests "StringFormat" [
@ -176,7 +180,7 @@ tests_StringFormat = tests "StringFormat" [
formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description " formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description "
formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des" formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des"
,let s `gives` expected = test s $ parseStringFormat s @?= Right expected ,let s `gives` expected = test s $ parseStringFormat (T.pack s) @?= Right expected
in tests "parseStringFormat" [ in tests "parseStringFormat" [
"" `gives` (defaultStringFormatStyle Nothing []) "" `gives` (defaultStringFormatStyle Nothing [])
, "D" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "D"]) , "D" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "D"])

47
hledger-lib/Hledger/Reports/BudgetReport.hs
View File

@ -27,6 +27,7 @@ module Hledger.Reports.BudgetReport (
) )
where where
import Control.Arrow (first)
import Data.Decimal import Data.Decimal
import Data.Default (def) import Data.Default (def)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@ -42,12 +43,12 @@ import Safe
--import Data.Maybe --import Data.Maybe
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map (Map) import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
--import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
--import System.Console.CmdArgs.Explicit as C --import System.Console.CmdArgs.Explicit as C
--import Lucid as L --import Lucid as L
import Text.Printf (printf)
import Text.Tabular as T import Text.Tabular as T
import Text.Tabular.AsciiWide as T import Text.Tabular.AsciiWide as T
@ -68,7 +69,7 @@ type BudgetCell = (Maybe Change, Maybe BudgetGoal)
type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell
type BudgetReport = PeriodicReport DisplayName BudgetCell type BudgetReport = PeriodicReport DisplayName BudgetCell
type BudgetDisplayCell = ((String, Int), Maybe ((String, Int), Maybe (String, Int))) type BudgetDisplayCell = ((Text, Int), Maybe ((Text, Int), Maybe (Text, Int)))
-- | Calculate per-account, per-period budget (balance change) goals -- | Calculate per-account, per-period budget (balance change) goals
-- from all periodic transactions, calculate actual balance changes -- from all periodic transactions, calculate actual balance changes
@ -219,23 +220,23 @@ combineBudgetAndActual ropts j
totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change
-- | Render a budget report as plain text suitable for console output. -- | Render a budget report as plain text suitable for console output.
budgetReportAsText :: ReportOpts -> BudgetReport -> String budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text
budgetReportAsText ropts@ReportOpts{..} budgetr = budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
title ++ "\n\n" ++ TB.fromText title <> TB.fromText "\n\n" <>
renderTable def{tableBorders=False,prettyTable=pretty_tables_} renderTableB def{tableBorders=False,prettyTable=pretty_tables_}
(alignCell TopLeft) (alignCell TopRight) (uncurry showcell) displayTableWithWidths (alignCell TopLeft) (alignCell TopRight) (uncurry showcell) displayTableWithWidths
where where
title = printf "Budget performance in %s%s:" title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr)
(showDateSpan $ periodicReportSpan budgetr) <> (case value_ of
(case value_ of
Just (AtCost _mc) -> ", valued at cost" Just (AtCost _mc) -> ", valued at cost"
Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL: Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL:
Just (AtEnd _mc) -> ", valued at period ends" Just (AtEnd _mc) -> ", valued at period ends"
Just (AtNow _mc) -> ", current value" Just (AtNow _mc) -> ", current value"
Just (AtDate d _mc) -> ", valued at " ++ T.unpack (showDate d) Just (AtDate d _mc) -> ", valued at " <> showDate d
Nothing -> "") Nothing -> "")
<> ":"
displayTableWithWidths :: Table String String ((Int, Int, Int), BudgetDisplayCell) displayTableWithWidths :: Table Text Text ((Int, Int, Int), BudgetDisplayCell)
displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells
Table rh ch displaycells = case budgetReportAsTable ropts budgetr of Table rh ch displaycells = case budgetReportAsTable ropts budgetr of
Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map displayCell) vals Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map displayCell) vals
@ -244,8 +245,8 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
where where
actual' = fromMaybe 0 actual actual' = fromMaybe 0 actual
budgetAndPerc b = (showamt b, showper <$> percentage actual' b) budgetAndPerc b = (showamt b, showper <$> percentage actual' b)
showamt = showMixedOneLine showAmountWithoutPrice Nothing (Just 32) color_ showamt = first T.pack . showMixedOneLine showAmountWithoutPrice Nothing (Just 32) color_
showper p = let str = show (roundTo 0 p) in (str, length str) showper p = let str = T.pack (show $ roundTo 0 p) in (str, T.length str)
cellWidth ((_,wa), Nothing) = (wa, 0, 0) cellWidth ((_,wa), Nothing) = (wa, 0, 0)
cellWidth ((_,wa), Just ((_,wb), Nothing)) = (wa, wb, 0) cellWidth ((_,wa), Just ((_,wb), Nothing)) = (wa, wb, 0)
cellWidth ((_,wa), Just ((_,wb), Just (_,wp))) = (wa, wb, wp) cellWidth ((_,wa), Just ((_,wb), Just (_,wp))) = (wa, wb, wp)
@ -259,14 +260,14 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
-- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells
showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell
showcell (actualwidth, budgetwidth, percentwidth) ((actual,wa), mbudget) = showcell (actualwidth, budgetwidth, percentwidth) ((actual,wa), mbudget) =
Cell TopRight [(replicate (actualwidth - wa) ' ' ++ actual ++ budgetstr, actualwidth + totalbudgetwidth)] Cell TopRight [(T.replicate (actualwidth - wa) " " <> actual <> budgetstr, actualwidth + totalbudgetwidth)]
where where
totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5 totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
totalbudgetwidth = if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3 totalbudgetwidth = if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3
budgetstr = case mbudget of budgetstr = case mbudget of
Nothing -> replicate totalbudgetwidth ' ' Nothing -> T.replicate totalbudgetwidth " "
Just ((budget, wb), Nothing) -> " [" ++ replicate totalpercentwidth ' ' ++ replicate (budgetwidth - wb) ' ' ++ budget ++ "]" Just ((budget, wb), Nothing) -> " [" <> T.replicate totalpercentwidth " " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
Just ((budget, wb), Just (pct, wp)) -> " [" ++ replicate (percentwidth - wp) ' ' ++ pct ++ "% of " ++ replicate (budgetwidth - wb) ' ' ++ budget ++ "]" Just ((budget, wb), Just (pct, wp)) -> " [" <> T.replicate (percentwidth - wp) " " <> pct <> "% of " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
-- | Calculate the percentage of actual change to budget goal to show, if any. -- | Calculate the percentage of actual change to budget goal to show, if any.
-- If valuing at cost, both amounts are converted to cost before comparing. -- If valuing at cost, both amounts are converted to cost before comparing.
@ -289,7 +290,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
| otherwise = id | otherwise = id
-- | Build a 'Table' from a multi-column balance report. -- | Build a 'Table' from a multi-column balance report.
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount) budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text (Maybe MixedAmount, Maybe MixedAmount)
budgetReportAsTable budgetReportAsTable
ropts@ReportOpts{balancetype_} ropts@ReportOpts{balancetype_}
(PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) = (PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) =
@ -299,7 +300,7 @@ budgetReportAsTable
(T.Group NoLine $ map Header colheadings) (T.Group NoLine $ map Header colheadings)
(map rowvals rows) (map rowvals rows)
where where
colheadings = map (T.unpack . reportPeriodName balancetype_ spans) spans colheadings = map (reportPeriodName balancetype_ spans) spans
++ [" Total" | row_total_ ropts] ++ [" Total" | row_total_ ropts]
++ ["Average" | average_ ropts] ++ ["Average" | average_ ropts]
@ -308,8 +309,8 @@ budgetReportAsTable
-- budgetReport sets accountlistmode to ALTree. Find a principled way to do -- budgetReport sets accountlistmode to ALTree. Find a principled way to do
-- this. -- this.
renderacct row = case accountlistmode_ ropts of renderacct row = case accountlistmode_ ropts of
ALTree -> replicate ((prrDepth row - 1)*2) ' ' ++ T.unpack (prrDisplayName row) ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
ALFlat -> T.unpack . accountNameDrop (drop_ ropts) $ prrFullName row ALFlat -> accountNameDrop (drop_ ropts) $ prrFullName row
rowvals (PeriodicReportRow _ as rowtot rowavg) = rowvals (PeriodicReportRow _ as rowtot rowavg) =
as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts] as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts]
addtotalrow addtotalrow

2
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -167,7 +167,7 @@ rawOptsToReportOpts rawopts = do
supports_color <- hSupportsANSIColor stdout supports_color <- hSupportsANSIColor stdout
let colorflag = stringopt "color" rawopts let colorflag = stringopt "color" rawopts
formatstring = maybestringopt "format" rawopts formatstring = T.pack <$> maybestringopt "format" rawopts
querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
format <- case parseStringFormat <$> formatstring of format <- case parseStringFormat <$> formatstring of

12
hledger-lib/Hledger/Utils/String.hs
View File

@ -55,6 +55,8 @@ module Hledger.Utils.String (
import Data.Char (isSpace, toLower, toUpper) import Data.Char (isSpace, toLower, toUpper)
import Data.Default (def) import Data.Default (def)
import Data.List (intercalate) import Data.List (intercalate)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Megaparsec ((<|>), between, many, noneOf, sepBy) import Text.Megaparsec ((<|>), between, many, noneOf, sepBy)
import Text.Megaparsec.Char (char) import Text.Megaparsec.Char (char)
import Text.Printf (printf) import Text.Printf (printf)
@ -63,7 +65,7 @@ import Hledger.Utils.Parse
import Hledger.Utils.Regex (toRegex', regexReplace) import Hledger.Utils.Regex (toRegex', regexReplace)
import Text.Tabular (Header(..), Properties(..)) import Text.Tabular (Header(..), Properties(..))
import Text.Tabular.AsciiWide (Align(..), Cell(..), TableOpts(..), renderRow) import Text.Tabular.AsciiWide (Align(..), Cell(..), TableOpts(..), renderRow)
import Text.WideString (strWidth, charWidth) import Text.WideString (charWidth, strWidth, textWidth)
-- | Take elements from the end of a list. -- | Take elements from the end of a list.
@ -184,16 +186,16 @@ unbracket s
-- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded. -- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.
-- Treats wide characters as double width. -- Treats wide characters as double width.
concatTopPadded :: [String] -> String concatTopPadded :: [String] -> String
concatTopPadded = renderRow def{tableBorders=False, borderSpaces=False} concatTopPadded = TL.unpack . renderRow def{tableBorders=False, borderSpaces=False}
. Group NoLine . map (Header . cell) . Group NoLine . map (Header . cell)
where cell = Cell BottomLeft . map (\x -> (x, strWidth x)) . lines where cell = Cell BottomLeft . map (\x -> (x, textWidth x)) . T.lines . T.pack
-- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. -- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
-- Treats wide characters as double width. -- Treats wide characters as double width.
concatBottomPadded :: [String] -> String concatBottomPadded :: [String] -> String
concatBottomPadded = renderRow def{tableBorders=False, borderSpaces=False} concatBottomPadded = TL.unpack . renderRow def{tableBorders=False, borderSpaces=False}
. Group NoLine . map (Header . cell) . Group NoLine . map (Header . cell)
where cell = Cell TopLeft . map (\x -> (x, strWidth x)) . lines where cell = Cell TopLeft . map (\x -> (x, textWidth x)) . T.lines . T.pack
-- | Join multi-line strings horizontally, after compressing each of -- | Join multi-line strings horizontally, after compressing each of

20
hledger-lib/Hledger/Utils/Text.hs
View File

@ -31,7 +31,7 @@ module Hledger.Utils.Text
-- -- * single-line layout -- -- * single-line layout
-- elideLeft, -- elideLeft,
textElideRight, textElideRight,
-- formatString, formatText,
-- -- * multi-line layout -- -- * multi-line layout
textConcatTopPadded, textConcatTopPadded,
-- concatBottomPadded, -- concatBottomPadded,
@ -97,15 +97,15 @@ wrap start end x = start <> x <> end
textChomp :: Text -> Text textChomp :: Text -> Text
textChomp = T.dropWhileEnd (`elem` ['\r', '\n']) textChomp = T.dropWhileEnd (`elem` ['\r', '\n'])
-- -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it. -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.
-- -- Works on multi-line strings too (but will rewrite non-unix line endings). -- Works on multi-line strings too (but will rewrite non-unix line endings).
-- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String formatText :: Bool -> Maybe Int -> Maybe Int -> Text -> Text
-- formatString leftJustified minwidth maxwidth s = intercalate "\n" $ map (printf fmt) $ lines s formatText leftJustified minwidth maxwidth =
-- where T.intercalate "\n" . map (pad . clip) . T.lines
-- justify = if leftJustified then "-" else "" where
-- minwidth' = maybe "" show minwidth pad = maybe id justify minwidth
-- maxwidth' = maybe "" (("."++).show) maxwidth clip = maybe id T.take maxwidth
-- fmt = "%" ++ justify ++ minwidth' ++ maxwidth' ++ "s" justify n = if leftJustified then T.justifyLeft n ' ' else T.justifyRight n ' '
-- underline :: String -> String -- underline :: String -> String
-- underline s = s' ++ replicate (length s) '-' ++ "\n" -- underline s = s' ++ replicate (length s) '-' ++ "\n"

131
hledger-lib/Text/Tabular/AsciiWide.hs
View File

@ -1,14 +1,21 @@
-- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat -- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat
-- wide characters as double width. -- wide characters as double width.
{-# LANGUAGE OverloadedStrings #-}
module Text.Tabular.AsciiWide where module Text.Tabular.AsciiWide where
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Default (Default(..)) import Data.Default (Default(..))
import Data.List (intersperse, transpose) import Data.List (intersperse, transpose)
import Data.Semigroup (stimesMonoid)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText)
import Safe (maximumMay) import Safe (maximumMay)
import Text.Tabular import Text.Tabular
import Text.WideString (strWidth) import Text.WideString (textWidth)
-- | The options to use for rendering a table. -- | The options to use for rendering a table.
@ -25,7 +32,7 @@ instance Default TableOpts where
} }
-- | Cell contents along an alignment -- | Cell contents along an alignment
data Cell = Cell Align [(String, Int)] data Cell = Cell Align [(Text, Int)]
deriving (Show) deriving (Show)
-- | How to align text in a cell -- | How to align text in a cell
@ -36,8 +43,8 @@ emptyCell :: Cell
emptyCell = Cell TopRight [] emptyCell = Cell TopRight []
-- | Create a single-line cell from the given contents with its natural width. -- | Create a single-line cell from the given contents with its natural width.
alignCell :: Align -> String -> Cell alignCell :: Align -> Text -> Cell
alignCell a x = Cell a [(x, strWidth x)] alignCell a x = Cell a [(x, textWidth x)]
-- | Return the width of a Cell. -- | Return the width of a Cell.
cellWidth :: Cell -> Int cellWidth :: Cell -> Int
@ -45,19 +52,28 @@ cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map snd xs
-- | Render a table according to common options, for backwards compatibility -- | Render a table according to common options, for backwards compatibility
render :: Bool -> (rh -> String) -> (ch -> String) -> (a -> String) -> Table rh ch a -> String render :: Bool -> (rh -> Text) -> (ch -> Text) -> (a -> Text) -> Table rh ch a -> TL.Text
render pretty fr fc f = renderTable def{prettyTable=pretty} (cell . fr) (cell . fc) (cell . f) render pretty fr fc f = renderTable def{prettyTable=pretty} (cell . fr) (cell . fc) (cell . f)
where cell = alignCell TopRight where cell = alignCell TopRight
-- | Render a table according to various cell specifications -- | Render a table according to various cell specifications>
renderTable :: TableOpts -- ^ Options controlling Table rendering renderTable :: TableOpts -- ^ Options controlling Table rendering
-> (rh -> Cell) -- ^ Rendering function for row headers -> (rh -> Cell) -- ^ Rendering function for row headers
-> (ch -> Cell) -- ^ Rendering function for column headers -> (ch -> Cell) -- ^ Rendering function for column headers
-> (a -> Cell) -- ^ Function determining the string and width of a cell -> (a -> Cell) -- ^ Function determining the string and width of a cell
-> Table rh ch a -> Table rh ch a
-> String -> TL.Text
renderTable topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) = renderTable topts fr fc f = toLazyText . renderTableB topts fr fc f
unlines . addBorders $
-- | A version of renderTable which returns the underlying Builder.
renderTableB :: TableOpts -- ^ Options controlling Table rendering
-> (rh -> Cell) -- ^ Rendering function for row headers
-> (ch -> Cell) -- ^ Rendering function for column headers
-> (a -> Cell) -- ^ Function determining the string and width of a cell
-> Table rh ch a
-> Builder
renderTableB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) =
unlinesB . addBorders $
renderColumns topts sizes ch2 renderColumns topts sizes ch2
: bar VM DoubleLine -- +======================================+ : bar VM DoubleLine -- +======================================+
: renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders) : renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders)
@ -83,49 +99,54 @@ renderTable topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (T
-- borders and bars -- borders and bars
addBorders xs = if borders then bar VT SingleLine : xs ++ [bar VB SingleLine] else xs addBorders xs = if borders then bar VT SingleLine : xs ++ [bar VB SingleLine] else xs
bar vpos prop = concat $ renderHLine vpos borders pretty sizes ch2 prop bar vpos prop = mconcat $ renderHLine vpos borders pretty sizes ch2 prop
unlinesB = (<>singleton '\n') . mconcat . intersperse "\n"
-- | Render a single row according to cell specifications. -- | Render a single row according to cell specifications.
renderRow :: TableOpts -> Header Cell -> String renderRow :: TableOpts -> Header Cell -> TL.Text
renderRow topts h = renderColumns topts is h renderRow topts = toLazyText . renderRowB topts
-- | A version of renderRow which returns the underlying Builder.
renderRowB:: TableOpts -> Header Cell -> Builder
renderRowB topts h = renderColumns topts is h
where is = map (\(Cell _ xs) -> fromMaybe 0 . maximumMay $ map snd xs) $ headerContents h where is = map (\(Cell _ xs) -> fromMaybe 0 . maximumMay $ map snd xs) $ headerContents h
verticalBar :: Bool -> Char verticalBar :: Bool -> Char
verticalBar pretty = if pretty then '│' else '|' verticalBar pretty = if pretty then '│' else '|'
leftBar :: Bool -> Bool -> String leftBar :: Bool -> Bool -> Builder
leftBar pretty True = verticalBar pretty : " " leftBar pretty True = fromString $ verticalBar pretty : " "
leftBar pretty False = [verticalBar pretty] leftBar pretty False = singleton $ verticalBar pretty
rightBar :: Bool -> Bool -> String rightBar :: Bool -> Bool -> Builder
rightBar pretty True = ' ' : [verticalBar pretty] rightBar pretty True = fromString $ ' ' : [verticalBar pretty]
rightBar pretty False = [verticalBar pretty] rightBar pretty False = singleton $ verticalBar pretty
midBar :: Bool -> Bool -> String midBar :: Bool -> Bool -> Builder
midBar pretty True = ' ' : verticalBar pretty : " " midBar pretty True = fromString $ ' ' : verticalBar pretty : " "
midBar pretty False = [verticalBar pretty] midBar pretty False = singleton $ verticalBar pretty
doubleMidBar :: Bool -> Bool -> String doubleMidBar :: Bool -> Bool -> Builder
doubleMidBar pretty True = if pretty then " ║ " else " || " doubleMidBar pretty True = fromText $ if pretty then " ║ " else " || "
doubleMidBar pretty False = if pretty then "║" else "||" doubleMidBar pretty False = fromText $ if pretty then "║" else "||"
-- | We stop rendering on the shortest list! -- | We stop rendering on the shortest list!
renderColumns :: TableOpts -- ^ rendering options for the table renderColumns :: TableOpts -- ^ rendering options for the table
-> [Int] -- ^ max width for each column -> [Int] -- ^ max width for each column
-> Header Cell -> Header Cell
-> String -> Builder
renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=spaces} is h = renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=spaces} is h =
concat . intersperse "\n" -- Put each line on its own line mconcat . intersperse "\n" -- Put each line on its own line
. map (addBorders . concat) . transpose -- Change to a list of lines and add borders . map (addBorders . mconcat) . transpose -- Change to a list of lines and add borders
. map (either hsep padCell) . flattenHeader -- We now have a matrix of strings . map (either hsep padCell) . flattenHeader -- We now have a matrix of strings
. zipHeader 0 is $ padRow <$> h -- Pad cell height and add width marker . zipHeader 0 is $ padRow <$> h -- Pad cell height and add width marker
where where
-- Pad each cell to have the appropriate width -- Pad each cell to have the appropriate width
padCell (w, Cell TopLeft ls) = map (\(x,xw) -> x ++ replicate (w - xw) ' ') ls padCell (w, Cell TopLeft ls) = map (\(x,xw) -> fromText x <> fromText (T.replicate (w - xw) " ")) ls
padCell (w, Cell BottomLeft ls) = map (\(x,xw) -> x ++ replicate (w - xw) ' ') ls padCell (w, Cell BottomLeft ls) = map (\(x,xw) -> fromText x <> fromText (T.replicate (w - xw) " ")) ls
padCell (w, Cell TopRight ls) = map (\(x,xw) -> replicate (w - xw) ' ' ++ x) ls padCell (w, Cell TopRight ls) = map (\(x,xw) -> fromText (T.replicate (w - xw) " ") <> fromText x) ls
padCell (w, Cell BottomRight ls) = map (\(x,xw) -> replicate (w - xw) ' ' ++ x) ls padCell (w, Cell BottomRight ls) = map (\(x,xw) -> fromText (T.replicate (w - xw) " ") <> fromText x) ls
-- Pad each cell to have the same number of lines -- Pad each cell to have the same number of lines
padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) ("",0) padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) ("",0)
@ -133,13 +154,13 @@ renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=s
padRow (Cell BottomLeft ls) = Cell BottomLeft $ replicate (nLines - length ls) ("",0) ++ ls padRow (Cell BottomLeft ls) = Cell BottomLeft $ replicate (nLines - length ls) ("",0) ++ ls
padRow (Cell BottomRight ls) = Cell BottomRight $ replicate (nLines - length ls) ("",0) ++ ls padRow (Cell BottomRight ls) = Cell BottomRight $ replicate (nLines - length ls) ("",0) ++ ls
hsep :: Properties -> [String] hsep :: Properties -> [Builder]
hsep NoLine = replicate nLines $ if spaces then " " else "" hsep NoLine = replicate nLines $ if spaces then " " else ""
hsep SingleLine = replicate nLines $ midBar pretty spaces hsep SingleLine = replicate nLines $ midBar pretty spaces
hsep DoubleLine = replicate nLines $ doubleMidBar pretty spaces hsep DoubleLine = replicate nLines $ doubleMidBar pretty spaces
addBorders xs | borders = leftBar pretty spaces ++ xs ++ rightBar pretty spaces addBorders xs | borders = leftBar pretty spaces <> xs <> rightBar pretty spaces
| spaces = ' ' : xs ++ " " | spaces = fromText " " <> xs <> fromText " "
| otherwise = xs | otherwise = xs
nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h
@ -150,52 +171,48 @@ renderHLine :: VPos
-> [Int] -- ^ width specifications -> [Int] -- ^ width specifications
-> Header a -> Header a
-> Properties -> Properties
-> [String] -> [Builder]
renderHLine _ _ _ _ _ NoLine = [] renderHLine _ _ _ _ _ NoLine = []
renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h] renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h]
renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> String renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder
renderHLine' vpos borders pretty prop is h = addBorders $ sep ++ coreLine ++ sep renderHLine' vpos borders pretty prop is h = addBorders $ sep <> coreLine <> sep
where where
addBorders xs = if borders then edge HL ++ xs ++ edge HR else xs addBorders xs = if borders then edge HL <> xs <> edge HR else xs
edge hpos = boxchar vpos hpos SingleLine prop pretty edge hpos = boxchar vpos hpos SingleLine prop pretty
coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h coreLine = foldMap helper $ flattenHeader $ zipHeader 0 is h
helper = either vsep dashes helper = either vsep dashes
dashes (i,_) = concat (replicate i sep) dashes (i,_) = stimesMonoid i sep
sep = boxchar vpos HM NoLine prop pretty sep = boxchar vpos HM NoLine prop pretty
vsep v = case v of vsep v = case v of
NoLine -> sep ++ sep NoLine -> sep <> sep
_ -> sep ++ cross v prop ++ sep _ -> sep <> cross v prop <> sep
cross v h = boxchar vpos HM v h pretty cross v h = boxchar vpos HM v h pretty
data VPos = VT | VM | VB -- top middle bottom data VPos = VT | VM | VB -- top middle bottom
data HPos = HL | HM | HR -- left middle right data HPos = HL | HM | HR -- left middle right
boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> String boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> Builder
boxchar vpos hpos vert horiz = lineart u d l r boxchar vpos hpos vert horiz = lineart u d l r
where where
u = u = case vpos of
case vpos of
VT -> NoLine VT -> NoLine
_ -> vert _ -> vert
d = d = case vpos of
case vpos of
VB -> NoLine VB -> NoLine
_ -> vert _ -> vert
l = l = case hpos of
case hpos of
HL -> NoLine HL -> NoLine
_ -> horiz _ -> horiz
r = r = case hpos of
case hpos of
HR -> NoLine HR -> NoLine
_ -> horiz _ -> horiz
pick :: String -> String -> Bool -> String pick :: Text -> Text -> Bool -> Builder
pick x _ True = x pick x _ True = fromText x
pick _ x False = x pick _ x False = fromText x
lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> String lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> Builder
-- up down left right -- up down left right
lineart SingleLine SingleLine SingleLine SingleLine = pick "┼" "+" lineart SingleLine SingleLine SingleLine SingleLine = pick "┼" "+"
lineart SingleLine SingleLine SingleLine NoLine = pick "┤" "+" lineart SingleLine SingleLine SingleLine NoLine = pick "┤" "+"
@ -244,6 +261,4 @@ lineart NoLine SingleLine DoubleLine DoubleLine = pick "╤" "+"
lineart SingleLine SingleLine DoubleLine DoubleLine = pick "╪" "+" lineart SingleLine SingleLine DoubleLine DoubleLine = pick "╪" "+"
lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++" lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++"
lineart _ _ _ _ = const "" lineart _ _ _ _ = const mempty
--

104
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -255,7 +255,7 @@ module Hledger.Cli.Commands.Balance (
) where ) where
import Data.Default (def) import Data.Default (def)
import Data.List (intercalate, transpose) import Data.List (intersperse, transpose)
import Data.Maybe (fromMaybe, maybeToList) import Data.Maybe (fromMaybe, maybeToList)
--import qualified Data.Map as Map --import qualified Data.Map as Map
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
@ -263,11 +263,12 @@ import Data.Semigroup ((<>))
#endif #endif
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.Time (fromGregorian) import Data.Time (fromGregorian)
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
import Lucid as L import Lucid as L
import Text.Tabular as T import Text.Tabular as Tab
import Text.Tabular.AsciiWide as T import Text.Tabular.AsciiWide as Tab
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
@ -321,16 +322,16 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
assrt = not $ ignore_assertions_ $ inputopts_ opts assrt = not $ ignore_assertions_ $ inputopts_ opts
render = case fmt of render = case fmt of
"txt" -> budgetReportAsText ropts "txt" -> budgetReportAsText ropts
"json" -> TL.unpack . (<>"\n") . toJsonText "json" -> (<>"\n") . toJsonText
"csv" -> TL.unpack . printCSV . budgetReportAsCsv ropts "csv" -> printCSV . budgetReportAsCsv ropts
_ -> const $ error' $ unsupportedOutputFormatError fmt _ -> error' $ unsupportedOutputFormatError fmt
writeOutput opts $ render budgetreport writeOutputLazyText opts $ render budgetreport
else else
if multiperiod then do -- multi period balance report if multiperiod then do -- multi period balance report
let report = multiBalanceReport rspec j let report = multiBalanceReport rspec j
render = case fmt of render = case fmt of
"txt" -> TL.pack . multiBalanceReportAsText ropts "txt" -> multiBalanceReportAsText ropts
"csv" -> printCSV . multiBalanceReportAsCsv ropts "csv" -> printCSV . multiBalanceReportAsCsv ropts
"html" -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts "html" -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts
"json" -> (<>"\n") . toJsonText "json" -> (<>"\n") . toJsonText
@ -340,7 +341,7 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
else do -- single period simple balance report else do -- single period simple balance report
let report = balanceReport rspec j -- simple Ledger-style balance report let report = balanceReport rspec j -- simple Ledger-style balance report
render = case fmt of render = case fmt of
"txt" -> \ropts -> TL.pack . balanceReportAsText ropts "txt" -> \ropts -> TB.toLazyText . balanceReportAsText ropts
"csv" -> \ropts -> printCSV . balanceReportAsCsv ropts "csv" -> \ropts -> printCSV . balanceReportAsCsv ropts
"json" -> const $ (<>"\n") . toJsonText "json" -> const $ (<>"\n") . toJsonText
_ -> error' $ unsupportedOutputFormatError fmt -- PARTIAL: _ -> error' $ unsupportedOutputFormatError fmt -- PARTIAL:
@ -363,18 +364,21 @@ balanceReportAsCsv opts (items, total) =
else [["total", T.pack $ showMixedAmountOneLineWithoutPrice False total]] else [["total", T.pack $ showMixedAmountOneLineWithoutPrice False total]]
-- | Render a single-column balance report as plain text. -- | Render a single-column balance report as plain text.
balanceReportAsText :: ReportOpts -> BalanceReport -> String balanceReportAsText :: ReportOpts -> BalanceReport -> TB.Builder
balanceReportAsText opts ((items, total)) = unlines $ balanceReportAsText opts ((items, total)) =
concat lines ++ if no_total_ opts then [] else overline : totallines unlinesB lines <> unlinesB (if no_total_ opts then [] else [overline, totallines])
where where
unlinesB [] = mempty
unlinesB xs = mconcat (intersperse (TB.singleton '\n') xs) <> TB.singleton '\n'
lines = map (balanceReportItemAsText opts) items lines = map (balanceReportItemAsText opts) items
-- abuse renderBalanceReportItem to render the total with similar format -- abuse renderBalanceReportItem to render the total with similar format
acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items] totallines = renderBalanceReportItem opts ("", 0, total)
totallines = map rstrip $ renderBalanceReportItem opts (T.replicate (acctcolwidth+1) " ", 0, total)
-- with a custom format, extend the line to the full report width; -- with a custom format, extend the line to the full report width;
-- otherwise show the usual 20-char line for compatibility -- otherwise show the usual 20-char line for compatibility
overlinewidth = fromMaybe (maximum' . map length $ concat lines) . overlineWidth $ format_ opts overlinewidth = fromMaybe 22 . overlineWidth $ format_ opts
overline = replicate overlinewidth '-' --overlinewidth = fromMaybe (maximum' . map length $ concat lines) . overlineWidth $ format_ opts
overline = TB.fromText $ T.replicate overlinewidth "-"
{- {-
:r :r
@ -391,7 +395,7 @@ This implementation turned out to be a bit convoluted but implements the followi
-- whatever string format is specified). Note, prices will not be rendered, and -- whatever string format is specified). Note, prices will not be rendered, and
-- differently-priced quantities of the same commodity will appear merged. -- differently-priced quantities of the same commodity will appear merged.
-- The output will be one or more lines depending on the format and number of commodities. -- The output will be one or more lines depending on the format and number of commodities.
balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> [String] balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> TB.Builder
balanceReportItemAsText opts (_, accountName, depth, amt) = balanceReportItemAsText opts (_, accountName, depth, amt) =
renderBalanceReportItem opts ( renderBalanceReportItem opts (
accountName, accountName,
@ -400,41 +404,45 @@ balanceReportItemAsText opts (_, accountName, depth, amt) =
) )
-- | Render a balance report item using the given StringFormat, generating one or more lines of text. -- | Render a balance report item using the given StringFormat, generating one or more lines of text.
renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> [String] renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> TB.Builder
renderBalanceReportItem opts (acctname, depth, total) = renderBalanceReportItem opts (acctname, depth, total) =
lines $ case format_ opts of case format_ opts of
OneLine _ comps -> concatOneLine $ render1 comps OneLine _ comps -> foldMap (TB.fromText . T.intercalate ", ") $ render1 comps
TopAligned _ comps -> concatBottomPadded $ render comps TopAligned _ comps -> renderRow' TopLeft $ render comps
BottomAligned _ comps -> concatTopPadded $ render comps BottomAligned _ comps -> renderRow' BottomLeft $ render comps
where where
render1 = map (renderComponent1 opts (acctname, depth, total)) renderRow' align = renderRowB def{tableBorders=False, borderSpaces=False}
render = map (renderComponent opts (acctname, depth, total)) . Tab.Group NoLine . map (Header . cell)
where cell = Cell align . map (\x -> (x, textWidth x))
render1 = map (T.lines . renderComponent1 opts (acctname, depth, total))
render = map (T.lines . renderComponent opts (acctname, depth, total))
-- | Render one StringFormat component for a balance report item. -- | Render one StringFormat component for a balance report item.
renderComponent :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String renderComponent :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> T.Text
renderComponent _ _ (FormatLiteral s) = s renderComponent _ _ (FormatLiteral s) = s
renderComponent opts (acctname, depth, total) (FormatField ljust min max field) = case field of renderComponent opts (acctname, depth, total) (FormatField ljust min max field) = case field of
DepthSpacerField -> formatString ljust Nothing max $ replicate d ' ' DepthSpacerField -> formatText ljust Nothing max $ T.replicate d " "
where d = case min of where d = case min of
Just m -> depth * m Just m -> depth * m
Nothing -> depth Nothing -> depth
AccountField -> formatString ljust min max (T.unpack acctname) AccountField -> formatText ljust min max acctname
TotalField -> fst $ showMixed showAmountWithoutPrice min max (color_ opts) total TotalField -> T.pack . fst $ showMixed showAmountWithoutPrice min max (color_ opts) total
_ -> "" _ -> ""
-- | Render one StringFormat component for a balance report item. -- | Render one StringFormat component for a balance report item.
-- This variant is for use with OneLine string formats; it squashes -- This variant is for use with OneLine string formats; it squashes
-- any multi-line rendered values onto one line, comma-and-space separated, -- any multi-line rendered values onto one line, comma-and-space separated,
-- while still complying with the width spec. -- while still complying with the width spec.
renderComponent1 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String renderComponent1 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> T.Text
renderComponent1 _ _ (FormatLiteral s) = s renderComponent1 _ _ (FormatLiteral s) = s
renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) = case field of renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) = case field of
AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented (T.unpack acctname))) AccountField -> formatText ljust min max . T.intercalate ", " . T.lines $ indented acctname
where where
-- better to indent the account name here rather than use a DepthField component -- better to indent the account name here rather than use a DepthField component
-- so that it complies with width spec. Uses a fixed indent step size. -- so that it complies with width spec. Uses a fixed indent step size.
indented = ((replicate (depth*2) ' ')++) indented = ((T.replicate (depth*2) " ")<>)
TotalField -> fst $ showMixedOneLine showAmountWithoutPrice min max (color_ opts) total TotalField -> T.pack . fst $ showMixedOneLine showAmountWithoutPrice min max (color_ opts) total
_ -> "" _ -> ""
-- rendering multi-column balance reports -- rendering multi-column balance reports
@ -559,9 +567,11 @@ multiBalanceReportHtmlFootRow ropts (acct:rest) =
--thRow = tr_ . mconcat . map (th_ . toHtml) --thRow = tr_ . mconcat . map (th_ . toHtml)
-- | Render a multi-column balance report as plain text suitable for console output. -- | Render a multi-column balance report as plain text suitable for console output.
multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> TL.Text
multiBalanceReportAsText ropts@ReportOpts{..} r = multiBalanceReportAsText ropts@ReportOpts{..} r = TB.toLazyText $
T.unpack title <> "\n\n" <> (balanceReportTableAsText ropts $ balanceReportAsTable ropts r) TB.fromText title
<> TB.fromText "\n\n"
<> balanceReportTableAsText ropts (balanceReportAsTable ropts r)
where where
title = mtitle <> " in " <> showDateSpan (periodicReportSpan r) <> valuationdesc <> ":" title = mtitle <> " in " <> showDateSpan (periodicReportSpan r) <> valuationdesc <> ":"
@ -584,23 +594,23 @@ multiBalanceReportAsText ropts@ReportOpts{..} r =
_ -> False _ -> False
-- | Build a 'Table' from a multi-column balance report. -- | Build a 'Table' from a multi-column balance report.
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table T.Text T.Text MixedAmount
balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_} balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
(PeriodicReport spans items (PeriodicReportRow _ coltotals tot avg)) = (PeriodicReport spans items (PeriodicReportRow _ coltotals tot avg)) =
maybetranspose $ maybetranspose $
addtotalrow $ addtotalrow $
Table Table
(T.Group NoLine $ map Header accts) (Tab.Group NoLine $ map Header accts)
(T.Group NoLine $ map Header colheadings) (Tab.Group NoLine $ map Header colheadings)
(map rowvals items) (map rowvals items)
where where
totalscolumn = row_total_ && balancetype_ `notElem` [CumulativeChange, HistoricalBalance] totalscolumn = row_total_ && balancetype_ `notElem` [CumulativeChange, HistoricalBalance]
colheadings = map (T.unpack . reportPeriodName balancetype_ spans) spans colheadings = map (reportPeriodName balancetype_ spans) spans
++ [" Total" | totalscolumn] ++ [" Total" | totalscolumn]
++ ["Average" | average_] ++ ["Average" | average_]
accts = map renderacct items accts = map renderacct items
renderacct row = renderacct row =
replicate ((prrDepth row - 1) * 2) ' ' ++ T.unpack (prrDisplayName row) T.replicate ((prrDepth row - 1) * 2) " " <> prrDisplayName row
rowvals (PeriodicReportRow _ as rowtot rowavg) = as rowvals (PeriodicReportRow _ as rowtot rowavg) = as
++ [rowtot | totalscolumn] ++ [rowtot | totalscolumn]
++ [rowavg | average_] ++ [rowavg | average_]
@ -617,12 +627,12 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
-- made using 'balanceReportAsTable'), render it in a format suitable for -- made using 'balanceReportAsTable'), render it in a format suitable for
-- console output. Amounts with more than two commodities will be elided -- console output. Amounts with more than two commodities will be elided
-- unless --no-elide is used. -- unless --no-elide is used.
balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String balanceReportTableAsText :: ReportOpts -> Table T.Text T.Text MixedAmount -> TB.Builder
balanceReportTableAsText ReportOpts{..} = balanceReportTableAsText ReportOpts{..} =
T.renderTable def{tableBorders=False, prettyTable=pretty_tables_} Tab.renderTableB def{tableBorders=False, prettyTable=pretty_tables_}
(T.alignCell TopLeft) (T.alignCell TopRight) showamt (Tab.alignCell TopLeft) (Tab.alignCell TopRight) showamt
where where
showamt = Cell TopRight . pure . showMixedOneLine showAmountWithoutPrice Nothing mmax color_ showamt = Cell TopRight . (\(a,w) -> [(T.pack a,w)]) . showMixedOneLine showAmountWithoutPrice Nothing mmax color_
mmax = if no_elide_ then Nothing else Just 32 mmax = if no_elide_ then Nothing else Just 32
@ -631,14 +641,12 @@ tests_Balance = tests "Balance" [
tests "balanceReportAsText" [ tests "balanceReportAsText" [
test "unicode in balance layout" $ do test "unicode in balance layout" $ do
j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
let rspec = defreportspec let rspec = defreportspec{rsOpts=defreportopts{no_total_=True}}
balanceReportAsText (rsOpts rspec) (balanceReport rspec{rsToday=fromGregorian 2008 11 26} j) TL.unpack (TB.toLazyText $ balanceReportAsText (rsOpts rspec) (balanceReport rspec{rsToday=fromGregorian 2008 11 26} j))
@?= @?=
unlines unlines
[" -100 актив:наличные" [" -100 актив:наличные"
," 100 расходы:покупки" ," 100 расходы:покупки"
,"--------------------"
," 0"
] ]
] ]

12
hledger/Hledger/Cli/Commands/Roi.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-| {-|
@ -20,6 +21,7 @@ import Data.List
import Numeric.RootFinding import Numeric.RootFinding
import Data.Decimal import Data.Decimal
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TL
import System.Console.CmdArgs.Explicit as CmdArgs import System.Console.CmdArgs.Explicit as CmdArgs
import Text.Tabular as Tbl import Text.Tabular as Tbl
@ -126,14 +128,14 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
, T.pack $ printf "%0.2f%%" $ smallIsZero twr ] , T.pack $ printf "%0.2f%%" $ smallIsZero twr ]
let table = Table let table = Table
(Tbl.Group NoLine (map (Header . show) (take (length tableBody) [1..]))) (Tbl.Group NoLine (map (Header . T.pack . show) (take (length tableBody) [1..])))
(Tbl.Group DoubleLine (Tbl.Group DoubleLine
[ Tbl.Group SingleLine [Header "Begin", Header "End"] [ Tbl.Group SingleLine [Header "Begin", Header "End"]
, Tbl.Group SingleLine [Header "Value (begin)", Header "Cashflow", Header "Value (end)", Header "PnL"] , Tbl.Group SingleLine [Header "Value (begin)", Header "Cashflow", Header "Value (end)", Header "PnL"]
, Tbl.Group SingleLine [Header "IRR", Header "TWR"]]) , Tbl.Group SingleLine [Header "IRR", Header "TWR"]])
tableBody tableBody
putStrLn $ Ascii.render prettyTables id id T.unpack table TL.putStrLn $ Ascii.render prettyTables id id id table
timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow pnl) = do timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow pnl) = do
let initialUnitPrice = 100 let initialUnitPrice = 100
@ -196,7 +198,7 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spa
unitBalances = add initialUnits unitBalances' unitBalances = add initialUnits unitBalances'
valuesOnDate = add 0 valuesOnDate' valuesOnDate = add 0 valuesOnDate'
putStr $ Ascii.render prettyTables T.unpack id id TL.putStr $ Ascii.render prettyTables id id T.pack
(Table (Table
(Tbl.Group NoLine (map (Header . showDate) dates)) (Tbl.Group NoLine (map (Header . showDate) dates))
(Tbl.Group DoubleLine [ Tbl.Group SingleLine [Header "Portfolio value", Header "Unit balance"] (Tbl.Group DoubleLine [ Tbl.Group SingleLine [Header "Portfolio value", Header "Unit balance"]
@ -226,11 +228,11 @@ internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueB
when showCashFlow $ do when showCashFlow $ do
printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd)) printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
let (dates, amounts) = unzip totalCF let (dates, amounts) = unzip totalCF
putStrLn $ Ascii.render prettyTables T.unpack id id TL.putStrLn $ Ascii.render prettyTables id id id
(Table (Table
(Tbl.Group NoLine (map (Header . showDate) dates)) (Tbl.Group NoLine (map (Header . showDate) dates))
(Tbl.Group SingleLine [Header "Amount"]) (Tbl.Group SingleLine [Header "Amount"])
(map ((:[]) . show) amounts)) (map ((:[]) . T.pack . show) amounts))
-- 0% is always a solution, so require at least something here -- 0% is always a solution, so require at least something here
case totalCF of case totalCF of

14
hledger/Hledger/Cli/CompoundBalanceCommand.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -16,8 +17,12 @@ module Hledger.Cli.CompoundBalanceCommand (
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.Time.Calendar (Day, addDays) import Data.Time.Calendar (Day, addDays)
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
import Hledger.Read.CsvReader (CSV, printCSV) import Hledger.Read.CsvReader (CSV, printCSV)
@ -153,7 +158,7 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportspec_=r
-- render appropriately -- render appropriately
render = case outputFormatFromOpts opts of render = case outputFormatFromOpts opts of
"txt" -> TL.pack . compoundBalanceReportAsText ropts' "txt" -> compoundBalanceReportAsText ropts'
"csv" -> printCSV . compoundBalanceReportAsCsv ropts' "csv" -> printCSV . compoundBalanceReportAsCsv ropts'
"html" -> L.renderText . compoundBalanceReportAsHtml ropts' "html" -> L.renderText . compoundBalanceReportAsHtml ropts'
"json" -> toJsonText "json" -> toJsonText
@ -189,10 +194,11 @@ Balance Sheet
Total || 1 1 1 Total || 1 1 1
-} -}
compoundBalanceReportAsText :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> String compoundBalanceReportAsText :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> TL.Text
compoundBalanceReportAsText ropts compoundBalanceReportAsText ropts
(CompoundPeriodicReport title _colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) = (CompoundPeriodicReport title _colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
T.unpack title ++ "\n\n" ++ TB.toLazyText $
TB.fromText title <> TB.fromText "\n\n" <>
balanceReportTableAsText ropts bigtable' balanceReportTableAsText ropts bigtable'
where where
bigtable = bigtable =
@ -218,7 +224,7 @@ compoundBalanceReportAsText ropts
-- convert to table -- convert to table
Table lefthdrs tophdrs cells = balanceReportAsTable ropts r Table lefthdrs tophdrs cells = balanceReportAsTable ropts r
-- tweak the layout -- tweak the layout
t = Table (Tab.Group SingleLine [Header $ T.unpack title, lefthdrs]) tophdrs ([]:cells) t = Table (Tab.Group SingleLine [Header title, lefthdrs]) tophdrs ([]:cells)
-- | Add the second table below the first, discarding its column headings. -- | Add the second table below the first, discarding its column headings.
concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') = concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =

8
hledger/test/amount-rendering.test
View File

@ -31,7 +31,7 @@ hledger -f - register
>>>=0 >>>=0
# 3. balance # 3. balance
hledger -f - balance hledger -f - balance -N
<<< <<<
2010/1/1 2010/1/1
a EUR 1 ; a euro a EUR 1 ; a euro
@ -42,8 +42,6 @@ hledger -f - balance
USD 1 b USD 1 b
EUR -1 EUR -1
USD -1 c USD -1 c
--------------------
0
>>>=0 >>>=0
# 4. a single-commodity zero amount's commodity/decimal places/price is preserved, when possible # 4. a single-commodity zero amount's commodity/decimal places/price is preserved, when possible
@ -63,7 +61,7 @@ hledger -f- print --explicit --empty
# When preserving a zero amount's commodity, we should also preserve # When preserving a zero amount's commodity, we should also preserve
# the amount style, such as where to place the symbol. # the amount style, such as where to place the symbol.
# https://github.com/simonmichael/hledger/issues/230 # https://github.com/simonmichael/hledger/issues/230
hledger -f- balance --tree hledger -f- balance --tree -N
<<< <<<
D 1000,00€ D 1000,00€
@ -79,8 +77,6 @@ D 1000,00€
4000,58€ 1 4000,58€ 1
-1000,58€ D -1000,58€ D
-3000,00€ e -3000,00€ e
--------------------
0
>>>= 0 >>>= 0

8
hledger/test/balance/373-layout.test
View File

@ -16,22 +16,18 @@
1 -1 1 -1
# 1. simple balance report in tree mode with zero/boring parents # 1. simple balance report in tree mode with zero/boring parents
$ hledger -f - bal --tree $ hledger -f - bal --tree -N
0 1:2 0 1:2
1 3 1 3
0 4 0 4
1 5 1 5
--------------------
0
# 2. simple balance report in flat mode # 2. simple balance report in flat mode
$ hledger -f - bal --flat $ hledger -f - bal --flat -N
-1 1:2 -1 1:2
1 1:2:3 1 1:2:3
-1 1:2:3:4 -1 1:2:3:4
1 1:2:3:4:5 1 1:2:3:4:5
--------------------
0
# 3. tabular balance report in flat mode # 3. tabular balance report in flat mode
$ hledger -f - bal -Y $ hledger -f - bal -Y

12
hledger/test/balance/balance.test
View File

@ -27,7 +27,7 @@ hledger -f sample.journal balance --tree o
>>>=0 >>>=0
# 3. Period reporting works for a specific year # 3. Period reporting works for a specific year
hledger -f - balance -b 2016 -e 2017 hledger -f - balance -b 2016 -e 2017 -N
<<< <<<
2015/10/10 Client A | Invoice #1 2015/10/10 Client A | Invoice #1
assets:receivables $10,000.00 assets:receivables $10,000.00
@ -52,13 +52,11 @@ hledger -f - balance -b 2016 -e 2017
$-40.00 assets:checking $-40.00 assets:checking
$50.00 expense:hosting $50.00 expense:hosting
$-10.00 revenue:clients:B $-10.00 revenue:clients:B
--------------------
0
>>>2 >>>2
>>>= 0 >>>= 0
# 4. Period reporting works for two years # 4. Period reporting works for two years
hledger -f - balance --tree -b 2015 -e 2017 hledger -f - balance --tree -b 2015 -e 2017 -N
<<< <<<
2015/10/10 Client A | Invoice #1 2015/10/10 Client A | Invoice #1
assets:receivables $10,000.00 assets:receivables $10,000.00
@ -85,13 +83,11 @@ hledger -f - balance --tree -b 2015 -e 2017
$-10,010.00 revenue:clients $-10,010.00 revenue:clients
$-10,000.00 A $-10,000.00 A
$-10.00 B $-10.00 B
--------------------
0
>>>2 >>>2
>>>= 0 >>>= 0
# 5. Period reporting works for one month # 5. Period reporting works for one month
hledger -f - balance --tree -b 2015/11 -e 2015/12 hledger -f - balance --tree -b 2015/11 -e 2015/12 -N
<<< <<<
2015/10/10 Client A | Invoice #1 2015/10/10 Client A | Invoice #1
assets:receivables $10,000.00 assets:receivables $10,000.00
@ -116,8 +112,6 @@ hledger -f - balance --tree -b 2015/11 -e 2015/12
0 assets 0 assets
$10,000.00 checking $10,000.00 checking
$-10,000.00 receivables $-10,000.00 receivables
--------------------
0
>>>2 >>>2
>>>= 0 >>>= 0

4
hledger/test/balance/date2.test
View File

@ -1,4 +1,4 @@
hledger -f - balance -p 'in 2009' --date2 hledger -f - balance -p 'in 2009' --date2 -N
<<< <<<
2009/1/1 x 2009/1/1 x
a 1 a 1
@ -10,6 +10,4 @@ hledger -f - balance -p 'in 2009' --date2
>>> >>>
1 a 1 a
-1 b -1 b
--------------------
0
>>>=0 >>>=0