RegisterScreen.hs

-- The account register screen, showing transactions in an account, like hledger-web's register.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module Hledger.UI.RegisterScreen
(rsNew
,rsUpdate
,rsDraw
,rsHandle
,rsSetAccount
,rsCenterSelection
)
where

import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (bimap, Bifunctor (second))
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Vector ((!?))
import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
import Brick
import Brick.Widgets.List hiding (reverse)
import Brick.Widgets.Edit
import Lens.Micro.Platform
import System.Console.ANSI

import Hledger
import Hledger.Cli hiding (mode, progname,prognameandversion)
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor
import Hledger.UI.ErrorScreen (uiReloadJournal, uiCheckBalanceAssertions, uiReloadJournalIfChanged)

rsDraw :: UIState -> [Widget Name]
rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
              ,aScreen=RS RSS{..}
              ,aMode=mode
              } = dbgui "rsDraw 1" $
  case mode of
    Help       -> [helpDialog, maincontent]
    _          -> [maincontent]
  where
    displayitems = V.toList $ listElements $ _rssList
    maincontent = Widget Greedy Greedy $ do
      -- calculate column widths, based on current available width
      c <- getContext
      let
        totalwidth = c^.availWidthL
                     - 2 -- XXX due to margin ? shouldn't be necessary (cf UIUtils)
        -- the date column is fixed width
        datewidth = 10
        -- multi-commodity amounts rendered on one line can be
        -- arbitrarily wide.  Give the two amounts as much space as
        -- they need, while reserving a minimum of space for other
        -- columns and whitespace.  If they don't get all they need,
        -- allocate it to them proportionally to their maximum widths.
        whitespacewidth = 10 -- inter-column whitespace, fixed width
        minnonamtcolswidth = datewidth + 1 + 2 + 2 -- date column plus at least 1 for status and 2 for desc and accts
        maxamtswidth = max 0 (totalwidth - minnonamtcolswidth - whitespacewidth)
        maxchangewidthseen = maximum' $ map (wbWidth . rsItemChangeAmount) displayitems
        maxbalwidthseen = maximum' $ map (wbWidth . rsItemBalanceAmount) displayitems
        changewidthproportion = fromIntegral maxchangewidthseen / fromIntegral (maxchangewidthseen + maxbalwidthseen)
        maxchangewidth = round $ changewidthproportion * fromIntegral maxamtswidth
        maxbalwidth = maxamtswidth - maxchangewidth
        changewidth = min maxchangewidth maxchangewidthseen
        balwidth = min maxbalwidth maxbalwidthseen
        -- assign the remaining space to the description and accounts columns
        -- maxdescacctswidth = totalwidth - (whitespacewidth - 4) - changewidth - balwidth
        maxdescacctswidth =
          -- trace (show (totalwidth, datewidth, changewidth, balwidth, whitespacewidth)) $
          max 0 (totalwidth - datewidth - 1 - changewidth - balwidth - whitespacewidth)
        -- allocating proportionally.
        -- descwidth' = maximum' $ map (strWidth . second6) displayitems
        -- acctswidth' = maximum' $ map (strWidth . third6) displayitems
        -- descwidthproportion = (descwidth' + acctswidth') / descwidth'
        -- maxdescwidth = min (maxdescacctswidth - 7) (maxdescacctswidth / descwidthproportion)
        -- maxacctswidth = maxdescacctswidth - maxdescwidth
        -- descwidth = min maxdescwidth descwidth'
        -- acctswidth = min maxacctswidth acctswidth'
        -- allocating equally.
        descwidth = maxdescacctswidth `div` 2
        acctswidth = maxdescacctswidth - descwidth
        colwidths = (datewidth,descwidth,acctswidth,changewidth,balwidth)

      render $ defaultLayout toplabel bottomlabel $ renderList (rsDrawItem colwidths) True _rssList

      where
        ropts = _rsReportOpts rspec
        ishistorical = balanceaccum_ ropts == Historical
        -- inclusive = tree_ ropts || rsForceInclusive

        toplabel =
              withAttr (attrName "border" <> attrName "bold") (str $ T.unpack $ replaceHiddenAccountsNameWith "All" _rssAccount)
