{-|
hledger-ui - a hledger add-on providing an efficient TUI.
Copyright (c) 2007-2015 Simon Michael <simon@joyful.com>
Released under GPL version 3 or later.
-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE MultiWayIf #-}

module Hledger.UI.Main where

import Control.Applicative ((<|>))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync)
import Control.Monad (forM_, void, when)
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.List (find)
import Data.List.Extra (nubSort)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Graphics.Vty (Mode (Mouse), Vty (outputIface), Output (setMode))
import Graphics.Vty.CrossPlatform (mkVty)
import Lens.Micro ((^.))
import System.Directory (canonicalizePath)
import System.Environment (withProgName)
import System.FilePath (takeDirectory)
import System.FSNotify (Event(Modified), watchDir, withManager, EventIsDirectory (IsFile))
import Brick hiding (bsDraw)
import qualified Brick.BChan as BC

import Hledger
import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.UI.Theme
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState (uiState, getDepth)
import Hledger.UI.UIUtils (dbguiEv, showScreenStack, showScreenSelection)
import Hledger.UI.MenuScreen
import Hledger.UI.AccountsScreen
import Hledger.UI.CashScreen
import Hledger.UI.BalancesheetScreen
import Hledger.UI.IncomestatementScreen
import Hledger.UI.RegisterScreen
import Hledger.UI.TransactionScreen
import Hledger.UI.ErrorScreen
import Hledger.UI.UIScreens


----------------------------------------------------------------------

newChan :: IO (BC.BChan a)
newChan :: forall a. IO (BChan a)
newChan = Int -> IO (BChan a)
forall a. Int -> IO (BChan a)
BC.newBChan Int
10

writeChan :: BC.BChan a -> a -> IO ()
writeChan :: forall a. BChan a -> a -> IO ()
writeChan = BChan a -> a -> IO ()
forall a. BChan a -> a -> IO ()
BC.writeBChan


hledgerUiMain :: IO ()
hledgerUiMain :: IO ()
hledgerUiMain = [Char] -> IO () -> IO ()
forall a. [Char] -> IO a -> IO a
withProgName [Char]
"hledger-ui.log" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  -- force Hledger.Utils.Debug.* to log to hledger-ui.log
  Int -> [Char] -> IO ()
forall (m :: * -> *). MonadIO m => Int -> [Char] -> m ()
traceLogAtIO Int
1 [Char]
"\n\n\n\n==== hledger-ui start"
  [Char] -> [[Char]] -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"args" [[Char]]
progArgs
  [Char] -> Int -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"debugLevel" Int
debugLevel

  -- try to encourage user's $PAGER to properly display ANSI (in command line help)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useColorOnStdout IO ()
setupPager

  opts :: UIOpts
opts@UIOpts{uoCliOpts :: UIOpts -> CliOpts
uoCliOpts=copts :: CliOpts
copts@CliOpts{inputopts_ :: CliOpts -> InputOpts
inputopts_=InputOpts
iopts,rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
rawopts}} <- IO UIOpts
getHledgerUIOpts
  -- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)

  -- always generate forecasted periodic transactions; their visibility will be toggled by the UI.
  let copts' :: CliOpts
copts' = CliOpts
copts{inputopts_=iopts{forecast_=forecast_ iopts <|> Just nulldatespan}}

  case Bool
True of
    Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"help"    RawOpts
rawopts -> [Char] -> IO ()
pager (Mode RawOpts -> [Char]
forall a. Mode a -> [Char]
showModeUsage Mode RawOpts
uimode)
    Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"info"    RawOpts
rawopts -> [Char] -> Maybe [Char] -> IO ()
runInfoForTopic [Char]
"hledger-ui" Maybe [Char]
forall a. Maybe a
Nothing
    Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"man"     RawOpts
rawopts -> [Char] -> Maybe [Char] -> IO ()
runManForTopic  [Char]
"hledger-ui" Maybe [Char]
forall a. Maybe a
Nothing
    Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"version" RawOpts
rawopts -> [Char] -> IO ()
putStrLn [Char]
prognameandversion
    -- _ | boolopt "binary-filename" rawopts -> putStrLn (binaryfilename progname)
    Bool
