cli: Commands.Register: support hyperlinks to hledger-web in HTML and FODS output

new option --base-url as in `balance` et.al.

Cli.Anchor: new module initialized with functions from Commands.Balance

hledger/Hledger/Cli/Anchor.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE QuasiQuotes          #-}
+module Hledger.Cli.Anchor (
+    setAccountAnchor,
+    dateCell,
+    dateSpanCell,
+    headerDateSpanCell,
+    ) where
+
+import qualified Data.Text as Text
+import Data.Text (Text)
+import Data.Time (Day)
+import Data.Maybe (fromMaybe)
+
+import qualified Text.URI as Uri
+import qualified Text.URI.QQ as UriQQ
+
+import qualified Hledger.Write.Spreadsheet as Spr
+import Hledger.Write.Spreadsheet (headerCell)
+import Hledger.Utils.Text (quoteIfSpaced)
+import Hledger.Data.Dates (showDateSpan, showDate)
+import Hledger.Data.Types (DateSpan)
+
+
+registerQueryUrl :: [Text] -> Text
+registerQueryUrl query =
+    Uri.render $
+    [UriQQ.uri|register|] {
+        Uri.uriQuery =
+            [Uri.QueryParam [UriQQ.queryKey|q|] $
+             fromMaybe (error "register URI query construction failed") $
+             Uri.mkQueryValue $ Text.unwords $
+             map quoteIfSpaced $ filter (not . Text.null) query]
+    }
+
+{- |
+>>> composeAnchor Nothing ["date:2024"]
+""
+>>> composeAnchor (Just "") ["date:2024"]
+"register?q=date:2024"
+>>> composeAnchor (Just "/") ["date:2024"]
+"/register?q=date:2024"
+>>> composeAnchor (Just "foo") ["date:2024"]
+"foo/register?q=date:2024"
+>>> composeAnchor (Just "foo/") ["date:2024"]
+"foo/register?q=date:2024"
+-}
+composeAnchor :: Maybe Text -> [Text] -> Text
+composeAnchor Nothing _ = mempty
+composeAnchor (Just baseUrl) query =
+    baseUrl <>
+    (if all (('/'==) . snd) $ Text.unsnoc baseUrl then "" else "/") <>
+    registerQueryUrl query
+
+-- cf. Web.Widget.Common
+removeDates :: [Text] -> [Text]
+removeDates =
+    filter (\term_ ->
+        not $ Text.isPrefixOf "date:" term_ || Text.isPrefixOf "date2:" term_)
+
+replaceDate :: Text -> [Text] -> [Text]
+replaceDate prd query = "date:"<>prd : removeDates query
+
+headerDateSpanCell ::
+    Maybe Text -> [Text] -> DateSpan -> Spr.Cell () Text
+headerDateSpanCell base query spn =
+    let prd = showDateSpan spn in
+    (headerCell prd) {
+        Spr.cellAnchor = composeAnchor base $ replaceDate prd query
+    }
+
+
+dateQueryCell ::
+    (Spr.Lines border) =>
+    Maybe Text -> [Text] -> Text -> Text -> Spr.Cell border Text
+dateQueryCell base query acct dateTerm =
+    (Spr.defaultCell dateTerm) {
+        Spr.cellAnchor =
+            composeAnchor base $ "inacct:"<>acct : replaceDate dateTerm query
+    }
+
+dateCell ::
+    (Spr.Lines border) =>
+    Maybe Text -> [Text] -> Text -> Day -> Spr.Cell border Text
+dateCell base query acct = dateQueryCell base query acct . showDate
+
+dateSpanCell ::
+    (Spr.Lines border) =>
+    Maybe Text -> [Text] -> Text -> DateSpan -> Spr.Cell border Text
+dateSpanCell base query acct = dateQueryCell base query acct . showDateSpan
+
+setAccountAnchor ::
+    Maybe Text -> [Text] -> Text -> Spr.Cell border text -> Spr.Cell border text
+setAccountAnchor base query acct cell =
+    cell {Spr.cellAnchor = composeAnchor base $ "inacct:"<>acct : query}

hledger/Hledger/Cli/Commands/Balance.hs