--           <+> withAttr ("border" <> "query") (str $ if inclusive then "" else " exclusive")
          <+> togglefilters
          <+> str " transactions"
          -- <+> str (if ishistorical then " historical total" else " period total")
          <+> borderQueryStr (T.unpack . T.unwords . map textQuoteIfNeeded $ querystring_ ropts)
          -- <+> str " and subs"
          <+> borderPeriodStr "in" (period_ ropts)
          <+> str " ("
          <+> cur
          <+> str "/"
          <+> total
          <+> str ")"
          <+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts then withAttr (attrName "border" <> attrName "query") (str " ignoring balance assertions") else str "")
          where
            togglefilters =
              case concat [
                   uiShowStatus copts $ statuses_ ropts
                  ,if real_ ropts then ["real"] else []
                  ,if empty_ ropts then [] else ["nonzero"]
                  ] of
                [] -> str ""
                fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs)
            cur = str $ case listSelected _rssList of
                         Nothing -> "-"
                         Just i -> show (i + 1)
            total = str $ show $ length nonblanks
            nonblanks = V.takeWhile (not . T.null . rsItemDate) $ listElements $ _rssList

            -- query = query_ $ reportopts_ $ cliopts_ opts

        bottomlabel = case mode of
                        Minibuffer label ed -> minibuffer label ed
                        _                   -> quickhelp
          where
            quickhelp = borderKeysStr' [
               ("LEFT", str "back")
              -- ,("RIGHT", str "transaction")

              -- tree/list mode - rsForceInclusive may override, but use tree_ to ensure a visible toggle effect
              ,("t", renderToggle (tree_ ropts) "list(-subs)" "tree(+subs)")
              -- ,("t", str "tree(+subs)")
              -- ,("l", str "list(-subs)")

              ,("H", renderToggle (not ishistorical) "historical" "period")
              ,("F", renderToggle1 (isJust . forecast_ . inputopts_ $ copts) "forecast")
              -- ,("a", "add")
              -- ,("g", "reload")
              ,("?", str "help")
              -- ,("q", "quit")
              ]

rsDraw _ = dbgui "rsDraw 2" $ errorWrongScreenType "draw function"  -- PARTIAL:

rsDrawItem :: (Int,Int,Int,Int,Int) -> Bool -> RegisterScreenItem -> Widget Name
rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected RegisterScreenItem{..} =
  Widget Greedy Fixed $ do
    render $
      txt (fitText (Just datewidth) (Just datewidth) True True rsItemDate) <+>
      txt " " <+>
      txt (fitText (Just 1) (Just 1) True True (T.pack $ show rsItemStatus)) <+>
      txt " " <+>
      txt (fitText (Just descwidth) (Just descwidth) True True rsItemDescription) <+>
      txt "  " <+>
      txt (fitText (Just acctswidth) (Just acctswidth) True True rsItemOtherAccounts) <+>
      txt "   " <+>
      withAttr changeattr (txt $ fitText (Just changewidth) (Just changewidth) True False changeAmt) <+>
      txt "   " <+>
      withAttr balattr (txt $ fitText (Just balwidth) (Just balwidth) True False balanceAmt)
  where
    changeAmt  = wbToText rsItemChangeAmount
    balanceAmt = wbToText rsItemBalanceAmount
    changeattr | T.any (=='-') changeAmt  = sel $ attrName "list" <> attrName "amount" <> attrName "decrease"
               | otherwise                = sel $ attrName "list" <> attrName "amount" <> attrName "increase"
    balattr    | T.any (=='-') balanceAmt = sel $ attrName "list" <> attrName "balance" <> attrName "negative"
               | otherwise                = sel $ attrName "list" <> attrName "balance" <> attrName "positive"
    sel | selected  = (<> attrName "selected")
        | otherwise = id