_                                         -> CliOpts -> (Journal -> IO ()) -> IO ()
forall a. CliOpts -> (Journal -> IO a) -> IO a
withJournalDo CliOpts
copts' (UIOpts -> Journal -> IO ()
runBrickUi UIOpts
opts)

runBrickUi :: UIOpts -> Journal -> IO ()
runBrickUi :: UIOpts -> Journal -> IO ()
runBrickUi uopts0 :: UIOpts
uopts0@UIOpts{uoCliOpts :: UIOpts -> CliOpts
uoCliOpts=copts :: CliOpts
copts@CliOpts{inputopts_ :: CliOpts -> InputOpts
inputopts_=InputOpts
_iopts,reportspec_ :: CliOpts -> ReportSpec
reportspec_=rspec :: ReportSpec
rspec@ReportSpec{_rsReportOpts :: ReportSpec -> ReportOpts
_rsReportOpts=ReportOpts
ropts}}} Journal
j =
  do
  let
    today :: Day
today = CliOpts
coptsCliOpts -> Getting Day CliOpts Day -> Day
forall s a. s -> Getting a s a -> a
^.Getting Day CliOpts Day
forall c. HasReportSpec c => Lens' c Day
Lens' CliOpts Day
rsDay

    -- hledger-ui's query handling is currently in flux, mixing old and new approaches.
    -- Related: #1340, #1383, #1387. Some notes and terminology:

    -- The *startup query* is the Query generated at program startup, from
    -- command line options, arguments, and the current date. hledger CLI
    -- uses this.

    -- hledger-ui/hledger-web allow the query to be changed at will, creating
    -- a new *runtime query* each time.

    -- The startup query or part of it can be used as a *constraint query*,
    -- limiting all runtime queries. hledger-web does this with the startup
    -- report period, never showing transactions outside those dates.
    -- hledger-ui does not do this.

    -- A query is a combination of multiple subqueries/terms, which are
    -- generated from command line options and arguments, ui/web app runtime
    -- state, and/or the current date.

    -- Some subqueries are generated by parsing freeform user input, which
    -- can fail. We don't want hledger users to see such failures except:

    -- 1. at program startup, in which case the program exits
    -- 2. after entering a new freeform query in hledger-ui/web, in which case
    --    the change is rejected and the program keeps running

    -- So we should parse those kinds of subquery only at those times. Any
    -- subqueries which do not require parsing can be kept separate. And
    -- these can be combined to make the full query when needed, eg when
    -- hledger-ui screens are generating their data. (TODO)

    -- Some parts of the query are also kept separate for UI reasons.
    -- hledger-ui provides special UI for controlling depth (number keys), 
    -- the report period (shift arrow keys), realness/status filters (RUPC keys) etc.
    -- There is also a freeform text area for extra query terms (/ key).
    -- It's cleaner and less conflicting to keep the former out of the latter.

    uopts :: UIOpts
uopts = UIOpts
uopts0{
      uoCliOpts=copts{
         reportspec_=rspec{
            _rsQuery=filteredQuery $ _rsQuery rspec,  -- query with depth/date parts removed
            _rsReportOpts=ropts{
               depth_    = queryDepth $ _rsQuery rspec,  -- query's depth part
               period_   = periodfromoptsandargs,       -- query's date part
               no_elide_ = True,  -- avoid squashing boring account names, for a more regular tree (unlike hledger)
               empty_    = not $ empty_ ropts,  -- show zero items by default, hide them with -E (unlike hledger)
               declared_ = True  -- always show declared accounts even if unused
               }
            }
         }
      }
      where
        datespanfromargs :: DateSpan
datespanfromargs = Bool -> Query -> DateSpan
queryDateSpan (ReportOpts -> Bool
date2_ ReportOpts
ropts) (Query -> DateSpan) -> Query -> DateSpan
forall a b. (a -> b) -> a -> b
$ ReportSpec -> Query
_rsQuery ReportSpec
rspec
        periodfromoptsandargs :: Period
periodfromoptsandargs =
          DateSpan -> Period
