-- | /register handlers.

{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}

module Hledger.Web.Handler.RegisterR where

import Data.List (intersperse, nub, partition)
import qualified Data.Text as T
import Safe (tailSafe)
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,
              transactionFragment, removeDates, removeInacct, replaceInacct)

-- | The main journal/account register view, with accounts sidebar.
getRegisterR :: Handler Html
getRegisterR :: Handler Html
getRegisterR = do
  Handler ()
checkServerSideUiEnabled
  VD{perms, j, q, opts, qparam, qopts, today} <- Handler ViewData
getViewData
  require ViewPermission

  let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
      s1 = if Bool
inclsubs then Text
"" else Text
" (excluding subaccounts)"
      s2 = if Query
q Query -> Query -> Bool
forall a. Eq a => a -> a -> Bool
/= Query
Any then Text
", filtered" else Text
""
      header = Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2

  let rspec = CliOpts -> ReportSpec
reportspec_ (WebOpts -> CliOpts
cliopts_ WebOpts
opts)
      acctQuery = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
Any ([QueryOpt] -> Maybe Query
inAccountQuery [QueryOpt]
qopts)
      acctlink Text
acc = (AppRoute
RegisterR, [(a
"q", Text -> Text -> Text
replaceInacct Text
qparam (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
accountQuery Text
acc)])
      otherTransAccounts =
          ((Posting, ([Char], [Char])) -> (Posting, (Text, Text)))
-> [(Posting, ([Char], [Char]))] -> [(Posting, (Text, Text))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Posting
acct,([Char]
name,[Char]
comma)) -> (Posting
acct, ([Char] -> Text
T.pack [Char]
name, [Char] -> Text
T.pack [Char]
comma))) ([(Posting, ([Char], [Char]))] -> [(Posting, (Text, Text))])
-> (Transaction -> [(Posting, ([Char], [Char]))])
-> Transaction
-> [(Posting, (Text, Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [(Maybe Posting, Char)] -> [(Posting, ([Char], [Char]))]
forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks ([(Maybe Posting, Char)] -> [(Posting, ([Char], [Char]))])
-> (Transaction -> [(Maybe Posting, Char)])
-> Transaction
-> [(Posting, ([Char], [Char]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(Maybe Posting, Char)] -> [(Maybe Posting, Char)]
forall d. Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated Int
40 ([(Maybe Posting, Char)] -> [(Maybe Posting, Char)])
-> (Transaction -> [(Maybe Posting, Char)])
-> Transaction
-> [(Maybe Posting, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Posting, ([Char], [Char]))] -> [(Maybe Posting, Char)]
forall acct char.
[(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks ([(Posting, ([Char], [Char]))] -> [(Maybe Posting, Char)])
-> (Transaction -> [(Posting, ([Char], [Char]))])
-> Transaction
-> [(Maybe Posting, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [Posting] -> [(Posting, ([Char], [Char]))]
forall {b}. IsString b => [Posting] -> [(Posting, ([Char], b))]
addCommas ([Posting] -> [(Posting, ([Char], [Char]))])
-> (Transaction -> [Posting])
-> Transaction
-> [(Posting, ([Char], [Char]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Posting] -> [Posting]
preferReal ([Posting] -> [Posting])
-> (Transaction -> [Posting]) -> Transaction -> [Posting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Query -> Transaction -> [Posting]
otherTransactionAccounts Query
q Query
acctQuery
      addCommas [Posting]
xs =
          [Posting] -> [([Char], b)] -> [(Posting, ([Char], b))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Posting]
xs ([([Char], b)] -> [(Posting, ([Char], b))])
-> [([Char], b)] -> [(Posting, ([Char], b))]
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> [b] -> [([Char], b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Posting -> [Char]) -> [Posting] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack (Text -> [Char]) -> (Posting -> Text) -> Posting -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
accountSummarisedName (Text -> Text) -> (Posting -> Text) -> Posting -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> Text
paccount) [Posting]
xs) ([b] -> [([Char], b)]) -> [b] -> [([Char], b)]
forall a b. (a -> b) -> a -> b
$
          [b] -> [b]
forall a. [a] -> [a]
tailSafe (b
", "b -> [Posting] -> [b]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$[Posting]
xs) [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b
""]
      items =
        Map Text AmountStyle
-> AccountTransactionsReport -> AccountTransactionsReport
forall a. HasAmounts a => Map Text AmountStyle -> a -> a
styleAmounts (Rounding -> Journal -> Map Text AmountStyle
journalCommodityStylesWith Rounding
HardRounding Journal
j) (AccountTransactionsReport -> AccountTransactionsReport)
-> AccountTransactionsReport -> AccountTransactionsReport
forall a b. (a -> b) -> a -> b
$
        ReportSpec -> Journal -> Query -> AccountTransactionsReport
accountTransactionsReport ReportSpec
rspec{_rsQuery=q} Journal
j Query
acctQuery
      balancelabel
        | Maybe (Text, Bool) -> Bool
forall a. Maybe a -> Bool
isJust ([QueryOpt] -> Maybe (Text, Bool)
inAccount [QueryOpt]
qopts), ReportOpts -> BalanceAccumulation
balanceaccum_ (ReportSpec -> ReportOpts
_rsReportOpts ReportSpec
rspec) BalanceAccumulation -> BalanceAccumulation -> Bool
forall a. Eq a => a -> a -> Bool
== BalanceAccumulation
Historical = [Char]
"Historical Total"
        | Maybe (Text, Bool) -> Bool
forall a. Maybe a -> Bool
isJust ([QueryOpt] -> Maybe (Text, Bool)
inAccount [QueryOpt]
qopts) = [Char]
"Period Total"
        | Bool
otherwise                = [Char]
"Total"
      transactionFrag = Journal -> Transaction -> [Char]
transactionFragment Journal
j
  defaultLayout $ do
    setTitle "register - hledger-web"
    $(widgetFile "register")

-- cf. Hledger.Reports.AccountTransactionsReport.accountTransactionsReportItems
otherTransactionAccounts :: Query -> Query -> Transaction -> [Posting]
otherTransactionAccounts :: Query -> Query -> Transaction -> [Posting]
otherTransactionAccounts Query
reportq Query
thisacctq Transaction
torig
    -- no current account ? summarise all matched postings
    | Query
thisacctq Query -> Query -> Bool
forall a. Eq a => a -> a -> Bool
== Query
None  = [Posting]
reportps
    -- only postings to current account ? summarise those
    | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
otheraccts    = [Posting]
thisacctps
    -- summarise matched postings to other account(s)
    | Bool
otherwise          = [Posting]
otheracctps
    where
      reportps :: [Posting]
reportps = Transaction -> [Posting]
tpostings (Transaction -> [Posting]) -> Transaction -> [Posting]
forall a b. (a -> b) -> a -> b
$ Query -> Transaction -> Transaction
filterTransactionPostings Query
reportq Transaction
torig
      ([Posting]
thisacctps, [Posting]
otheracctps) = (Posting -> Bool) -> [Posting] -> ([Posting], [Posting])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Query -> Posting -> Bool
matchesPosting Query
thisacctq) [Posting]
reportps
      otheraccts :: [Text]
otheraccts = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Posting -> Text) -> [Posting] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Posting -> Text
paccount [Posting]
otheracctps

-- cf. Hledger.Reports.AccountTransactionsReport.summarisePostingAccounts
preferReal :: [Posting] -> [Posting]
preferReal :: [Posting] -> [Posting]
preferReal [Posting]
ps
    | [Posting] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posting]
realps = [Posting]
ps
    | Bool
otherwise   = [Posting]
realps
    where realps :: [Posting]
realps = (Posting -> Bool) -> [Posting] -> [Posting]
forall a. (a -> Bool) -> [a] -> [a]
filter Posting -> Bool
isReal [Posting]
ps

elideRightDecorated :: Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated :: forall d. Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated Int
width [(Maybe d, Char)]
s =
    if [(Maybe d, Char)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe d, Char)]
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width
        then Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
forall a. Int -> [a] -> [a]
take (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [(Maybe d, Char)]
s [(Maybe d, Char)] -> [(Maybe d, Char)] -> [(Maybe d, Char)]
forall a. [a] -> [a] -> [a]
++ (Char -> (Maybe d, Char)) -> [Char] -> [(Maybe d, Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe d
forall a. Maybe a
Nothing,) [Char]
".."
        else [(Maybe d, Char)]
s

undecorateLinks :: [(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks :: forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks [] = []
undecorateLinks xs0 :: [(Maybe acct, char)]
xs0@((Maybe acct, char)
x:[(Maybe acct, char)]
_) =
    case (Maybe acct, char)
x of
        (Just acct
acct, char
_) ->
            let ([(Maybe acct, char)]
link, [(Maybe acct, char)]
xs1) = ((Maybe acct, char) -> Bool)
-> [(Maybe acct, char)]
-> ([(Maybe acct, char)], [(Maybe acct, char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Maybe acct -> Bool
forall a. Maybe a -> Bool
isJust (Maybe acct -> Bool)
-> ((Maybe acct, char) -> Maybe acct) -> (Maybe acct, char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe acct, char) -> Maybe acct
forall a b. (a, b) -> a
fst) [(Maybe acct, char)]
xs0
                ([(Maybe acct, char)]
comma, [(Maybe acct, char)]
xs2) = ((Maybe acct, char) -> Bool)
-> [(Maybe acct, char)]
-> ([(Maybe acct, char)], [(Maybe acct, char)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Maybe acct -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe acct -> Bool)
-> ((Maybe acct, char) -> Maybe acct) -> (Maybe acct, char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe acct, char) -> Maybe acct
forall a b. (a, b) -> a
fst) [(Maybe acct, char)]
xs1
            in (acct
acct, (((Maybe acct, char) -> char) -> [(Maybe acct, char)] -> [char]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe acct, char) -> char
forall a b. (a, b) -> b
snd [(Maybe acct, char)]
link, ((Maybe acct, char) -> char) -> [(Maybe acct, char)] -> [char]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe acct, char) -> char
forall a b. (a, b) -> b
snd [(Maybe acct, char)]
comma)) (acct, ([char], [char]))
-> [(acct, ([char], [char]))] -> [(acct, ([char], [char]))]
forall a. a -> [a] -> [a]
: [(Maybe acct, char)] -> [(acct, ([char], [char]))]
forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks [(Maybe acct, char)]
xs2
        (Maybe acct, char)
_ -> [Char] -> [(acct, ([char], [char]))]
forall a. [Char] -> a
error' [Char]
"link name not decorated with account"  -- PARTIAL:

decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks :: forall acct char.
[(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks = ((acct, ([char], [char])) -> [(Maybe acct, char)])
-> [(acct, ([char], [char]))] -> [(Maybe acct, char)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((acct, ([char], [char])) -> [(Maybe acct, char)])
 -> [(acct, ([char], [char]))] -> [(Maybe acct, char)])
-> ((acct, ([char], [char])) -> [(Maybe acct, char)])
-> [(acct, ([char], [char]))]
-> [(Maybe acct, char)]
forall a b. (a -> b) -> a -> b
$ \(acct
acct, ([char]
name, [char]
comma)) ->
    (char -> (Maybe acct, char)) -> [char] -> [(Maybe acct, char)]
forall a b. (a -> b) -> [a] -> [b]
map (acct -> Maybe acct
forall a. a -> Maybe a
Just acct
acct,) [char]
name [(Maybe acct, char)]
-> [(Maybe acct, char)] -> [(Maybe acct, char)]
forall a. [a] -> [a] -> [a]
++ (char -> (Maybe acct, char)) -> [char] -> [(Maybe acct, char)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe acct
forall a. Maybe a
Nothing,) [char]
comma

-- | Generate javascript/html for a register balance line chart based on
-- the provided "AccountTransactionsReportItem"s.
registerChartHtml :: Text -> String -> [(CommoditySymbol, [AccountTransactionsReportItem])] -> HtmlUrl AppRoute
registerChartHtml :: Text
-> [Char]
-> [(Text, AccountTransactionsReport)]
-> HtmlUrl AppRoute
registerChartHtml Text
q [Char]
title [(Text, AccountTransactionsReport)]
percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
 -- have to make sure plot is not called when our container (maincontent)
 -- is hidden, eg with add form toggled
 where
   charttitle :: [Char]
charttitle = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
title then [Char]
"" else [Char]
title [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
   colorForCommodity :: Text -> Int
colorForCommodity = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Text -> Maybe Int) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [(Text, Int)] -> Maybe Int)
-> [(Text, Int)] -> Text -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [(Text, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Text, Int)]
commoditiesIndex
   commoditiesIndex :: [(Text, Int)]
commoditiesIndex = [Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Text, AccountTransactionsReport) -> Text)
-> [(Text, AccountTransactionsReport)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, AccountTransactionsReport) -> Text
forall a b. (a, b) -> a
fst [(Text, AccountTransactionsReport)]
percommoditytxnreports) [Int
0..] :: [(CommoditySymbol,Int)]
   simpleMixedAmountQuantity :: MixedAmount -> Quantity
simpleMixedAmountQuantity = Quantity -> (Amount -> Quantity) -> Maybe Amount -> Quantity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Quantity
0 Amount -> Quantity
aquantity (Maybe Amount -> Quantity)
-> (MixedAmount -> Maybe Amount) -> MixedAmount -> Quantity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Amount] -> Maybe Amount
forall a. [a] -> Maybe a
listToMaybe ([Amount] -> Maybe Amount)
-> (MixedAmount -> [Amount]) -> MixedAmount -> Maybe Amount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amounts (MixedAmount -> [Amount])
-> (MixedAmount -> MixedAmount) -> MixedAmount -> [Amount]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> MixedAmount
mixedAmountStripCosts
   showZeroCommodity :: MixedAmount -> [Char]
showZeroCommodity = WideBuilder -> [Char]
wbUnpack (WideBuilder -> [Char])
-> (MixedAmount -> WideBuilder) -> MixedAmount -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmountFormat -> MixedAmount -> WideBuilder
showMixedAmountB AmountFormat
oneLineNoCostFmt{displayCost=False,displayZeroCommodity=True}
   shownull :: t a -> t a
shownull t a
c = if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
c then t a
" " else t a
c
   nodatelink :: (AppRoute, [(Text, Text)])
nodatelink = (AppRoute
RegisterR, [(Text
"q", [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
removeDates Text
q)])

dayToJsTimestamp :: Day -> Integer
dayToJsTimestamp :: Day -> Integer
dayToJsTimestamp Day
d =
  [Char] -> Integer
forall a. Read a => [Char] -> a
read (TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%s" UTCTime
t) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000 -- XXX read
  where
    t :: UTCTime
t = Day -> DiffTime -> UTCTime
UTCTime Day
d (Integer -> DiffTime
secondsToDiffTime Integer
0)