@@ -239,7 +239,6 @@ Currently, empty cells show 0.
 {-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TemplateHaskell      #-}
-{-# LANGUAGE QuasiQuotes          #-}
 
 module Hledger.Cli.Commands.Balance (
   -- ** balance command
@@ -294,8 +293,6 @@ import Data.Time (addDays, fromGregorian)
 import System.Console.CmdArgs.Explicit as C (flagNone, flagReq, flagOpt)
 import Lucid as L hiding (value_)
 import Safe (headMay, maximumMay)
-import qualified Text.URI as Uri
-import qualified Text.URI.QQ as UriQQ
 import Text.Tabular.AsciiWide
     (Header(..), Align(..), Properties(..), Cell(..), Table(..), TableOpts(..),
     cellWidth, concatTables, renderColumns, renderRowB, renderTableByRowsB, textCell)
@@ -305,6 +302,7 @@ import qualified System.IO as IO
 import Hledger
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Utils
+import Hledger.Cli.Anchor (setAccountAnchor, dateSpanCell, headerDateSpanCell)
 import Hledger.Write.Csv (CSV, printCSV, printTSV)
 import Hledger.Write.Ods (printFods)
 import Hledger.Write.Html.Lucid (printHtml)
@@ -596,66 +594,9 @@ renderComponent topaligned oneline opts (acctname, dep, total) (FormatField ljus
                   }
 
 
-registerQueryUrl :: [Text] -> Text
-registerQueryUrl query =
-    Uri.render $
-    [UriQQ.uri|register|] {
-        Uri.uriQuery =
-            [Uri.QueryParam [UriQQ.queryKey|q|] $
-             fromMaybe (error "register URI query construction failed") $
-             Uri.mkQueryValue $ T.unwords $
-             map quoteIfSpaced $ filter (not . T.null) query]
-    }
-
-{- |
->>> composeAnchor Nothing ["date:2024"]
-""
->>> composeAnchor (Just "") ["date:2024"]
-"register?q=date:2024"
->>> composeAnchor (Just "/") ["date:2024"]
-"/register?q=date:2024"
->>> composeAnchor (Just "foo") ["date:2024"]
-"foo/register?q=date:2024"
->>> composeAnchor (Just "foo/") ["date:2024"]
-"foo/register?q=date:2024"
--}
-composeAnchor :: Maybe Text -> [Text] -> Text
-composeAnchor Nothing _ = mempty
-composeAnchor (Just baseUrl) query =
-    baseUrl <>
-    (if all (('/'==) . snd) $ T.unsnoc baseUrl then "" else "/") <>
-    registerQueryUrl query
-
--- cf. Web.Widget.Common
-removeDates :: [Text] -> [Text]
-removeDates =
-    filter (\term_ ->
-        not $ T.isPrefixOf "date:" term_ || T.isPrefixOf "date2:" term_)
-
-replaceDate :: Text -> [Text] -> [Text]
-replaceDate prd query = "date:"<>prd : removeDates query
-
-headerDateSpanCell ::
-    Maybe Text -> [Text] -> DateSpan -> Ods.Cell () Text
-headerDateSpanCell base query spn =
-    let prd = showDateSpan spn in
-    (headerCell prd) {
-        Ods.cellAnchor = composeAnchor base $ replaceDate prd query
-    }
-
 simpleDateSpanCell :: DateSpan -> Ods.Cell Ods.NumLines Text
 simpleDateSpanCell = Ods.defaultCell . showDateSpan
 
-dateSpanCell ::
-    (Ods.Lines border) =>
-    Maybe Text -> [Text] -> Text -> DateSpan -> Ods.Cell border Text
-dateSpanCell base query acct spn =
-    let prd = showDateSpan spn in
-    (Ods.defaultCell prd) {
-        Ods.cellAnchor =
-            composeAnchor base $ "inacct:"<>acct : replaceDate prd query
-    }
-
 addTotalBorders :: [[Ods.Cell border text]] -> [[Ods.Cell Ods.NumLines text]]
 addTotalBorders =
     zipWith
@@ -665,11 +606,6 @@ addTotalBorders =
                     Ods.cellBorder = Ods.noBorder {Ods.borderTop = border}}))
         (Ods.DoubleLine : repeat Ods.NoLine)
 
-setAccountAnchor ::
-    Maybe Text -> [Text] -> Text -> Ods.Cell border text -> Ods.Cell border text
-setAccountAnchor base query acct cell =
-    cell {Ods.cellAnchor = composeAnchor base $ "inacct:"<>acct : query}
-
 
 -- | Render a single-column balance report as FODS.
 balanceReportAsSpreadsheet ::

hledger/Hledger/Cli/Commands/Register.hs

