Merge 125bf88d42 into eeb070195c

Journal page contains links to those reports.

hledger-web/Hledger/Web/App.hs

@@ -144,6 +144,8 @@ instance Yesod App where
           }
         rspec' = rspec{_rsQuery=q,_rsReportOpts=ropts'}
 
+    maybePeriod <- lookupGetParam "period"
+
     hideEmptyAccts <- if empty_ ropts
                          then return True
                          else (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest

hledger-web/Hledger/Web/Application.hs

@@ -28,6 +28,7 @@ import Hledger.Web.Handler.EditR
 import Hledger.Web.Handler.UploadR
 import Hledger.Web.Handler.JournalR
 import Hledger.Web.Handler.RegisterR
+import Hledger.Web.Handler.BalanceR
 import Hledger.Web.Import
 import Hledger.Web.WebOptions (WebOpts(serve_,serve_api_), corsPolicy)
 

hledger-web/Hledger/Web/Handler/BalanceR.hs

@@ -0,0 +1,62 @@
+-- | /balance handlers.
+
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hledger.Web.Handler.BalanceR where
+
+import Hledger
+import Hledger.Cli.CliOptions
+import Hledger.Write.Html.Blaze (printHtml)
+import Hledger.Web.Import
+import Hledger.Web.WebOptions
+import qualified Hledger.Cli.Commands.Balance as Balance
+import qualified Hledger.Query as Query
+
+import Text.Megaparsec.Error (errorBundlePretty)
+import qualified Text.Blaze.Html4.Strict as Blaze
+import qualified Data.Text as Text
+import qualified Yesod
+
+
+-- | The balance or multi-period balance view, with sidebar.
+getBalanceR :: Handler Html
+getBalanceR = do
+  checkServerSideUiEnabled
+  VD{j, q, qparam, opts, today} <- getViewData
+  require ViewPermission
+  let title :: Text
+      title = "Balance Report" <> if q /= Any then ", filtered" else ""
+      rspecOrig = reportspec_ $ cliopts_ opts
+      ropts =
+        (_rsReportOpts rspecOrig) {
+          balance_base_url_ = Just "",
+          querystring_ = Query.words'' queryprefixes qparam
+        }
+      rspec =
+        rspecOrig {
+          _rsQuery = filterQuery (not . queryIsDepth) q,
+          _rsReportOpts = ropts
+        }
+
+  defaultLayout $ do
+    mperiod <- lookupGetParam "period"
+    case mperiod of
+      Nothing -> do
+        setTitle "balance - hledger-web"
+        Yesod.toWidget .
+          (Blaze.h2 (Blaze.toHtml title) >>) .
+          printHtml . map (map (fmap Blaze.toHtml)) .
+          Balance.balanceReportAsSpreadsheet ropts $
+            balanceReport rspec j
+      Just perStr -> do
+        setTitle "multibalance - hledger-web"
+        case parsePeriodExpr today perStr of
+          Left msg -> Yesod.toWidget $ Text.pack $ errorBundlePretty msg
+          Right (per_,_) ->
+            Yesod.toWidget .
+              (Blaze.h2 (Blaze.toHtml title) >>) .
+              printHtml . map (map (fmap Blaze.toHtml)) .
+              snd . Balance.multiBalanceReportAsSpreadsheet ropts $
+                let rspec' = rspec{_rsReportOpts = ropts{interval_ = per_}} in
+                multiBalanceReport rspec' j

hledger-web/Hledger/Web/Handler/JournalR.hs

@@ -16,6 +16,8 @@ import Hledger.Web.Widget.Common
             (accountQuery, mixedAmountAsHtml,
              transactionFragment, replaceInacct)
 
+import qualified Data.Text as Text
+
 -- | The formatted journal view, with sidebar.
 getJournalR :: Handler Html
 getJournalR = do
@@ -27,6 +29,9 @@ getJournalR = do
         Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)"
       title' = title <> if q /= Any then ", filtered" else ""
       acctlink a = (RegisterR, [("q", replaceInacct qparam $ accountQuery a)])
+      qparamOpt = if Text.null qparam then [] else [("q",qparam)]
+      ballink = (BalanceR, qparamOpt)
+      multiballink per_ = (BalanceR, ("period",per_) : qparamOpt)
       rspec = (reportspec_ $ cliopts_ opts){_rsQuery = filterQuery (not . queryIsDepth) q}
       items = reverse $
         styleAmounts (journalCommodityStylesWith HardRounding j) $

hledger-web/config/routes

@@ -5,6 +5,7 @@
 /                RootR           GET
 /journal         JournalR        GET
 /register        RegisterR       GET
