From 86c3d7d656c14e6a9f95516efd91dde3661d5005 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Thu, 17 Oct 2024 23:03:28 +0200 Subject: [PATCH] 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 | 95 ++++++++++++++++++++++++ hledger/Hledger/Cli/Commands/Balance.hs | 66 +--------------- hledger/Hledger/Cli/Commands/Register.hs | 34 ++++++--- hledger/hledger.cabal | 1 + hledger/package.yaml | 1 + 5 files changed, 121 insertions(+), 76 deletions(-) create mode 100644 hledger/Hledger/Cli/Anchor.hs diff --git a/hledger/Hledger/Cli/Anchor.hs b/hledger/Hledger/Cli/Anchor.hs new file mode 100644 index 000000000..39a0cdbd5 --- /dev/null +++ b/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} diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index e1f26ea94..816d6140d 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/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 :: diff --git a/hledger/Hledger/Cli/Commands/Register.hs b/hledger/Hledger/Cli/Commands/Register.hs index f407862b2..7ea6f0763 100644 --- a/hledger/Hledger/Cli/Commands/Register.hs +++ b/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]] -postingsReportAsSpreadsheet fmt is = + AmountFormat -> Maybe Text -> [Text] -> + 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] -postingsReportItemAsRecord fmt (_, _, _, p, b) = + AmountFormat -> Maybe Text -> [Text] -> + PostingsReportItem -> [Spr.Cell border T.Text] +postingsReportItemAsRecord fmt base query (_, _, _, p, b) = [(cell idx) {Spr.cellType = Spr.TypeInteger}, - (cell date) {Spr.cellType = Spr.TypeDate}, - cell code, cell desc, cell acct, + (dateCell base query (paccount p) date) {Spr.cellType = Spr.TypeDate}, + 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 diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 661964c75..731806bc1 100644 --- a/hledger/hledger.cabal +++ b/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 diff --git a/hledger/package.yaml b/hledger/package.yaml index becd774e8..ab80b9506 100644 --- a/hledger/package.yaml +++ b/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