dateSpanAsPeriod (DateSpan -> Period) -> DateSpan -> Period
forall a b. (a -> b) -> a -> b
$ [DateSpan] -> DateSpan
spansIntersect [Period -> DateSpan
periodAsDateSpan (Period -> DateSpan) -> Period -> DateSpan
forall a b. (a -> b) -> a -> b
$ ReportOpts -> Period
period_ ReportOpts
ropts, DateSpan
datespanfromargs]
        filteredQuery :: Query -> Query
filteredQuery Query
q = Query -> Query
simplifyQuery (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ [Query] -> Query
And [ReportOpts -> Query
queryFromFlags ReportOpts
ropts, Query -> Query
filtered Query
q]
          where filtered :: Query -> Query
filtered = (Query -> Bool) -> Query -> Query
filterQuery (\Query
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Query -> Bool
queryIsDepth Query
x Bool -> Bool -> Bool
|| Query -> Bool
queryIsDate Query
x)

    -- Choose the initial screen to display.
    -- We also set up a stack of previous screens, as if you had navigated down to it from the top.
    -- Note the previous screens list is ordered nearest-first, with the top-most (menu) screen last.
    -- Keep all of this synced with msNew.
    rawopts :: RawOpts
rawopts = CliOpts -> RawOpts
rawopts_ (CliOpts -> RawOpts) -> CliOpts -> RawOpts
forall a b. (a -> b) -> a -> b
$ UIOpts -> CliOpts
uoCliOpts (UIOpts -> CliOpts) -> UIOpts -> CliOpts
forall a b. (a -> b) -> a -> b
$ UIOpts
uopts
    ([Screen]
prevscrs, Screen
currscr) =
      (([Screen], Screen) -> [Char])
-> ([Screen], Screen) -> ([Screen], Screen)
forall a. Show a => (a -> [Char]) -> a -> a
dbg1With ([Char] -> (Screen -> [Char]) -> UIState -> [Char]
showScreenStack [Char]
"initial" Screen -> [Char]
showScreenSelection (UIState -> [Char])
-> (([Screen], Screen) -> UIState) -> ([Screen], Screen) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Screen] -> Screen -> UIState) -> ([Screen], Screen) -> UIState
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry2 (UIOpts -> Journal -> [Screen] -> Screen -> UIState
uiState UIOpts
defuiopts Journal
nulljournal)) (([Screen], Screen) -> ([Screen], Screen))
-> ([Screen], Screen) -> ([Screen], Screen)
forall a b. (a -> b) -> a -> b
$
      if
        -- An accounts screen is specified. Its previous screen will be the menu screen with it selected.
        | [Char] -> RawOpts -> Bool
boolopt [Char]
"cash" RawOpts
rawopts -> ([Int -> Screen -> Screen
msSetSelectedScreen Int
csItemIndex Screen
menuscr], Screen
csacctsscr)
        | [Char] -> RawOpts -> Bool
boolopt [Char]
"bs"   RawOpts
rawopts -> ([Int -> Screen -> Screen
msSetSelectedScreen Int
bsItemIndex Screen
menuscr], Screen
bsacctsscr)
        | [Char] -> RawOpts -> Bool
boolopt [Char]
"is"   RawOpts
rawopts -> ([Int -> Screen -> Screen
msSetSelectedScreen Int
isItemIndex Screen
menuscr], Screen
isacctsscr)
        | [Char] -> RawOpts -> Bool
boolopt [Char]
"all"  RawOpts
rawopts -> ([Int -> Screen -> Screen
msSetSelectedScreen Int
asItemIndex Screen
menuscr], Screen
allacctsscr)

        -- A register screen is specified with --register=ACCT. The initial screen stack will be:
        --
        --   menu screen, with ACCTSSCR selected
        --    ACCTSSCR (the accounts screen containing ACCT), with ACCT selected
        --     register screen for ACCT
        --
        | Just [Char]
apat <- UIOpts -> Maybe [Char]
uoRegister UIOpts
uopts ->
          let
            -- the account being requested
            acct :: Text
