2012-11-20 06:23:23 +04:00
|
|
|
-- | /register handlers.
|
|
|
|
|
2021-08-27 14:13:28 +03:00
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE QuasiQuotes #-}
|
2018-06-10 02:39:05 +03:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2021-08-27 14:13:28 +03:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{-# LANGUAGE TupleSections #-}
|
2018-06-10 02:39:05 +03:00
|
|
|
|
2018-06-18 12:23:44 +03:00
|
|
|
module Hledger.Web.Handler.RegisterR where
|
2012-11-20 06:23:23 +04:00
|
|
|
|
2019-06-08 11:01:43 +03:00
|
|
|
import Data.List (intersperse, nub, partition)
|
lib: textification begins! account names
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.
This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:
hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text: <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>
hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text: <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>
hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text: <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>
hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text: <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
2016-05-24 04:16:21 +03:00
|
|
|
import qualified Data.Text as T
|
2018-06-10 02:39:05 +03:00
|
|
|
import Text.Hamlet (hamletFile)
|
2012-11-20 06:23:23 +04:00
|
|
|
|
2018-06-09 14:46:08 +03:00
|
|
|
import Hledger
|
2015-08-28 22:33:33 +03:00
|
|
|
import Hledger.Cli.CliOptions
|
2018-06-18 12:23:44 +03:00
|
|
|
import Hledger.Web.Import
|
2015-08-28 22:33:33 +03:00
|
|
|
import Hledger.Web.WebOptions
|
2018-06-18 12:23:44 +03:00
|
|
|
import Hledger.Web.Widget.AddForm (addModal)
|
2020-05-24 19:57:50 +03:00
|
|
|
import Hledger.Web.Widget.Common
|
2020-05-26 14:04:26 +03:00
|
|
|
(accountQuery, mixedAmountAsHtml,
|
2021-01-26 22:50:30 +03:00
|
|
|
transactionFragment, removeDates, removeInacct, replaceInacct)
|
2012-11-20 06:23:23 +04:00
|
|
|
|
|
|
|
-- | The main journal/account register view, with accounts sidebar.
|
2014-05-21 15:30:54 +04:00
|
|
|
getRegisterR :: Handler Html
|
2012-11-20 06:23:23 +04:00
|
|
|
getRegisterR = do
|
2019-08-17 09:55:56 +03:00
|
|
|
checkServerSideUiEnabled
|
2023-05-02 02:23:33 +03:00
|
|
|
VD{caps, j, q, opts, qparam, qopts, today} <- getViewData
|
2018-06-24 17:25:22 +03:00
|
|
|
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
|
|
|
|
|
2018-06-10 02:39:05 +03:00
|
|
|
let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
|
|
|
|
s1 = if inclsubs then "" else " (excluding subaccounts)"
|
2023-05-02 02:23:33 +03:00
|
|
|
s2 = if q /= Any then ", filtered" else ""
|
2018-06-10 02:39:05 +03:00
|
|
|
header = a <> s1 <> s2
|
2014-06-13 03:14:41 +04:00
|
|
|
|
2020-09-16 04:45:52 +03:00
|
|
|
let rspec = reportspec_ (cliopts_ opts)
|
2018-06-17 18:42:41 +03:00
|
|
|
acctQuery = fromMaybe Any (inAccountQuery qopts)
|
2023-05-02 02:23:33 +03:00
|
|
|
acctlink acc = (RegisterR, [("q", replaceInacct qparam $ accountQuery acc)])
|
2019-06-08 11:01:43 +03:00
|
|
|
otherTransAccounts =
|
2019-06-10 20:33:16 +03:00
|
|
|
map (\(acct,(name,comma)) -> (acct, (T.pack name, T.pack comma))) .
|
|
|
|
undecorateLinks . elideRightDecorated 40 . decorateLinks .
|
2023-05-02 02:23:33 +03:00
|
|
|
addCommas . preferReal . otherTransactionAccounts q acctQuery
|
2019-06-10 20:33:16 +03:00
|
|
|
addCommas xs =
|
|
|
|
zip xs $
|
|
|
|
zip (map (T.unpack . accountSummarisedName . paccount) xs) $
|
|
|
|
tail $ (", "<$xs) ++ [""]
|
2023-05-02 02:23:33 +03:00
|
|
|
items = accountTransactionsReport rspec{_rsQuery=q} j acctQuery
|
2020-10-27 12:02:47 +03:00
|
|
|
balancelabel
|
2021-07-23 09:47:48 +03:00
|
|
|
| isJust (inAccount qopts), balanceaccum_ (_rsReportOpts rspec) == Historical = "Historical Total"
|
2020-10-27 12:02:47 +03:00
|
|
|
| isJust (inAccount qopts) = "Period Total"
|
|
|
|
| otherwise = "Total"
|
2020-05-25 11:06:20 +03:00
|
|
|
transactionFrag = transactionFragment j
|
2018-06-10 02:39:05 +03:00
|
|
|
defaultLayout $ do
|
|
|
|
setTitle "register - hledger-web"
|
|
|
|
$(widgetFile "register")
|
2014-06-13 03:14:41 +04:00
|
|
|
|
2019-06-08 11:01:43 +03:00
|
|
|
-- cf. Hledger.Reports.AccountTransactionsReport.accountTransactionsReportItems
|
|
|
|
otherTransactionAccounts :: Query -> Query -> Transaction -> [Posting]
|
|
|
|
otherTransactionAccounts reportq thisacctq torig
|
|
|
|
-- no current account ? summarise all matched postings
|
|
|
|
| thisacctq == None = reportps
|
|
|
|
-- only postings to current account ? summarise those
|
|
|
|
| null otheraccts = thisacctps
|
|
|
|
-- summarise matched postings to other account(s)
|
|
|
|
| otherwise = otheracctps
|
|
|
|
where
|
|
|
|
reportps = tpostings $ filterTransactionPostings reportq torig
|
|
|
|
(thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps
|
|
|
|
otheraccts = nub $ map paccount otheracctps
|
|
|
|
|
|
|
|
-- cf. Hledger.Reports.AccountTransactionsReport.summarisePostingAccounts
|
|
|
|
preferReal :: [Posting] -> [Posting]
|
|
|
|
preferReal ps
|
|
|
|
| null realps = ps
|
|
|
|
| otherwise = realps
|
|
|
|
where realps = filter isReal ps
|
|
|
|
|
2019-06-10 20:33:16 +03:00
|
|
|
elideRightDecorated :: Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
|
|
|
|
elideRightDecorated width s =
|
|
|
|
if length s > width
|
2021-08-27 14:13:28 +03:00
|
|
|
then take (width - 2) s ++ map (Nothing,) ".."
|
2019-06-10 20:33:16 +03:00
|
|
|
else s
|
|
|
|
|
|
|
|
undecorateLinks :: [(Maybe acct, char)] -> [(acct, ([char], [char]))]
|
|
|
|
undecorateLinks [] = []
|
|
|
|
undecorateLinks xs0@(x:_) =
|
|
|
|
case x of
|
|
|
|
(Just acct, _) ->
|
|
|
|
let (link, xs1) = span (isJust . fst) xs0
|
|
|
|
(comma, xs2) = span (isNothing . fst) xs1
|
|
|
|
in (acct, (map snd link, map snd comma)) : undecorateLinks xs2
|
2020-08-06 02:05:56 +03:00
|
|
|
_ -> error "link name not decorated with account" -- PARTIAL:
|
2019-06-10 20:33:16 +03:00
|
|
|
|
|
|
|
decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)]
|
2021-08-27 14:13:28 +03:00
|
|
|
decorateLinks = concatMap $ \(acct, (name, comma)) ->
|
|
|
|
map (Just acct,) name ++ map (Nothing,) comma
|
2019-06-10 20:33:16 +03:00
|
|
|
|
2019-05-24 08:12:12 +03:00
|
|
|
-- | Generate javascript/html for a register balance line chart based on
|
2021-06-23 05:00:59 +03:00
|
|
|
-- the provided "AccountTransactionsReportItem"s.
|
|
|
|
registerChartHtml :: Text -> String -> [(CommoditySymbol, [AccountTransactionsReportItem])] -> HtmlUrl AppRoute
|
2021-01-26 22:50:30 +03:00
|
|
|
registerChartHtml q title percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
|
2019-05-24 08:12:12 +03:00
|
|
|
-- have to make sure plot is not called when our container (maincontent)
|
|
|
|
-- is hidden, eg with add form toggled
|
|
|
|
where
|
2020-10-27 12:02:47 +03:00
|
|
|
charttitle = if null title then "" else title ++ ":"
|
2019-05-24 08:12:12 +03:00
|
|
|
colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
|
|
|
|
commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
|
2021-07-09 08:50:28 +03:00
|
|
|
simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts . mixedAmountStripPrices
|
|
|
|
showZeroCommodity = wbUnpack . showMixedAmountB oneLine{displayPrice=False,displayZeroCommodity=True}
|
2019-05-24 08:12:12 +03:00
|
|
|
shownull c = if null c then " " else c
|
2021-01-26 22:50:30 +03:00
|
|
|
nodatelink = (RegisterR, [("q", T.unwords $ removeDates q)])
|
2018-06-09 11:57:22 +03:00
|
|
|
|
|
|
|
dayToJsTimestamp :: Day -> Integer
|
|
|
|
dayToJsTimestamp d =
|
|
|
|
read (formatTime defaultTimeLocale "%s" t) * 1000 -- XXX read
|
|
|
|
where
|
|
|
|
t = UTCTime d (secondsToDiffTime 0)
|
2019-02-18 18:55:29 +03:00
|
|
|
|