+/balance         BalanceR        GET
 /add             AddR            GET POST PUT
 
 /manage             ManageR         GET

hledger-web/hledger-web.cabal

@@ -143,6 +143,7 @@ library
   other-modules:
       Hledger.Web.App
       Hledger.Web.Handler.AddR
+      Hledger.Web.Handler.BalanceR
       Hledger.Web.Handler.EditR
       Hledger.Web.Handler.JournalR
       Hledger.Web.Handler.MiscR
@@ -184,6 +185,7 @@ library
     , http-client
     , http-conduit
     , http-types
+    , lucid
     , megaparsec >=7.0.0 && <9.7
     , mtl >=2.2.1
     , network

hledger-web/package.yaml

@@ -123,6 +123,7 @@ library:
   - http-conduit
   - http-client
   - http-types
+  - lucid
   - megaparsec >=7.0.0 && <9.7
   - mtl >=2.2.1
   - network

hledger-web/templates/default-layout.hamlet

@@ -19,6 +19,8 @@ $if elem ViewPermission perms
     <form#searchform.input-group method=GET>
       <input .form-control name=q value=#{qparam} placeholder="Search"
         title="Enter hledger search patterns to filter the data below">
+      $maybe period <- maybePeriod
+        <input hidden name=period value=#{period}>
       <div .input-group-btn>
         $if not (T.null qparam)
           <a href=@{here} .btn .btn-default title="Clear search terms">

hledger-web/templates/journal.hamlet

@@ -6,6 +6,20 @@ $if elem AddPermission perms
      data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal">
     Add a transaction
 
+<p>
+  Report:
+  <a href=@?{ballink} title="Show balance report">Balance
+  <a href=@?{multiballink "yearly"}
+      title="Show daily multi-period balance report">Yearly
+  <a href=@?{multiballink "quarterly"}
+      title="Show daily multi-period balance report">Quarterly
+  <a href=@?{multiballink "monthly"}
+      title="Show daily multi-period balance report">Monthly
+  <a href=@?{multiballink "weekly"}
+      title="Show daily multi-period balance report">Weekly
+  <a href=@?{multiballink "daily"}
+      title="Show daily multi-period balance report">Daily
+
 <div .table-responsive>
   <table .transactionsreport .table .table-condensed>
     <thead>

hledger/Hledger/Cli/Commands/Balance.hs

@@ -303,7 +303,6 @@ import Hledger.Cli.Utils
 import Hledger.Write.Csv (CSV, printCSV, printTSV)
 import Hledger.Write.Ods (printFods)
 import Hledger.Write.Html.Lucid (printHtml)
-import Hledger.Write.Html.Attribute (tableStylesheet)
 import qualified Hledger.Write.Html.Lucid as Html
 import qualified Hledger.Write.Spreadsheet as Ods
 
@@ -692,9 +691,10 @@ balanceReportAsSpreadsheet ::
 balanceReportAsSpreadsheet opts (items, total) =
     (if transpose_ opts then Ods.transpose else id) $
     headers :
-    concatMap (\(a, _, _, b) -> rows Value a b) items ++
+    concatMap (rows Value) items ++
     if no_total_ opts then []
-      else addTotalBorders $ rows Total totalRowHeadingSpreadsheet total
+      else addTotalBorders $
+           rows Total (totalRowHeadingSpreadsheet, totalRowHeadingSpreadsheet, 0, total)
   where
     cell = Ods.defaultCell
     headers =
@@ -703,14 +703,14 @@ balanceReportAsSpreadsheet opts (items, total) =
         LayoutBare -> ["commodity", "balance"]
         _          -> ["balance"]
     rows ::
-        RowClass -> AccountName ->
-        MixedAmount -> [[Ods.Cell Ods.NumLines Text]]
-    rows rc name ma =
+        RowClass -> BalanceReportItem ->
+        [[Ods.Cell Ods.NumLines Text]]
+    rows rc (name, dispName, dep, ma) =
       let accountCell =
               setAccountAnchor
                   (guard (rc==Value) >> balance_base_url_ opts)
                   (querystring_ opts) name $
-              cell $ accountNameDrop (drop_ opts) name in
+              cell $ renderBalanceAcct opts nbsp (name, dispName, dep) in
       addRowSpanHeader accountCell $
       case layout_ opts of
       LayoutBare ->
@@ -774,16 +774,16 @@ multiBalanceReportAsCsv opts@ReportOpts{..} report = maybeTranspose allRows
       _ -> rows ++ totals
     rows = header:body
     (header, body, totals) =
