{-# 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 (mkVty, Mode (Mouse), Vty (outputIface), Output (setMode))
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 = forall a. Int -> IO (BChan a)
BC.newBChan Int
10
writeChan :: BC.BChan a -> a -> IO ()
writeChan :: forall a. BChan a -> a -> IO ()
writeChan = forall a. BChan a -> a -> IO ()
BC.writeBChan
hledgerUiMain :: IO ()
hledgerUiMain :: IO ()
hledgerUiMain = forall a. [Char] -> IO a -> IO a
withProgName [Char]
"hledger-ui.log" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadIO m => Int -> [Char] -> m ()
traceLogAtIO Int
1 [Char]
"\n\n\n\n==== hledger-ui start"
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"args" [[Char]]
progArgs
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"debugLevel" Int
debugLevel
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
let copts' :: CliOpts
copts' = CliOpts
copts{inputopts_ :: InputOpts
inputopts_=InputOpts
iopts{forecast_ :: Maybe DateSpan
forecast_=InputOpts -> Maybe DateSpan
forecast_ InputOpts
iopts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just DateSpan
nulldatespan}}
case Bool
True of
Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"help" RawOpts
rawopts -> [Char] -> IO ()
pager (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" forall a. Maybe a
Nothing
Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"man" RawOpts
rawopts -> [Char] -> Maybe [Char] -> IO ()
runManForTopic [Char]
"hledger-ui" forall a. Maybe a
Nothing
Bool
_ | [Char] -> RawOpts -> Bool
boolopt [Char]
"version" RawOpts
rawopts -> [Char] -> IO ()
putStrLn [Char]
prognameandversion
Bool
_ -> 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
coptsforall s a. s -> Getting a s a -> a
^.forall c. HasReportSpec c => Lens' c Day
rsDay
uopts :: UIOpts
uopts = UIOpts
uopts0{
uoCliOpts :: CliOpts
uoCliOpts=CliOpts
copts{
reportspec_ :: ReportSpec
reportspec_=ReportSpec
rspec{
_rsQuery :: Query
_rsQuery=Query -> Query
filteredQuery forall a b. (a -> b) -> a -> b
$ ReportSpec -> Query
_rsQuery ReportSpec
rspec,
_rsReportOpts :: ReportOpts
_rsReportOpts=ReportOpts
ropts{
depth_ :: Maybe Int
depth_ = Query -> Maybe Int
queryDepth forall a b. (a -> b) -> a -> b
$ ReportSpec -> Query
_rsQuery ReportSpec
rspec,
period_ :: Period
period_ = Period
periodfromoptsandargs,
no_elide_ :: Bool
no_elide_ = Bool
True,
empty_ :: Bool
empty_ = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ReportOpts -> Bool
empty_ ReportOpts
ropts,
declared_ :: Bool
declared_ = Bool
True
}
}
}
}
where
datespanfromargs :: DateSpan
datespanfromargs = Bool -> Query -> DateSpan
queryDateSpan (ReportOpts -> Bool
date2_ ReportOpts
ropts) forall a b. (a -> b) -> a -> b
$ ReportSpec -> Query
_rsQuery ReportSpec
rspec
periodfromoptsandargs :: Period
periodfromoptsandargs =
DateSpan -> Period
dateSpanAsPeriod forall a b. (a -> b) -> a -> b
$ [DateSpan] -> DateSpan
spansIntersect [Period -> DateSpan
periodAsDateSpan forall a b. (a -> b) -> a -> b
$ ReportOpts -> Period
period_ ReportOpts
ropts, DateSpan
datespanfromargs]
filteredQuery :: Query -> Query
filteredQuery Query
q = Query -> Query
simplifyQuery 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 forall a b. (a -> b) -> a -> b
$ Query -> Bool
queryIsDepth Query
x Bool -> Bool -> Bool
|| Query -> Bool
queryIsDate Query
x)
rawopts :: RawOpts
rawopts = CliOpts -> RawOpts
rawopts_ forall a b. (a -> b) -> a -> b
$ UIOpts -> CliOpts
uoCliOpts forall a b. (a -> b) -> a -> b
$ UIOpts
uopts
([Screen]
prevscrs, Screen
currscr) =
forall a. Show a => (a -> [Char]) -> a -> a
dbg1With ([Char] -> (Screen -> [Char]) -> UIState -> [Char]
showScreenStack [Char]
"initial" Screen -> [Char]
showScreenSelection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry2 (UIOpts -> Journal -> [Screen] -> Screen -> UIState
uiState UIOpts
defuiopts Journal
nulljournal)) forall a b. (a -> b) -> a -> b
$
if
| [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)
| Just [Char]
apat <- UIOpts -> Maybe [Char]
uoRegister UIOpts
uopts ->
let
acct :: Text
acct = forall a. a -> Maybe a -> a
fromMaybe (forall a. [Char] -> a
error' forall a b. (a -> b) -> a -> b
$ [Char]
"--register "forall a. [a] -> [a] -> [a]
++[Char]
apatforall a. [a] -> [a] -> [a]
++[Char]
" did not match any account")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe Text
firstMatch forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalAccountNamesDeclaredOrImplied Journal
j
where
firstMatch :: [Text] -> Maybe Text
firstMatch = case Text -> Either [Char] Regexp
toRegexCI forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
apat of
Right Regexp
re -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Regexp -> Text -> Bool
regexMatchText Regexp
re)
Left [Char]
_ -> forall a b. a -> b -> a
const forall a. Maybe a
Nothing
regscr :: Screen
regscr =
Text -> Bool -> Screen -> Screen
rsSetAccount Text
acct Bool
False 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 forall a. Ord a => a -> a -> Bool
>= Int
de
Maybe Int
Nothing -> Bool
False
(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)
forall a b. a -> (a -> b) -> b
& forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Screen -> Screen
asSetSelectedAccount Text
acct)
menuscr' :: Screen
menuscr' = Int -> Screen -> Screen
msSetSelectedScreen Int
selidx Screen
menuscr
in ([Screen
acctsscr, Screen
menuscr'], Screen
regscr)
| 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 forall a. Maybe a
Nothing
csacctsscr :: Screen
csacctsscr = UIOpts -> Day -> Journal -> Maybe Text -> Screen
csNew UIOpts
uopts Day
today Journal
j forall a. Maybe a
Nothing
bsacctsscr :: Screen
bsacctsscr = UIOpts -> Day -> Journal -> Maybe Text -> Screen
bsNew UIOpts
uopts Day
today Journal
j forall a. Maybe a
Nothing
isacctsscr :: Screen
isacctsscr = UIOpts -> Day -> Journal -> Maybe Text -> Screen
isNew UIOpts
uopts Day
today Journal
j 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)
let
makevty :: IO Vty
makevty = do
Vty
v <- Config -> IO Vty
mkVty forall a. Monoid a => a
mempty
Output -> Mode -> Bool -> IO ()
setMode (Vty -> Output
outputIface Vty
v) Mode
Mouse Bool
True
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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall a. Maybe a
Nothing App UIState AppEvent Name
app UIState
ui
else do
BChan AppEvent
eventChan <- forall a. IO (BChan a)
newChan
let
watchDate :: Day -> IO b
watchDate Day
old = do
Int -> IO ()
threadDelay Int
1000000
Day
new <- IO Day
getCurrentDay
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Day
new forall a. Eq a => a -> a -> Bool
/= Day
old) forall a b. (a -> b) -> a -> b
$ do
let dc :: AppEvent
dc = Day -> Day -> AppEvent
DateChange Day
old Day
new
forall a. BChan a -> a -> IO ()
writeChan BChan AppEvent
eventChan AppEvent
dc
Day -> IO b
watchDate Day
new
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync
(IO Day
getCurrentDay forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}. Day -> IO b
watchDate)
forall a b. (a -> b) -> a -> b
$ \Async Any
_async ->
forall a. (WatchManager -> IO a) -> IO a
withManager forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
[[Char]]
files <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> IO [Char]
canonicalizePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Journal -> [([Char], Text)]
jfiles Journal
j
let directories :: [[Char]]
directories = forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
takeDirectory [[Char]]
files
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"files" [[Char]]
files
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"directories to watch" [[Char]]
directories
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
directories forall a b. (a -> b) -> a -> b
$ \[Char]
d -> WatchManager -> [Char] -> ActionPredicate -> Action -> IO (IO ())
watchDir
WatchManager
mgr
[Char]
d
(\case
Modified [Char]
f UTCTime
_ EventIsDirectory
IsFile -> [Char]
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
files
Event
_ -> Bool
False
)
(\Event
fev -> do
forall (m :: * -> *) a. (MonadIO m, Show a) => [Char] -> a -> m ()
dbg1IO [Char]
"fsnotify" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Event
fev
forall a. BChan a -> a -> IO ()
writeChan BChan AppEvent
eventChan AppEvent
FileChange
)
Vty
vty <- IO Vty
makevty
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 (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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, appAttrMap :: UIState -> AttrMap
appAttrMap = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe AttrMap
defaultTheme forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe AttrMap
getTheme forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Char]
mtheme
, appChooseCursor :: UIState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = 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
forall s. [Char] -> EventM Name s ()
dbguiEv forall a b. (a -> b) -> a -> b
$ [Char]
"\n==== " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show BrickEvent Name AppEvent
ev
UIState
ui <- 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