86c3d7d656
new option --base-url as in `balance` et.al. Cli.Anchor: new module initialized with functions from Commands.Balance
96 lines
2.9 KiB
Haskell
96 lines
2.9 KiB
Haskell
{-# 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}
|