-- | /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 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{[Capability]
caps :: ViewData -> [Capability]
caps :: [Capability]
caps, Journal
j :: ViewData -> Journal
j :: Journal
j, Query
m :: ViewData -> Query
m :: Query
m, WebOpts
opts :: ViewData -> WebOpts
opts :: WebOpts
opts, Text
q :: ViewData -> Text
q :: Text
q, [QueryOpt]
qopts :: ViewData -> [QueryOpt]
qopts :: [QueryOpt]
qopts, Day
today :: ViewData -> Day
today :: Day
today} <- Handler ViewData
getViewData
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapView forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'view' capability")

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

  let rspec :: ReportSpec
rspec = CliOpts -> ReportSpec
reportspec_ (WebOpts -> CliOpts
cliopts_ WebOpts
opts)
      acctQuery :: Query
acctQuery = forall a. a -> Maybe a -> a
fromMaybe Query
Any ([QueryOpt] -> Maybe Query
inAccountQuery [QueryOpt]
qopts)
      acctlink :: Text -> (AppRoute, [(a, Text)])
acctlink Text
acc = (AppRoute
RegisterR, [(a
"q", Text -> Text -> Text
replaceInacct Text
q forall a b. (a -> b) -> a -> b
$ Text -> Text
accountQuery Text
acc)])
      otherTransAccounts :: Transaction -> [(Posting, (Text, Text))]
otherTransAccounts =
          forall a b. (a -> b) -> [a] -> [b]
map (\(Posting
acct,(String
name,String
comma)) -> (Posting
acct, (String -> Text
T.pack String
name, String -> Text
T.pack String
comma))) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated Int
40 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall acct char.
[(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall {b}. IsString b => [Posting] -> [(Posting, (String, b))]
addCommas forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Posting] -> [Posting]
preferReal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Query -> Transaction -> [Posting]
otherTransactionAccounts Query
m Query
acctQuery
      addCommas :: [Posting] -> [(Posting, (String, b))]
addCommas [Posting]
xs =
          forall a b. [a] -> [b] -> [(a, b)]
zip [Posting]
xs forall a b. (a -> b) -> a -> b
$
          forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
accountSummarisedName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posting -> Text
paccount) [Posting]
xs) forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ (b
", "forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$[Posting]
xs) forall a. [a] -> [a] -> [a]
++ [b
""]
      items :: AccountTransactionsReport
items = ReportSpec -> Journal -> Query -> AccountTransactionsReport
accountTransactionsReport ReportSpec
rspec{_rsQuery :: Query
_rsQuery=Query
m} Journal
j Query
acctQuery
      balancelabel :: String
balancelabel
        | forall a. Maybe a -> Bool
isJust ([QueryOpt] -> Maybe (Text, Bool)
inAccount [QueryOpt]
qopts), ReportOpts -> BalanceAccumulation
balanceaccum_ (ReportSpec -> ReportOpts
_rsReportOpts ReportSpec
rspec) forall a. Eq a => a -> a -> Bool
== BalanceAccumulation
Historical = String
"Historical Total"
        | forall a. Maybe a -> Bool
isJust ([QueryOpt] -> Maybe (Text, Bool)
inAccount [QueryOpt]
qopts) = String
"Period Total"
        | Bool
otherwise                = String
"Total"
      transactionFrag :: Transaction -> String
transactionFrag = Journal -> Transaction -> String
transactionFragment Journal
j
  forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"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 forall a. Eq a => a -> a -> Bool
== Query
None  = [Posting]
reportps
    -- only postings to current account ? summarise those
    | 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 forall a b. (a -> b) -> a -> b
$ Query -> Transaction -> Transaction
filterTransactionPostings Query
reportq Transaction
torig
      ([Posting]
thisacctps, [Posting]
otheracctps) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Query -> Posting -> Bool
matchesPosting Query
thisacctq) [Posting]
reportps
      otheraccts :: [Text]
otheraccts = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posting]
realps = [Posting]
ps
    | Bool
otherwise   = [Posting]
realps
    where realps :: [Posting]
realps = 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe d, Char)]
s forall a. Ord a => a -> a -> Bool
> Int
width
        then forall a. Int -> [a] -> [a]
take (Int
width forall a. Num a => a -> a -> a
- Int
2) [(Maybe d, Char)]
s forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Maybe a
Nothing,) String
".."
        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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe acct, char)]
xs0
                ([(Maybe acct, char)]
comma, [(Maybe acct, char)]
xs2) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe acct, char)]
xs1
            in (acct
acct, (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Maybe acct, char)]
link, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Maybe acct, char)]
comma)) forall a. a -> [a] -> [a]
: forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks [(Maybe acct, char)]
xs2
        (Maybe acct, char)
_ -> forall a. HasCallStack => String -> a
error String
"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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a -> b) -> a -> b
$ \(acct
acct, ([char]
name, [char]
comma)) ->
    forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just acct
acct,) [char]
name forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (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
-> String
-> [(Text, AccountTransactionsReport)]
-> HtmlUrl AppRoute
registerChartHtml Text
q String
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 :: String
charttitle = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
title then String
"" else String
title forall a. [a] -> [a] -> [a]
++ String
":"
   colorForCommodity :: Text -> Int
colorForCommodity = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Text, Int)]
commoditiesIndex
   commoditiesIndex :: [(Text, Int)]
commoditiesIndex = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, AccountTransactionsReport)]
percommoditytxnreports) [Int
0..] :: [(CommoditySymbol,Int)]
   simpleMixedAmountQuantity :: MixedAmount -> Quantity
simpleMixedAmountQuantity = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Quantity
0 Amount -> Quantity
aquantity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> [Amount]
amounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. MixedAmount -> MixedAmount
mixedAmountStripPrices
   showZeroCommodity :: MixedAmount -> String
showZeroCommodity = WideBuilder -> String
wbUnpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmountDisplayOpts -> MixedAmount -> WideBuilder
showMixedAmountB AmountDisplayOpts
oneLine{displayPrice :: Bool
displayPrice=Bool
False,displayZeroCommodity :: Bool
displayZeroCommodity=Bool
True}
   shownull :: t a -> t a
shownull t a
c = if 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 forall a b. (a -> b) -> a -> b
$ Text -> [Text]
removeDates Text
q)])

dayToJsTimestamp :: Day -> Integer
dayToJsTimestamp :: Day -> Integer
dayToJsTimestamp Day
d =
  forall a. Read a => String -> a
read (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s" UTCTime
t) 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)