@@ -20,6 +20,7 @@ module Hledger.Cli.Commands.Register (
 
 import Data.Default (def)
 import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
 import qualified Data.Map as Map
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
@@ -34,6 +35,7 @@ import Hledger.Write.Html.Lucid (printHtml)
 import qualified Hledger.Write.Spreadsheet as Spr
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Utils
+import Hledger.Cli.Anchor (setAccountAnchor, dateCell)
 import Text.Tabular.AsciiWide (Cell(..), Align(..), Properties(..), Header(Header, Group), renderRowB, textCell, tableBorders, borderSpaces)
 import qualified Lucid
 import Data.List (sortBy)
@@ -68,6 +70,7 @@ registermode = hledgerCommandMode
       ++ " or $COLUMNS). -wN,M sets description width as well."
      )
   ,flagNone ["align-all"] (setboolopt "align-all") "guarantee alignment across all lines (slower)"
+  ,flagReq  ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URLPREFIX" "in html output, generate links to hledger-web, with this prefix. (Usually the base url shown by hledger-web; can also be relative.)"
   ,outputFormatFlag ["txt","csv","tsv","json"]
   ,outputFileFlag
   ])
@@ -102,40 +105,49 @@ register opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j
            | fmt=="html" =
                 (<>"\n") . Lucid.renderText . printHtml .
                 map (map (fmap Lucid.toHtml)) .
-                postingsReportAsSpreadsheet oneLineNoCostFmt
+                postingsReportAsSpreadsheet oneLineNoCostFmt baseUrl query
            | fmt=="fods" =
                 printFods IO.localeEncoding . Map.singleton "Register" .
                 (,) (Just 1, Nothing) .
-                postingsReportAsSpreadsheet oneLineNoCostFmt
+                postingsReportAsSpreadsheet oneLineNoCostFmt baseUrl query
            | otherwise   = error' $ unsupportedOutputFormatError fmt  -- PARTIAL:
       where fmt = outputFormatFromOpts opts
+            baseUrl = balance_base_url_ $ _rsReportOpts rspec
+            query = querystring_ $ _rsReportOpts rspec
 
 postingsReportAsCsv :: PostingsReport -> CSV
 postingsReportAsCsv =
-  Spr.rawTableContent . postingsReportAsSpreadsheet machineFmt
+  Spr.rawTableContent . postingsReportAsSpreadsheet machineFmt Nothing []
 
 postingsReportAsSpreadsheet ::
-  AmountFormat -> PostingsReport -> [[Spr.Cell Spr.NumLines T.Text]]
+  AmountFormat -> Maybe Text -> [Text] ->
-postingsReportAsSpreadsheet fmt is =
+  PostingsReport -> [[Spr.Cell Spr.NumLines T.Text]]
+postingsReportAsSpreadsheet fmt base query is =
   Spr.addHeaderBorders
     (map Spr.headerCell
       ["txnidx","date","code","description","account","amount","total"])
   :
-  map (postingsReportItemAsRecord fmt) is
+  map (postingsReportItemAsRecord fmt base query) is
 
+{- ToDo:
+link txnidx to journal URL,
+   however, requires Web.Widget.Common.transactionFragment
+-}
 postingsReportItemAsRecord ::
     (Spr.Lines border) =>
-    AmountFormat -> PostingsReportItem -> [Spr.Cell border T.Text]
+    AmountFormat -> Maybe Text -> [Text] ->
-postingsReportItemAsRecord fmt (_, _, _, p, b) =
+    PostingsReportItem -> [Spr.Cell border T.Text]
+postingsReportItemAsRecord fmt base query (_, _, _, p, b) =
     [(cell idx) {Spr.cellType = Spr.TypeInteger},
-     (cell date) {Spr.cellType = Spr.TypeDate},
+     (dateCell base query (paccount p) date) {Spr.cellType = Spr.TypeDate},
-     cell code, cell desc, cell acct,
+     cell code, cell desc,
+     setAccountAnchor base query (paccount p) $ cell acct,
      amountCell (pamount p),
      amountCell b]
   where
     cell = Spr.defaultCell
     idx  = T.pack . show . maybe 0 tindex $ ptransaction p
-    date = showDate $ postingDate p -- XXX csv should show date2 with --date2
+    date = postingDate p -- XXX csv should show date2 with --date2
     code = maybe "" tcode $ ptransaction p
     desc = maybe "" tdescription $ ptransaction p
     acct = bracket $ paccount p

hledger/hledger.cabal

@@ -110,6 +110,7 @@ flag threaded
 library
   exposed-modules:
       Hledger.Cli
+      Hledger.Cli.Anchor
       Hledger.Cli.Anon
       Hledger.Cli.CliOptions
       Hledger.Cli.Commands

hledger/package.yaml

@@ -164,6 +164,7 @@ library:
   cpp-options: -DVERSION="1.40.99"
   exposed-modules:
   - Hledger.Cli
+  - Hledger.Cli.Anchor
   - Hledger.Cli.Anon
   - Hledger.Cli.CliOptions
   - Hledger.Cli.Commands