-        multiBalanceReportAsSpreadsheetHelper False opts report
+        multiBalanceReportAsSpreadsheetParts False opts report
     maybeTranspose = if transpose_ then transpose else id
 
 -- Helper for CSV and ODS and HTML rendering.
-multiBalanceReportAsSpreadsheetHelper ::
+multiBalanceReportAsSpreadsheetParts ::
     Bool -> ReportOpts -> MultiBalanceReport ->
     ([Ods.Cell Ods.NumLines Text],
      [[Ods.Cell Ods.NumLines Text]],
      [[Ods.Cell Ods.NumLines Text]])
-multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport colspans items tr) =
+multiBalanceReportAsSpreadsheetParts ishtml opts@ReportOpts{..} (PeriodicReport colspans items tr) =
     (headers, concatMap fullRowAsTexts items, addTotalBorders totalrows)
   where
     accountCell label =
@@ -807,7 +807,7 @@ multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport
       where acctName = prrFullName row
             anchorCell =
               setAccountAnchor balance_base_url_ querystring_ acctName $
-              accountCell $ accountNameDrop drop_ acctName
+              accountCell $ renderPeriodicAcct opts nbsp row
     totalrows =
       if no_total_
         then []
@@ -822,15 +822,10 @@ multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport
 -- | Render a multi-column balance report as HTML.
 multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
 multiBalanceReportAsHtml ropts mbr =
-  let
-    (headingsrow,bodyrows,mtotalsrows) = multiBalanceReportHtmlRows ropts mbr
-  in do
+  do
     link_ [rel_ "stylesheet", href_ "hledger.css"]
-    style_ tableStylesheet
-    table_ $ mconcat $
-         [headingsrow]
-      ++ bodyrows
-      ++ mtotalsrows
+    printHtml . map (map (fmap L.toHtml)) $
+      snd $ multiBalanceReportAsSpreadsheet ropts mbr
 
 -- | Render the HTML table rows for a MultiBalanceReport.
 -- Returns the heading row, 0 or more body rows, and the totals row if enabled.
@@ -840,7 +835,7 @@ multiBalanceReportHtmlRows ropts mbr =
     -- TODO: should the commodity_column be displayed as a subaccount in this case as well?
     (headingsrow, bodyrows, mtotalsrows)
       | transpose_ ropts = error' "Sorry, --transpose with HTML output is not yet supported"  -- PARTIAL:
-      | otherwise = multiBalanceReportAsSpreadsheetHelper True ropts mbr
+      | otherwise = multiBalanceReportAsSpreadsheetParts True ropts mbr
     formatRow = Html.formatRow . map (fmap L.toHtml)
   in
     (formatRow headingsrow
@@ -854,7 +849,7 @@ multiBalanceReportAsSpreadsheet ::
   ReportOpts -> MultiBalanceReport ->
   ((Maybe Int, Maybe Int), [[Ods.Cell Ods.NumLines Text]])
 multiBalanceReportAsSpreadsheet ropts mbr =
-  let (header,body,total) = multiBalanceReportAsSpreadsheetHelper True ropts mbr
+  let (header,body,total) = multiBalanceReportAsSpreadsheetParts True ropts mbr
   in  (if transpose_ ropts then swap *** Ods.transpose else id) $
       ((Just 1, case layout_ ropts of LayoutWide _ -> Just 1; _ -> Nothing),
             header : body ++ total)
@@ -1052,7 +1047,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
 
 -- | Build a 'Table' from a multi-column balance report.
 budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text WideBuilder
-budgetReportAsTable ReportOpts{..} (PeriodicReport spans items totrow) =
+budgetReportAsTable ropts@ReportOpts{..} (PeriodicReport spans items totrow) =
   maybetransposetable $
   addtotalrow $
     Table
@@ -1158,17 +1153,10 @@ budgetReportAsTable ReportOpts{..} (PeriodicReport spans items totrow) =
             shownitems =
               map (\i ->
                 let
-                  addacctcolumn = map (\(cs, cvals) -> (renderacct i, cs, cvals))
+                  addacctcolumn = map (\(cs, cvals) -> (renderPeriodicAcct ropts " " i, cs, cvals))
                   isunbudgetedrow = displayFull (prrName i) == unbudgetedAccountName
                 in addacctcolumn $ showrow isunbudgetedrow $ rowToBudgetCells i)
               items
-              where
-                -- FIXME. Have to check explicitly for which to render here, since
-                -- budgetReport sets accountlistmode to ALTree. Find a principled way to do
-                -- this.
-                renderacct row = case accountlistmode_ of
-                  ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
-                  ALFlat -> accountNameDrop (drop_) $ prrFullName row
 
         (totrowcs, totrowtexts)  = unzip  $ concat showntotrow
           where
@@ -1277,7 +1265,7 @@ budgetReportAsCsv ropts report
 budgetReportAsSpreadsheet ::
   ReportOpts -> BudgetReport -> [[Ods.Cell Ods.NumLines Text]]
 budgetReportAsSpreadsheet
-  ReportOpts{..}
+  ropts@ReportOpts{..}
   (PeriodicReport colspans items totrow)
   = (if transpose_ then Ods.transpose else id) $
 
@@ -1291,14 +1279,18 @@ budgetReportAsSpreadsheet
   ) :
 
   -- account rows
