From 02516ef9871817593930b4342229f852b45ac7d9 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sun, 14 Jan 2018 18:09:50 -0800 Subject: [PATCH] bal/bs/bse/cf/is: basic HTML output --- hledger/Hledger/Cli/CliOptions.hs | 3 +- hledger/Hledger/Cli/Commands/Balance.hs | 92 ++++++++++++++----- hledger/Hledger/Cli/Commands/Print.hs | 5 +- hledger/Hledger/Cli/Commands/Register.hs | 5 +- hledger/Hledger/Cli/CompoundBalanceCommand.hs | 61 +++++++++++- hledger/hledger.cabal | 3 +- hledger/package.yaml | 1 + 7 files changed, 138 insertions(+), 32 deletions(-) diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 6322a10ab..6a872fb3b 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -161,7 +161,7 @@ reportflags = [ -- | Common output-related flags: --output-file, --output-format... outputflags = [outputFormatFlag, outputFileFlag] -outputFormatFlag = flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats:\ntxt, csv." +outputFormatFlag = flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats:\ntxt, csv, html." outputFileFlag = flagReq ["output-file","o"] (\s opts -> Right $ setopt "output-file" s opts) "FILE" "write output to FILE. A file extension matching one of the above formats selects that format." argsFlag :: FlagHelp -> Arg RawOpts @@ -524,6 +524,7 @@ defaultOutputFormat = "txt" outputFormats = [defaultOutputFormat] ++ ["csv" + ,"html" ] -- | Get the output format from the --output-format option, diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index e546e1808..fa486287c 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/hledger/Hledger/Cli/Commands/Balance.hs @@ -233,6 +233,8 @@ Currently, empty cells show 0. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hledger.Cli.Commands.Balance ( balancemode @@ -241,6 +243,8 @@ module Hledger.Cli.Commands.Balance ( ,balanceReportItemAsText ,multiBalanceReportAsText ,multiBalanceReportAsCsv + ,multiBalanceReportAsHtml + ,multiBalanceReportHtmlRows ,renderBalanceReportTable ,balanceReportAsTable ,tests_Hledger_Cli_Commands_Balance @@ -249,10 +253,11 @@ module Hledger.Cli.Commands.Balance ( import Data.List (intercalate, nub) import Data.Maybe import qualified Data.Map as Map --- import Data.Monoid import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import System.Console.CmdArgs.Explicit as C import Data.Decimal (roundTo) +import Lucid as L import Text.CSV import Test.HUnit import Text.Printf (printf) @@ -320,8 +325,9 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do in singleBalanceReport ropts' (queryFromOpts d ropts) j | otherwise = balanceReport ropts (queryFromOpts d ropts) j render = case format of - "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r - _ -> balanceReportAsText + "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r + "html" -> \_ _ -> error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO + _ -> balanceReportAsText writeOutput opts $ render ropts report _ | boolopt "budget" rawopts -> do @@ -332,14 +338,16 @@ balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do render = case format of -- XXX: implement csv rendering "csv" -> (++ "\n") . printCSV . multiBalanceReportAsCsv ropts + "html" -> const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO _ -> multiBalanceReportWithBudgetAsText ropts budgetReport writeOutput opts $ render report | otherwise -> do let report = multiBalanceReport ropts (queryFromOpts d ropts) j render = case format of - "csv" -> (++ "\n") . printCSV . multiBalanceReportAsCsv ropts - _ -> multiBalanceReportAsText ropts + "csv" -> (++ "\n") . printCSV . multiBalanceReportAsCsv ropts + "html" -> (++ "\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts + _ -> multiBalanceReportAsText ropts writeOutput opts $ render report -- | Re-map account names to closet parent with periodic transaction from budget. @@ -503,17 +511,19 @@ renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) TotalField -> fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showamt total)) where showamt | color_ opts = cshowMixedAmountWithoutPrice - | otherwise = showMixedAmountWithoutPrice + | otherwise = showMixedAmountWithoutPrice _ -> "" -- multi-column balance reports -- | Render a multi-column balance report as CSV. +-- The CSV will always include the initial headings row, +-- and will include the final totals row unless --no-total is set. multiBalanceReportAsCsv :: ReportOpts -> MultiBalanceReport -> CSV multiBalanceReportAsCsv opts (MultiBalanceReport (colspans, items, (coltotals,tot,avg))) = - ("account" : map showDateSpan colspans - ++ (if row_total_ opts then ["total"] else []) - ++ (if average_ opts then ["average"] else []) + ("Account" : map showDateSpan colspans + ++ (if row_total_ opts then ["Total"] else []) + ++ (if average_ opts then ["Average"] else []) ) : [T.unpack a : map showMixedAmountOneLineWithoutPrice @@ -524,13 +534,49 @@ multiBalanceReportAsCsv opts (MultiBalanceReport (colspans, items, (coltotals,to ++ if no_total_ opts then [] - else [["totals"] + else [["Total:"] ++ map showMixedAmountOneLineWithoutPrice ( coltotals ++ (if row_total_ opts then [tot] else []) ++ (if average_ opts then [avg] else []) )] +-- | Render a multi-column balance report as HTML. +multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html () +multiBalanceReportAsHtml ropts mbr = + let + (headingsrow,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr + in + table_ $ mconcat $ + [headingsrow] + ++ bodyrows + ++ maybe [] (:[]) mtotalsrow + +-- | Render the HTML table rows for a MultiBalanceReport. +-- Returns the heading row, 0 or more body rows, and the totals row if enabled. +multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ())) +multiBalanceReportHtmlRows ropts mbr = + let + headingsrow:rest = multiBalanceReportAsCsv ropts mbr + (bodyrows, mtotalsrow) | no_total_ ropts = (rest, Nothing) + | otherwise = (init rest, Just $ last rest) + in + (thRow headingsrow + ,map multiBalanceReportHtmlBodyRow bodyrows + ,thRow <$> mtotalsrow + ) + +-- | Render one MultiBalanceReport data row as a HTML table row. +multiBalanceReportHtmlBodyRow :: [String] -> Html () +multiBalanceReportHtmlBodyRow [] = mempty -- shouldn't happen +multiBalanceReportHtmlBodyRow (acct:amts) = + tr_ $ mconcat $ + td_ (toHtml acct) : + [td_ [style_ "text-align:right"] (toHtml amt) | amt <- amts] + +thRow :: [String] -> Html () +thRow = tr_ . mconcat . map (th_ . toHtml) + -- | Render a multi-column balance report as plain text suitable for console output. multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String multiBalanceReportAsText opts r = @@ -559,16 +605,16 @@ multiBalanceReportWithBudgetAsText opts budget r = CumulativeChange -> "Ending balances (cumulative)" HistoricalBalance -> "Ending balances (historical)" showcell (real, Nothing) = showamt real - showcell (real, Just budget) = + showcell (real, Just budget) = case percentage real budget of Just pct -> printf "%s [%s%% of %s]" (showamt real) (show $ roundTo 0 pct) (showamt budget) Nothing -> printf "%s [%s]" (showamt real) (showamt budget) percentage real budget = -- percentage of budget consumed is always computed in the cost basis case (toCost real, toCost budget) of - (Mixed [a1], Mixed [a2]) + (Mixed [a1], Mixed [a2]) | isReallyZeroAmount a1 -> Just 0 -- if there are no postings, we consumed 0% of budget - | acommodity a1 == acommodity a2 && aquantity a2 /= 0 -> + | acommodity a1 == acommodity a2 && aquantity a2 /= 0 -> Just $ 100 * aquantity a1 / aquantity a2 _ -> Nothing where @@ -582,11 +628,11 @@ multiBalanceReportWithBudgetAsText opts budget r = -- Both of these are satisfied by construction of budget report and process of rolling up -- account names. combine (Table l t d) (Table l' t' d') = Table l t combinedRows - where + where -- For all accounts that are present in the budget, zip real amounts with budget amounts - combinedRows = [ combineRow row budgetRow + combinedRows = [ combineRow row budgetRow | (acct, row) <- zip (headerContents l) d - , let budgetRow = + , let budgetRow = if acct == "" then [] -- "" is totals row else fromMaybe [] $ Map.lookup acct budgetAccts ] @@ -594,26 +640,26 @@ multiBalanceReportWithBudgetAsText opts budget r = -- Headers for budget row will always be a sublist of headers of row combineRow r br = let reportRow = zip (headerContents t) r - budgetRow = Map.fromList $ zip (headerContents t') br - findBudgetVal hdr = Map.lookup hdr budgetRow + budgetRow = Map.fromList $ zip (headerContents t') br + findBudgetVal hdr = Map.lookup hdr budgetRow in map (\(hdr, val) -> (val, findBudgetVal hdr)) reportRow budgetAccts = Map.fromList $ zip (headerContents l') d' - + -- | Given a table representing a multi-column balance report (for example, -- made using 'balanceReportAsTable'), render it in a format suitable for -- console output. renderBalanceReportTable :: ReportOpts -> Table String String MixedAmount -> String -renderBalanceReportTable ropts = +renderBalanceReportTable ropts = renderBalanceReportTable' ropts showamt where showamt | color_ ropts = cshowMixedAmountOneLineWithoutPrice | otherwise = showMixedAmountOneLineWithoutPrice - + renderBalanceReportTable' :: ReportOpts -> (a -> String) -> Table String String a -> String -renderBalanceReportTable' (ReportOpts { pretty_tables_ = pretty}) showCell = +renderBalanceReportTable' (ReportOpts { pretty_tables_ = pretty}) showCell = unlines . addtrailingblank - . trimborder + . trimborder . lines . render pretty id id showCell . align diff --git a/hledger/Hledger/Cli/Commands/Print.hs b/hledger/Hledger/Cli/Commands/Print.hs index cd60a601f..4d06b6090 100644 --- a/hledger/Hledger/Cli/Commands/Print.hs +++ b/hledger/Hledger/Cli/Commands/Print.hs @@ -59,8 +59,9 @@ printEntries opts@CliOpts{reportopts_=ropts} j = do let q = queryFromOpts d ropts fmt = outputFormatFromOpts opts (render, ropts') = case fmt of - "csv" -> ((++"\n") . printCSV . entriesReportAsCsv, ropts{accountlistmode_=ALFlat}) - _ -> (entriesReportAsText opts, ropts) + "csv" -> ((++"\n") . printCSV . entriesReportAsCsv, ropts{accountlistmode_=ALFlat}) + "html" -> (const $ error' "Sorry, HTML output is not yet implemented for this kind of report.", ropts{accountlistmode_=ALFlat}) -- TODO + _ -> (entriesReportAsText opts, ropts) writeOutput opts $ render $ entriesReport ropts' q j entriesReportAsText :: CliOpts -> EntriesReport -> String diff --git a/hledger/Hledger/Cli/Commands/Register.hs b/hledger/Hledger/Cli/Commands/Register.hs index 640770c36..c90c66e7d 100644 --- a/hledger/Hledger/Cli/Commands/Register.hs +++ b/hledger/Hledger/Cli/Commands/Register.hs @@ -61,8 +61,9 @@ register :: CliOpts -> Journal -> IO () register opts@CliOpts{reportopts_=ropts} j = do d <- getCurrentDay let fmt = outputFormatFromOpts opts - render | fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv) - | otherwise = postingsReportAsText + render | fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv) + | fmt=="html" = const $ error' "Sorry, HTML output is not yet implemented for this kind of report." -- TODO + | otherwise = postingsReportAsText writeOutput opts $ render opts $ postingsReport ropts (queryFromOpts d ropts) j postingsReportAsCsv :: PostingsReport -> CSV diff --git a/hledger/Hledger/Cli/CompoundBalanceCommand.hs b/hledger/Hledger/Cli/CompoundBalanceCommand.hs index c0a7e81c3..068889337 100644 --- a/hledger/Hledger/Cli/CompoundBalanceCommand.hs +++ b/hledger/Hledger/Cli/CompoundBalanceCommand.hs @@ -15,9 +15,12 @@ module Hledger.Cli.CompoundBalanceCommand ( import Data.List (intercalate, foldl') import Data.Maybe (fromMaybe) import Data.Monoid (Sum(..), (<>)) +import qualified Data.Text +import qualified Data.Text.Lazy as TL import Data.Tuple.HT (uncurry3) import System.Console.CmdArgs.Explicit as C import Text.CSV +import Lucid as L import Text.Tabular as T import Hledger @@ -181,8 +184,9 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{command_=cmd, -- render appropriately writeOutput opts $ case format of - "csv" -> printCSV (compoundBalanceReportAsCsv ropts cbr) ++ "\n" - _ -> compoundBalanceReportAsText ropts' cbr + "csv" -> printCSV (compoundBalanceReportAsCsv ropts cbr) ++ "\n" + "html" -> (++ "\n") $ TL.unpack $ L.renderText $ compoundBalanceReportAsHtml ropts cbr + _ -> compoundBalanceReportAsText ropts' cbr -- | Run one subreport for a compound balance command in single-column mode. -- Currently this returns the plain text rendering of the subreport, and its total. @@ -347,4 +351,55 @@ compoundBalanceReportAsCsv ropts (title, colspans, subreports, (coltotals, grand ++ (if row_total_ ropts then [grandtotal] else []) ++ (if average_ ropts then [grandavg] else []) ) - ]) \ No newline at end of file + ]) + +-- | Render a compound balance report as HTML. +compoundBalanceReportAsHtml :: ReportOpts -> CompoundBalanceReport -> Html () +compoundBalanceReportAsHtml ropts cbr = + let + (title, colspans, subreports, (coltotals, grandtotal, grandavg)) = cbr + colspanattr = colspan_ $ Data.Text.pack $ show $ length colspans + 1 + leftattr = style_ "text-align:left" + blankrow = tr_ $ td_ [colspanattr] $ toHtmlRaw (" "::String) + + titlerows = + [tr_ $ th_ [colspanattr, leftattr] $ toHtml title] + ++ [thRow $ + "" : + map showDateSpan colspans + ++ (if row_total_ ropts then ["Total"] else []) + ++ (if average_ ropts then ["Average"] else []) + ] + + -- Make rows for a subreport: its title row, not the headings row, + -- the data rows, any totals row, and a blank row for whitespace. + subreportrows :: (String, MultiBalanceReport) -> [Html ()] + subreportrows (subreporttitle, mbr) = + let + (_,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr + in + [tr_ $ th_ [colspanattr, leftattr] $ toHtml subreporttitle] + ++ bodyrows + ++ maybe [] (:[]) mtotalsrow + ++ [blankrow] + + totalrows | no_total_ ropts || length subreports == 1 = [] + | otherwise = + [thRow $ + "Grand Total:" : + map showMixedAmountOneLineWithoutPrice ( + coltotals + ++ (if row_total_ ropts then [grandtotal] else []) + ++ (if average_ ropts then [grandavg] else []) + ) + ] + in + table_ $ mconcat $ + titlerows + ++ [blankrow] + ++ concatMap subreportrows subreports + ++ totalrows + +thRow :: [String] -> Html () +thRow = tr_ . mconcat . map (th_ . toHtml) + diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 6dedb08a8..45869d253 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b3929eebc33ec5bd2e240d49c003aba48ddc1d4f0e9a09ca2e8161d531bd9fb3 +-- hash: cb1407ac28a973e8fc74c9e78c06c2c29715873a64eb4586417cf02d12bfa60f name: hledger version: 1.5.99 @@ -97,6 +97,7 @@ library , haskeline >=0.6 , here , hledger-lib >=1.5.99 && <1.6 + , lucid , megaparsec >=5.0 , mtl , mtl-compat diff --git a/hledger/package.yaml b/hledger/package.yaml index d611c5cc8..6b5883160 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -138,6 +138,7 @@ library: - hashable >=1.2.4 - haskeline >=0.6 - HUnit + - lucid - mtl - mtl-compat - old-time