acct = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Text
forall a. [Char] -> a
error' ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"--register "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
apat[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" did not match any account")  -- PARTIAL:
              (Maybe Text -> Text) -> ([Text] -> Maybe Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe Text
firstMatch ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalAccountNamesDeclaredOrImplied Journal
j
              where
                firstMatch :: [Text] -> Maybe Text
firstMatch = case Text -> Either [Char] Regexp
toRegexCI (Text -> Either [Char] Regexp) -> Text -> Either [Char] Regexp
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
apat of
                    Right Regexp
re -> (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Regexp -> Text -> Bool
regexMatchText Regexp
re)
                    Left  [Char]
_  -> Maybe Text -> [Text] -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing

            -- the register screen for acct
            regscr :: Screen
regscr = 
              Text -> Bool -> Screen -> Screen
rsSetAccount Text
acct Bool
False (Screen -> Screen) -> Screen -> Screen
forall a b. (a -> b) -> a -> b
$
              UIOpts -> Day -> Journal -> Text -> Bool -> Screen
rsNew UIOpts
uopts Day
today Journal
j Text
acct Bool
forceinclusive
                where
                  forceinclusive :: Bool
forceinclusive = case UIState -> Maybe Int
getDepth UIState
ui of
                                    Just Int
de -> Text -> Int
accountNameLevel Text
acct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
de
                                    Maybe Int
Nothing -> Bool
False

            -- The accounts screen containing acct.
            -- Keep these selidx values synced with the menu items in msNew.
            (Screen
acctsscr, Int
selidx) =
              case Journal -> Text -> Maybe AccountType
journalAccountType Journal
j Text
acct of
                Just AccountType
t | AccountType -> Bool
isBalanceSheetAccountType AccountType
t    -> (Screen
bsacctsscr, Int
1)
                Just AccountType
t | AccountType -> Bool
isIncomeStatementAccountType AccountType
t -> (Screen
isacctsscr, Int
2)
                Maybe AccountType
_                                       -> (Screen
allacctsscr,Int
0)
              (Screen, Int) -> ((Screen, Int) -> (Screen, Int)) -> (Screen, Int)
forall a b. a -> (a -> b) -> b
& (Screen -> Screen) -> (Screen, Int) -> (Screen, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Screen -> Screen
asSetSelectedAccount Text
acct)

            -- the menu screen
            menuscr' :: Screen
menuscr' = Int -> Screen -> Screen
msSetSelectedScreen Int
selidx Screen
menuscr
          in ([Screen
acctsscr, Screen
menuscr'], Screen
regscr)

        -- Otherwise, start on the menu screen.
        | Bool
otherwise -> ([], Screen
menuscr)

        where
          menuscr :: Screen
menuscr     = Screen
msNew
          allacctsscr :: Screen
allacctsscr = UIOpts -> Day -> Journal -> Maybe Text -> Screen
asNew UIOpts
uopts Day
today Journal
j Maybe Text
forall a. Maybe a
Nothing
          csacctsscr :: Screen
csacctsscr  = UIOpts -> Day -> Journal -> Maybe Text -> Screen
csNew UIOpts
uopts Day
today Journal
j Maybe Text
forall a. Maybe a
Nothing
          bsacctsscr :: Screen
bsacctsscr  = UIOpts -> Day -> Journal -> Maybe Text -> Screen
bsNew UIOpts
uopts Day
today Journal
j Maybe Text
forall a. Maybe a
Nothing
          isacctsscr :: Screen
isacctsscr  = UIOpts -> Day -> Journal -> Maybe Text -> Screen
isNew UIOpts
uopts Day
today Journal
j Maybe Text
forall a. Maybe a
Nothing

    ui :: UIState
ui = UIOpts -> Journal -> [Screen] -> Screen -> UIState
uiState UIOpts
uopts Journal
j [Screen]
prevscrs Screen
currscr
    app :: App UIState AppEvent Name
app = Maybe [Char] -> App UIState AppEvent Name
brickApp (UIOpts -> Maybe [Char]
uoTheme UIOpts
uopts)

  -- print (length (show ui)) >> exitSuccess  -- show any debug output to this point & quit

  let 
    -- helper: make a Vty terminal controller with mouse support enabled
    makevty :: IO Vty
makevty = do
      Vty
v <- VtyUserConfig -> IO Vty
mkVty VtyUserConfig
forall a. Monoid a => a
mempty
      Output -> Mode -> Bool -> IO ()
setMode (Vty -> Output
outputIface Vty
v) Mode
Mouse Bool
True
      Vty -> IO Vty
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Vty
v

  if Bool -> Bool
not (UIOpts -> Bool
uoWatch UIOpts
uopts)
  then do
    Vty
vty <- IO Vty
makevty
    IO UIState -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UIState -> IO ()) -> IO UIState -> IO ()
forall a b. (a -> b) -> a -> b
$ Vty
-> IO Vty
-> Maybe (BChan AppEvent)
-> App UIState AppEvent Name
-> UIState
-> IO UIState
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
vty IO Vty
makevty Maybe (BChan AppEvent)
forall a. Maybe a
Nothing App UIState AppEvent Name
app UIState
ui

  else do
    -- a channel for sending misc. events to the app
    BChan AppEvent
eventChan <- IO (BChan AppEvent)
forall a. IO (BChan a)
newChan

    -- start a background thread reporting changes in the current date
    -- use async for proper child termination in GHCI
    let
      watchDate :: Day -> IO b
watchDate Day
old = do
        Int -> IO ()
threadDelay Int
1000000 -- 1 s
        Day
new <- IO Day
getCurrentDay
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Day
new Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
/= Day
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let dc :: AppEvent
dc = Day -> Day -> AppEvent
DateChange Day
old Day
new
          -- dbg1IO "datechange" dc -- XXX don't uncomment until dbg*IO fixed to use traceIO, GHC may block/end thread
          -- traceIO $ show dc
          BChan AppEvent -> AppEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeChan BChan AppEvent
eventChan AppEvent
dc
        Day -> IO b
watchDate Day
new

    IO Any -> (Async Any -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync
      -- run this small task asynchronously:
      (IO Day
getCurrentDay IO Day -> (Day -> IO Any) -> IO Any
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Day -> IO Any
forall {b}. Day -> IO b
watchDate)
      -- until this main task terminates:
      ((Async Any -> IO ()) -> IO ()) -> (Async Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async Any
_async ->
      -- start one or more background threads reporting changes in the directories of our files
      -- XXX many quick successive saves causes the problems listed in BUGS
      -- with Debounce increased to 1s it easily gets stuck on an error or blank screen
      -- until you press g, but it becomes responsive again quickly.
      -- withManagerConf defaultConfig{confDebounce=Debounce 1} $ \mgr -> do
      -- with Debounce at the default 1ms it clears transient errors itself
      -- but gets tied up for ages
      (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
        [[Char]]
files <- (([Char], Text) -> IO [Char]) -> [([Char], Text)] -> IO [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> IO [Char]
canonicalizePath ([Char] -> IO [Char])
-> (([Char], Text) -> [Char]) -> ([Char], Text) -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Text) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], Text)] -> IO [[Char]])
-> [([Char], Text)] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ Journal -> [([Char], Text)]
jfiles Journal
j
        let directories :: [[Char]]