-  concatMap (rowAsTexts Value prrFullName) items
+  concatMap (\row -> rowAsTexts Value (accountCell row) row) items
 
   -- totals row
   ++ addTotalBorders
-        (concat [ rowAsTexts Total (const totalRowHeadingBudgetCsv) totrow | not no_total_ ])
+        (concat [ rowAsTexts Total (cell totalRowHeadingBudgetCsv) totrow | not no_total_ ])
 
   where
     cell = Ods.defaultCell
+    accountCell row =
+        let name = prrFullName row in
+        setAccountAnchor (balance_base_url_) querystring_ name $
+        cell $ renderPeriodicAcct ropts nbsp row
     {-
     ToDo: The chosen HTML cell class names are not put in stone.
     If you find you need more systematic names,
@@ -1310,16 +1302,18 @@ budgetReportAsSpreadsheet
         maybe Ods.emptyCell (fmap wbToText . curry (cellFromMixedAmount oneLineNoCostFmt) cls) mval
 
     rowAsTexts :: RowClass
-               -> (PeriodicReportRow a BudgetCell -> Text)
+               -> Ods.Cell Ods.NumLines Text
                -> PeriodicReportRow a BudgetCell
                -> [[Ods.Cell Ods.NumLines Text]]
-    rowAsTexts rc render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg))
-      | layout_ /= LayoutBare = [accountCell : map showNorm vals]
-      | otherwise =
-            joinNames . zipWith (:) (map cell cs)  -- add symbols and names
+    rowAsTexts rc acctCell (PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) =
+      addRowSpanHeader acctCell $
+      case layout_ of
+        LayoutBare ->
+            zipWith (:) (map cell cs)   -- add symbols
           . transpose                   -- each row becomes a list of Text quantities
           . map (map (fmap wbToText) . cellsFromMixedAmount dopts . second (fromMaybe nullmixedamt))
           $ vals
+        _ -> [map showNorm vals]
       where
         cs = S.toList . mconcat . map maCommodities $ mapMaybe snd vals
         dopts = oneLineNoCostFmt{displayCommodity=layout_ /= LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing}
@@ -1331,11 +1325,25 @@ budgetReportAsSpreadsheet
                         (budgetAverageClass rc, budgetavg)]
                             | average_]
 
-        joinNames = map (accountCell :)
-        accountCell =
-            let name = render row in
-            setAccountAnchor (guard (rc==Value) >> balance_base_url_)
-                querystring_ name (cell name)
+
+nbsp :: Text
+nbsp = "\160"
+
+renderBalanceAcct ::
+    ReportOpts -> Text -> (AccountName, AccountName, Int) -> Text
+renderBalanceAcct opts space (fullName, displayName, dep) =
+  case accountlistmode_ opts of
+    ALTree -> T.replicate ((dep - 1)*2) space <> displayName
+    ALFlat -> accountNameDrop (drop_ opts) fullName
+
+-- FIXME. Have to check explicitly for which to render here, since
+-- budgetReport sets accountlistmode to ALTree. Find a principled way to do
+-- this.
+renderPeriodicAcct ::
+    ReportOpts -> Text -> PeriodicReportRow DisplayName a -> Text
+renderPeriodicAcct opts space row =
+    renderBalanceAcct opts space
+        (prrFullName row, prrDisplayName row, prrDepth row)
 
 
 -- tests

hledger/Hledger/Cli/CompoundBalanceCommand.hs

@@ -379,7 +379,8 @@ compoundBalanceReportAsHtml ropts cbr =
             Total simpleDateSpanCell totalrow
                              -- make a table of rendered lines of the report totals row
         & map (map (fmap wbToText))
-        & addRowSpanHeader (Spr.defaultCell "Net:")
+        & addRowSpanHeader
+            ((Spr.defaultCell "Net:") {Spr.cellClass = Spr.Class "account"})
                              -- insert a headings column, with Net: on the first line only
         & addTotalBorders    -- marking the first for special styling
         & map (Html.formatRow . map (fmap L.toHtml))