-- XXX clean up like asHandle
rsHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
rsHandle ev = do
  ui0 <- get'
  dbguiEv "rsHandle 1"
  case ui0 of
    ui@UIState{
      aScreen=RS sst@RSS{..}
      ,aopts=UIOpts{uoCliOpts=copts}
      ,ajournal=j
      ,aMode=mode
      } -> do
      d <- liftIO getCurrentDay
      let
        journalspan = journalDateSpan False j
        nonblanks = V.takeWhile (not . T.null . rsItemDate) $ listElements $ _rssList
        lastnonblankidx = max 0 (length nonblanks - 1)
        numberedtxns = zipWith (curry (second rsItemTransaction)) [(1::Integer)..] (V.toList nonblanks)
        -- the transactions being shown and the currently selected or last transaction, if any:
        mtxns :: Maybe ([NumberedTransaction], NumberedTransaction)
        mtxns = case numberedtxns of
          []        -> Nothing
          nts@(_:_) -> Just (nts, maybe (last nts) (bimap ((+1).fromIntegral) rsItemTransaction) $
                              listSelectedElement _rssList)  -- PARTIAL: last won't fail
      case mode of
        Minibuffer _ ed ->
          case ev of
            VtyEvent (EvKey KEsc   []) -> modify' closeMinibuffer
            VtyEvent (EvKey KEnter []) -> put' $ regenerateScreens j d $
                case setFilter s $ closeMinibuffer ui of
                  Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui
                  Right ui' -> ui'
              where s = chomp . unlines . map strip $ getEditContents ed
            -- VtyEvent (EvKey (KChar '/') []) -> put' $ regenerateScreens j d $ showMinibuffer ui
            VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
            VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
            VtyEvent e -> do
              ed' <- nestEventM' ed $ handleEditorEvent (VtyEvent e)
              put' ui{aMode=Minibuffer "filter" ed'}
            AppEvent _  -> return ()
            MouseDown{} -> return ()
            MouseUp{}   -> return ()

        Help ->
          case ev of
            -- VtyEvent (EvKey (KChar 'q') []) -> halt
            VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
            VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
            _ -> helpHandle ev

        Normal ->
          case ev of
            VtyEvent (EvKey (KChar 'q') []) -> halt
            VtyEvent (EvKey KEsc        []) -> put' $ resetScreens d ui
            VtyEvent (EvKey (KChar c)   []) | c == '?' -> put' $ setMode Help ui

            -- AppEvents arrive in --watch mode, see AccountsScreen
            AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
              put' $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
              where
                p = reportPeriod ui

            e | e `elem` [AppEvent FileChange, VtyEvent (EvKey (KChar 'g') [])] ->
              liftIO (uiReloadJournal copts d ui) >>= put'

            VtyEvent (EvKey (KChar 'I') []) -> put' $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
            VtyEvent (EvKey (KChar 'a') []) -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
            VtyEvent (EvKey (KChar 'A') []) -> suspendAndResume $ void (runIadd (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui
            VtyEvent (EvKey (KChar 'T') []) -> put' $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
            VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui
              where
                (pos,f) = case listSelectedElement _rssList of
                            Nothing -> (endPosition, journalFilePath j)
                            Just (_, RegisterScreenItem{
                              rsItemTransaction=Transaction{tsourcepos=(SourcePos f' l c,_)}}) -> (Just (unPos l, Just $ unPos c),f')

            -- display mode/query toggles
            VtyEvent (EvKey (KChar 'B') []) -> rsCenterSelection (regenerateScreens j d $ toggleConversionOp ui) >>= put'
            VtyEvent (EvKey (KChar 'V') []) -> rsCenterSelection (regenerateScreens j d $ toggleValue ui) >>= put'
            VtyEvent (EvKey (KChar 'H') []) -> rsCenterSelection (regenerateScreens j d $ toggleHistorical ui) >>= put'
            VtyEvent (EvKey (KChar 't') []) -> rsCenterSelection (regenerateScreens j d $ toggleTree ui) >>= put'
            VtyEvent (EvKey (KChar c) []) | c `elem` ['z','Z'] -> rsCenterSelection (regenerateScreens j d $ toggleEmpty ui) >>= put'
            VtyEvent (EvKey (KChar 'R') []) -> rsCenterSelection (regenerateScreens j d $ toggleReal ui) >>= put'
            VtyEvent (EvKey (KChar 'U') []) -> rsCenterSelection (regenerateScreens j d $ toggleUnmarked ui) >>= put'
            VtyEvent (EvKey (KChar 'P') []) -> rsCenterSelection (regenerateScreens j d $ togglePending ui) >>= put'
            VtyEvent (EvKey (KChar 'C') []) -> rsCenterSelection (regenerateScreens j d $ toggleCleared ui) >>= put'
            VtyEvent (EvKey (KChar 'F') []) -> rsCenterSelection (regenerateScreens j d $ toggleForecast d ui) >>= put'

            VtyEvent (EvKey (KChar '/') []) -> put' $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui
            VtyEvent (EvKey (KDown)     [MShift]) -> put' $ regenerateScreens j d $ shrinkReportPeriod d ui
            VtyEvent (EvKey (KUp)       [MShift]) -> put' $ regenerateScreens j d $ growReportPeriod d ui
            VtyEvent (EvKey (KRight)    [MShift]) -> put' $ regenerateScreens j d $ nextReportPeriod journalspan ui
            VtyEvent (EvKey (KLeft)     [MShift]) -> put' $ regenerateScreens j d $ previousReportPeriod journalspan ui
            VtyEvent (EvKey k           []) | k `elem` [KBS, KDel] -> (put' $ regenerateScreens j d $ resetFilter ui)
            VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _rssList >> redraw
            VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui

            -- exit screen on LEFT
            VtyEvent e | e `elem` moveLeftEvents  -> put' $ popScreen ui
            -- or on a click in the app's left margin. This is a VtyEvent since not in a clickable widget.
            VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> put' $ popScreen ui

            -- enter transaction screen on RIGHT
            VtyEvent e | e `elem` moveRightEvents ->
              case mtxns of Nothing -> return (); Just (nts, nt) -> rsEnterTransactionScreen _rssAccount nts nt ui
            -- or on transaction click
            -- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347
            -- just use it to move the selection
            MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
              put' $ ui{aScreen=RS sst{_rssList=listMoveTo y _rssList}}
              where clickeddate = maybe "" rsItemDate $ listElements _rssList !? y
            -- and on MouseUp, enter the subscreen
            MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
              case mtxns of Nothing -> return (); Just (nts, nt) -> rsEnterTransactionScreen _rssAccount nts nt ui
              where clickeddate = maybe "" rsItemDate $ listElements _rssList !? y

            -- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled
            VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
              vScrollBy (viewportScroll $ listName $ _rssList) 1
              where mnextelement = listSelectedElement $ listMoveDown _rssList

            -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
            -- pushing the selection when necessary.
            MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do
              let scrollamt = if btn==BScrollUp then -1 else 1
              list' <- nestEventM' _rssList $ listScrollPushingSelection name (rsListSize _rssList) scrollamt
              put' ui{aScreen=RS sst{_rssList=list'}}

            -- if page down or end leads to a blank padding item, stop at last non-blank
            VtyEvent e@(EvKey k           []) | k `elem` [KPageDown, KEnd] -> do
              l <- nestEventM' _rssList $ handleListEvent e
              if isBlankElement $ listSelectedElement l
              then do
                let l' = listMoveTo lastnonblankidx l
                scrollSelectionToMiddle l'
                put' ui{aScreen=RS sst{_rssList=l'}}
              else
                put' ui{aScreen=RS sst{_rssList=l}}

            -- fall through to the list's event handler (handles other [pg]up/down events)
            VtyEvent e -> do
              let e' = normaliseMovementKeys e
              newitems <- nestEventM' _rssList $ handleListEvent e'
              put' ui{aScreen=RS sst{_rssList=newitems}}

            MouseDown{}       -> return ()
            MouseUp{}         -> return ()
            AppEvent _        -> return ()

    _ -> dbgui "rsHandle 2" $ errorWrongScreenType "event handler"

isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""

rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements

rsSetAccount :: AccountName -> Bool -> Screen -> Screen
rsSetAccount a forceinclusive (RS st@RSS{}) =
  RS st{_rssAccount=replaceHiddenAccountsNameWith "*" a, _rssForceInclusive=forceinclusive}
rsSetAccount _ _ st = st

-- | Scroll the selected item to the middle of the screen, when on the register screen.
-- No effect on other screens.
rsCenterSelection :: UIState -> EventM Name UIState UIState
rsCenterSelection ui@UIState{aScreen=RS sst} = do
  scrollSelectionToMiddle $ _rssList sst
  return ui  -- ui is unchanged, but this makes the function more chainable
rsCenterSelection ui = return ui

rsEnterTransactionScreen :: AccountName -> [NumberedTransaction] -> NumberedTransaction -> UIState -> EventM Name UIState ()
rsEnterTransactionScreen acct nts nt ui = do
  dbguiEv "rsEnterTransactionScreen"
  put' $
    pushScreen (tsNew acct nts nt)
    ui