directories = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubSort ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
takeDirectory [[Char]]
files
        [Char] -> [[Char]] -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"files" [[Char]]
files
        [Char] -> [[Char]] -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"directories to watch" [[Char]]
directories

        [[Char]] -> ([Char] -> IO (IO ())) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
directories (([Char] -> IO (IO ())) -> IO ())
-> ([Char] -> IO (IO ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
d -> WatchManager -> [Char] -> ActionPredicate -> Action -> IO (IO ())
watchDir
          WatchManager
mgr
          [Char]
d
          -- predicate: ignore changes not involving our files
          (\case
            Modified [Char]
f UTCTime
_ EventIsDirectory
IsFile -> [Char]
f [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
files
            -- Added    f _ -> f `elem` files
            -- Removed  f _ -> f `elem` files
            -- we don't handle adding/removing journal files right now
            -- and there might be some of those events from tmp files
            -- clogging things up so let's ignore them
            Event
_ -> Bool
False
            )
          -- action: send event to app
          (\Event
fev -> do
            -- return $ dbglog "fsnotify" $ showFSNEvent fev -- not working
            [Char] -> [Char] -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"fsnotify" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
fev
            BChan AppEvent -> AppEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeChan BChan AppEvent
eventChan AppEvent
FileChange
            )

        -- and start the app. Must be inside the withManager block. (XXX makevty too ?)
        Vty
vty <- IO Vty
makevty
        IO UIState -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UIState -> IO ()) -> IO UIState -> IO ()
forall a b. (a -> b) -> a -> b
$ Vty
-> IO Vty
-> Maybe (BChan AppEvent)
-> App UIState AppEvent Name
-> UIState
-> IO UIState
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
vty IO Vty
makevty (BChan AppEvent -> Maybe (BChan AppEvent)
forall a. a -> Maybe a
Just BChan AppEvent
eventChan) App UIState AppEvent Name
app UIState
ui

brickApp :: Maybe String -> App UIState AppEvent Name
brickApp :: Maybe [Char] -> App UIState AppEvent Name
brickApp Maybe [Char]
mtheme = App {
    appStartEvent :: EventM Name UIState ()
appStartEvent   = () -> EventM Name UIState ()
forall a. a -> EventM Name UIState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  , appAttrMap :: UIState -> AttrMap
appAttrMap      = AttrMap -> UIState -> AttrMap
forall a b. a -> b -> a
const (AttrMap -> UIState -> AttrMap) -> AttrMap -> UIState -> AttrMap
forall a b. (a -> b) -> a -> b
$ AttrMap -> Maybe AttrMap -> AttrMap
forall a. a -> Maybe a -> a
fromMaybe AttrMap
defaultTheme (Maybe AttrMap -> AttrMap) -> Maybe AttrMap -> AttrMap
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe AttrMap
getTheme ([Char] -> Maybe AttrMap) -> Maybe [Char] -> Maybe AttrMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Char]
mtheme
  , appChooseCursor :: UIState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = UIState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor
  , appHandleEvent :: BrickEvent Name AppEvent -> EventM Name UIState ()
appHandleEvent  = BrickEvent Name AppEvent -> EventM Name UIState ()
uiHandle
  , appDraw :: UIState -> [Widget Name]
appDraw         = UIState -> [Widget Name]
uiDraw
  }

uiHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
uiHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
uiHandle BrickEvent Name AppEvent
ev = do
  [Char] -> EventM Name UIState ()
forall s. [Char] -> EventM Name s ()
dbguiEv ([Char] -> EventM Name UIState ())
-> [Char] -> EventM Name UIState ()
forall a b. (a -> b) -> a -> b
$ [Char]
"\n==== " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BrickEvent Name AppEvent -> [Char]
forall a. Show a => a -> [Char]
show BrickEvent Name AppEvent
ev
  UIState
ui <- EventM Name UIState UIState
forall s (m :: * -> *). MonadState s m => m s
get
  case UIState -> Screen
aScreen UIState
ui of
    MS MenuScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
msHandle BrickEvent Name AppEvent
ev
    AS AccountsScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
asHandle BrickEvent Name AppEvent
ev
    CS AccountsScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
csHandle BrickEvent Name AppEvent
ev
    BS AccountsScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
bsHandle BrickEvent Name AppEvent
ev
    IS AccountsScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
isHandle BrickEvent Name AppEvent
ev
    RS RegisterScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
rsHandle BrickEvent Name AppEvent
ev
    TS TransactionScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
tsHandle BrickEvent Name AppEvent
ev
    ES ErrorScreenState
_ -> BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle BrickEvent Name AppEvent
ev

uiDraw :: UIState -> [Widget Name]
uiDraw :: UIState -> [Widget Name]
uiDraw UIState
ui =
  case UIState -> Screen
aScreen UIState
ui of
    MS MenuScreenState
_ -> UIState -> [Widget Name]
msDraw UIState
ui
    AS AccountsScreenState
_ -> UIState -> [Widget Name]
asDraw UIState
ui
    CS AccountsScreenState
_ -> UIState -> [Widget Name]
csDraw UIState
ui
    BS AccountsScreenState
_ -> UIState -> [Widget Name]
bsDraw UIState
ui
    IS AccountsScreenState
_ -> UIState -> [Widget Name]
isDraw UIState
ui
    RS RegisterScreenState
_ -> UIState -> [Widget Name]
rsDraw UIState
ui
    TS TransactionScreenState
_ -> UIState -> [Widget Name]
tsDraw UIState
ui
    ES ErrorScreenState
_ -> UIState -> [Widget Name]
esDraw UIState
ui