{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Web.Handler.RegisterR where
import Data.List (intersperse, nub, partition)
import qualified Data.Text as T
import Text.Hamlet (hamletFile)
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Web.Import
import Hledger.Web.WebOptions
import Hledger.Web.Widget.AddForm (addModal)
import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml)
getRegisterR :: Handler Html
getRegisterR = do
checkServerSideUiEnabled
VD{caps, j, m, opts, qopts, today} <- getViewData
when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
s1 = if inclsubs then "" else " (excluding subaccounts)"
s2 = if m /= Any then ", filtered" else ""
header = a <> s1 <> s2
let ropts = reportopts_ (cliopts_ opts)
acctQuery = fromMaybe Any (inAccountQuery qopts)
acctlink acc = (RegisterR, [("q", accountQuery acc)])
otherTransAccounts =
map (\(acct,(name,comma)) -> (acct, (T.pack name, T.pack comma))) .
undecorateLinks . elideRightDecorated 40 . decorateLinks .
addCommas . preferReal . otherTransactionAccounts m acctQuery
addCommas xs =
zip xs $
zip (map (T.unpack . accountSummarisedName . paccount) xs) $
tail $ (", "<$xs) ++ [""]
r@(balancelabel,items) = accountTransactionsReport ropts j m acctQuery
balancelabel' = if isJust (inAccount qopts) then balancelabel else "Total"
defaultLayout $ do
setTitle "register - hledger-web"
$(widgetFile "register")
otherTransactionAccounts :: Query -> Query -> Transaction -> [Posting]
otherTransactionAccounts reportq thisacctq torig
| thisacctq == None = reportps
| null otheraccts = thisacctps
| otherwise = otheracctps
where
reportps = tpostings $ filterTransactionPostings reportq torig
(thisacctps, otheracctps) = partition (matchesPosting thisacctq) reportps
otheraccts = nub $ map paccount otheracctps
preferReal :: [Posting] -> [Posting]
preferReal ps
| null realps = ps
| otherwise = realps
where realps = filter isReal ps
elideRightDecorated :: Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated width s =
if length s > width
then take (width - 2) s ++ map ((,) Nothing) ".."
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
_ -> error "link name not decorated with account"
decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks =
concatMap
(\(acct, (name, comma)) ->
map ((,) (Just acct)) name ++ map ((,) Nothing) comma)
registerChartHtml :: [(CommoditySymbol, (String, [TransactionsReportItem]))] -> HtmlUrl AppRoute
registerChartHtml percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
where
charttitle = case maybe "" (fst . snd) $ listToMaybe percommoditytxnreports of
"" -> ""
s -> s <> ":"
colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts
shownull c = if null c then " " else c
dayToJsTimestamp :: Day -> Integer
dayToJsTimestamp d =
read (formatTime defaultTimeLocale "%s" t) * 1000
where
t = UTCTime d (secondsToDiffTime 0)