-- | /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
  Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Capability
CapView Capability -> [Capability] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Capability]
caps) (Text -> Handler ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Missing the 'view' capability")

  let (Text
a,Bool
inclsubs) = (Text, Bool) -> Maybe (Text, Bool) -> (Text, Bool)
forall a. a -> Maybe a -> a
fromMaybe (Text
"all accounts",Bool
True) (Maybe (Text, Bool) -> (Text, Bool))
-> Maybe (Text, Bool) -> (Text, Bool)
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 Query -> Query -> Bool
forall a. Eq a => a -> a -> Bool
/= Query
Any then Text
", filtered" else Text
""
      header :: 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 :: ReportSpec
rspec = CliOpts -> ReportSpec
reportspec_ (WebOpts -> CliOpts
cliopts_ WebOpts
opts)
      acctQuery :: Query
acctQuery = Query -> Maybe Query -> Query
forall a. a -> Maybe a -> a
fromMaybe Query
Any ([QueryOpt] -> Maybe Query
inAccountQuery [QueryOpt]
qopts)
      acctlink :: Text -> (Route App, [(a, Text)])
acctlink Text
acc = (Route App
RegisterR, [(a
"q", Text -> Text -> Text
replaceInacct Text
q (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
accountQuery Text
acc)])
      otherTransAccounts :: Transaction -> [(Posting, (Text, Text))]
otherTransAccounts =
          ((Posting, (String, String)) -> (Posting, (Text, Text)))
-> [(Posting, (String, String))] -> [(Posting, (Text, Text))]
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))) ([(Posting, (String, String))] -> [(Posting, (Text, Text))])
-> (Transaction -> [(Posting, (String, String))])
-> Transaction
-> [(Posting, (Text, Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [(Maybe Posting, Char)] -> [(Posting, (String, String))]
forall acct char.
[(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks ([(Maybe Posting, Char)] -> [(Posting, (String, String))])
-> (Transaction -> [(Maybe Posting, Char)])
-> Transaction
-> [(Posting, (String, String))]
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, (String, String))] -> [(Maybe Posting, Char)]
forall acct char.
[(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks ([(Posting, (String, String))] -> [(Maybe Posting, Char)])
-> (Transaction -> [(Posting, (String, String))])
-> Transaction
-> [(Maybe Posting, Char)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [Posting] -> [(Posting, (String, String))]
forall b. IsString b => [Posting] -> [(Posting, (String, b))]
addCommas ([Posting] -> [(Posting, (String, String))])
-> (Transaction -> [Posting])
-> Transaction
-> [(Posting, (String, String))]
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
m Query
acctQuery
      addCommas :: [Posting] -> [(Posting, (String, b))]
addCommas [Posting]
xs =
          [Posting] -> [(String, b)] -> [(Posting, (String, b))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Posting]
xs ([(String, b)] -> [(Posting, (String, b))])
-> [(String, b)] -> [(Posting, (String, b))]
forall a b. (a -> b) -> a -> b
$
          [String] -> [b] -> [(String, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Posting -> String) -> [Posting] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (Posting -> Text) -> Posting -> String
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] -> [(String, b)]) -> [b] -> [(String, b)]
forall a b. (a -> b) -> a -> b
$
          [b] -> [b]
forall a. [a] -> [a]
tail ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ (b
", "b -> [Posting] -> [b]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$[Posting]
xs) [b] -> [b] -> [b]
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
        | 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 = String
"Historical Total"
        | Maybe (Text, Bool) -> Bool
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
  WidgetFor App () -> Handler Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor App () -> Handler Html)
-> WidgetFor App () -> Handler Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> WidgetFor App ()
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 Query -> Query -> Bool
forall a. Eq a => a -> a -> Bool
== Query
None  = [Posting]
reportps
    -- only postings to current account ? summarise those
    | [Text] -> 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 (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 :: Int -> [(Maybe d, Char)] -> [(Maybe d, Char)]
elideRightDecorated Int
width [(Maybe d, Char)]
s =
    if [(Maybe d, Char)] -> 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)) -> String -> [(Maybe d, Char)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe d
forall a. Maybe a
Nothing,) String
".."
        else [(Maybe d, Char)]
s

undecorateLinks :: [(Maybe acct, char)] -> [(acct, ([char], [char]))]
undecorateLinks :: [(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)
_ -> String -> [(acct, ([char], [char]))]
forall a. HasCallStack => String -> a
error String
"link name not decorated with account"  -- PARTIAL:

decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks :: [(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
-> String
-> [(Text, AccountTransactionsReport)]
-> HtmlUrl (Route App)
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 String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
title then String
"" else String
title String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
   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
mixedAmountStripPrices
   showZeroCommodity :: MixedAmount -> String
showZeroCommodity = WideBuilder -> String
wbUnpack (WideBuilder -> String)
-> (MixedAmount -> WideBuilder) -> MixedAmount -> String
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 t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
c then t a
" " else t a
c
   nodatelink :: (Route App, [(Text, Text)])
nodatelink = (Route App
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 =
  String -> Integer
forall a. Read a => String -> a
read (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%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)