mirror of
https://github.com/simonmichael/hledger.git
synced 2024-11-08 07:09:28 +03:00
ui: rewrite the ui using brick
hledger-ui (formerly hledger-vty) is now built on brick, a new declarative UI layer built on vty. This brings much new power, and should make the UI much easier to grow and maintain. At this point, functionality and performance are similar to the old version. There's no journal entries screen, but entering the postings screen jumps to the latest posting, and layout is better (multiple commodities are rendered on one line). Requires unreleased brick from github (HEAD or some branch) for now.
This commit is contained in:
Simon Michael
parent
8f18560b05
commit
49e1840a0f
122
hledger-ui/Hledger/UI/AccountsScreen.hs
Normal file
122
hledger-ui/Hledger/UI/AccountsScreen.hs
Normal file
@ -0,0 +1,122 @@
|
||||
-- The accounts screen, showing accounts and balances like the CLI balance command.
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.UI.AccountsScreen
|
||||
(screen)
|
||||
where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
-- import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
-- import Data.Default
|
||||
import Data.List
|
||||
-- import Data.Monoid --
|
||||
import Data.Time.Calendar (Day)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Brick.Types as T
|
||||
import qualified Brick.Main as M
|
||||
-- import qualified Brick.AttrMap as A
|
||||
import qualified Brick.Widgets.Border as B
|
||||
import qualified Brick.Widgets.Center as C
|
||||
import qualified Brick.Widgets.List as L
|
||||
-- import Brick.Util (fg, on)
|
||||
import Brick.Widgets.Core
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,prognameandversion,green)
|
||||
-- import Hledger.Cli.Options (defaultBalanceLineFormat)
|
||||
import Hledger.UI.Options
|
||||
import Hledger.UI.UITypes
|
||||
import Hledger.UI.UIUtils
|
||||
import qualified Hledger.UI.RegisterScreen as RS (screen)
|
||||
|
||||
screen = AccountsScreen{
|
||||
asState = L.list "accounts" V.empty
|
||||
,sInitFn = initAccountsScreen
|
||||
,sDrawFn = drawAccountsScreen
|
||||
,sHandleFn = handleAccountsScreen
|
||||
}
|
||||
|
||||
initAccountsScreen :: Day -> [String] -> AppState -> AppState
|
||||
initAccountsScreen d args st@AppState{aopts=opts, ajournal=j, aScreen=s@AccountsScreen{}} =
|
||||
st{aScreen=s{asState=is'}}
|
||||
where
|
||||
is' = L.list (T.Name "accounts") (V.fromList items)
|
||||
(items,_total) = balanceReport ropts q j
|
||||
where
|
||||
q = queryFromOpts d ropts
|
||||
-- query_="cur:\\$"} -- XXX limit to one commodity to ensure one-line items
|
||||
--{query_=unwords' $ locArgs l}
|
||||
ropts = (reportopts_ cliopts)
|
||||
{no_elide_=True}
|
||||
{query_=unwords' args}
|
||||
cliopts = cliopts_ opts
|
||||
initAccountsScreen _ _ _ = error "init function called with wrong screen type, should not happen"
|
||||
|
||||
drawAccountsScreen :: AppState -> [Widget]
|
||||
drawAccountsScreen st@AppState{aScreen=AccountsScreen{asState=is}} = [ui]
|
||||
where
|
||||
label = "Account " <+> cur <+> " of " <+> total
|
||||
cur = case is^.(L.listSelectedL) of
|
||||
Nothing -> "-"
|
||||
Just i -> str (show (i + 1))
|
||||
total = str $ show $ length $ is^.(L.listElementsL)
|
||||
box = B.borderWithLabel label $
|
||||
-- hLimit 25 $
|
||||
-- vLimit 15 $
|
||||
L.renderList is (drawAccountsItem fmt) 1
|
||||
ui = box
|
||||
_ui = C.vCenter $ vBox [ C.hCenter box
|
||||
, " "
|
||||
, C.hCenter "Press Esc to exit."
|
||||
]
|
||||
items = L.listElements is
|
||||
flat = flat_ $ reportopts_ $ cliopts_ $ aopts st
|
||||
acctcolwidth = maximum $
|
||||
V.map
|
||||
(\((full,short,indent),_) ->
|
||||
if flat then length full else length short + indent*2)
|
||||
items
|
||||
fmt = OneLine [ -- use a one-line format, List elements must have equal height
|
||||
FormatField True (Just 2) Nothing DepthSpacerField
|
||||
, FormatField True (Just acctcolwidth) Nothing AccountField
|
||||
, FormatLiteral " "
|
||||
, FormatField False (Just 40) Nothing TotalField
|
||||
]
|
||||
|
||||
drawAccountsScreen _ = error "draw function called with wrong screen type, should not happen"
|
||||
|
||||
drawAccountsItem :: StringFormat -> Bool -> BalanceReportItem -> Widget
|
||||
drawAccountsItem fmt sel item =
|
||||
let selStr i = if sel
|
||||
then withAttr customAttr (str $ showitem i)
|
||||
else str $ showitem i
|
||||
showitem = intercalate "\n" . balanceReportItemAsText defreportopts fmt
|
||||
in
|
||||
selStr item
|
||||
|
||||
handleAccountsScreen :: AppState -> Vty.Event -> M.EventM (M.Next AppState)
|
||||
handleAccountsScreen st@AppState{aScreen=scr@AccountsScreen{asState=is}} e = do
|
||||
d <- liftIO getCurrentDay
|
||||
-- c <- getContext
|
||||
-- let h = c^.availHeightL
|
||||
-- moveSel n l = L.listMoveBy n l
|
||||
case e of
|
||||
Vty.EvKey Vty.KEsc [] -> M.halt st
|
||||
Vty.EvKey (Vty.KChar 'q') [] -> M.halt st
|
||||
Vty.EvKey (Vty.KLeft) [] -> M.continue $ popScreen st
|
||||
Vty.EvKey (Vty.KRight) [] -> M.continue st'
|
||||
where
|
||||
st' = screenEnter d args RS.screen st
|
||||
args = case L.listSelectedElement is of
|
||||
Just (_, ((acct, _, _), _)) -> ["acct:"++accountNameToAccountRegex acct]
|
||||
Nothing -> []
|
||||
|
||||
-- Vty.EvKey (Vty.KPageDown) [] -> M.continue $ st{aScreen=scr{asState=moveSel h is}}
|
||||
-- Vty.EvKey (Vty.KPageUp) [] -> M.continue $ st{aScreen=scr{asState=moveSel (-h) is}}
|
||||
|
||||
-- fall through to the list's event handler (handles up/down)
|
||||
ev -> M.continue st{aScreen=scr{asState=T.handleEvent ev is}}
|
||||
handleAccountsScreen _ _ = error "event handler called with wrong screen type, should not happen"
|
||||
@ -1,38 +1,77 @@
|
||||
{-|
|
||||
hledger-ui - a hledger add-on providing a curses-style interface.
|
||||
Copyright (c) 2007-2011 Simon Michael <simon@joyful.com>
|
||||
Copyright (c) 2007-2015 Simon Michael <simon@joyful.com>
|
||||
Released under GPL version 3 or later.
|
||||
|
||||
TODO:
|
||||
reg: don't repeat date/description for postings in same txn
|
||||
reg: show a hledger-web-style register
|
||||
--
|
||||
switch to next brick release
|
||||
reg: use full width
|
||||
page up/down
|
||||
home/end
|
||||
search
|
||||
filter
|
||||
--
|
||||
show journal entries
|
||||
add
|
||||
edit
|
||||
-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module Hledger.UI.Main (main) where
|
||||
module Hledger.UI.Main where
|
||||
|
||||
-- import Control.Applicative
|
||||
-- import Control.Lens ((^.))
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Time.Calendar
|
||||
import Graphics.Vty
|
||||
import Safe
|
||||
-- import Data.Default
|
||||
-- import Data.Monoid --
|
||||
-- import Data.List
|
||||
-- import Data.Maybe
|
||||
-- import Data.Time.Calendar
|
||||
-- import Safe
|
||||
import System.Exit
|
||||
|
||||
import qualified Graphics.Vty as V
|
||||
-- import qualified Brick.Types as T
|
||||
import qualified Brick.Main as M
|
||||
-- import qualified Brick.AttrMap as A
|
||||
-- import qualified Brick.Widgets.Border as B
|
||||
-- import qualified Brick.Widgets.Center as C
|
||||
-- import qualified Brick.Widgets.List as L
|
||||
-- import Brick.Util (fg, on)
|
||||
-- import Brick.Widgets.Core
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,prognameandversion,green)
|
||||
import Hledger.UI.Options
|
||||
import Hledger.UI.UITypes
|
||||
import Hledger.UI.UIUtils
|
||||
import Hledger.UI.AccountsScreen as AS
|
||||
import Hledger.UI.RegisterScreen as RS
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- | The available screens.
|
||||
appScreens = [
|
||||
AS.screen
|
||||
,RS.screen
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- getHledgerUIOpts
|
||||
-- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
|
||||
runWith opts
|
||||
|
||||
runWith :: UIOpts -> IO ()
|
||||
runWith opts = run opts
|
||||
run opts
|
||||
where
|
||||
run opts
|
||||
| "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp uimode) >> exitSuccess
|
||||
| "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
|
||||
| "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
|
||||
| otherwise = withJournalDo' opts ui
|
||||
| "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp uimode) >> exitSuccess
|
||||
| "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
|
||||
| "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
|
||||
| otherwise = withJournalDo' opts runBrickUi
|
||||
|
||||
withJournalDo' :: UIOpts -> (UIOpts -> Journal -> IO ()) -> IO ()
|
||||
withJournalDo' opts cmd = do
|
||||
@ -42,385 +81,30 @@ withJournalDo' opts cmd = do
|
||||
(head `fmap` journalFilePathFromOpts (cliopts_ opts)) >>= readJournalFile Nothing Nothing True >>=
|
||||
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
|
||||
|
||||
helpmsg = "(right) drill down, (left) back up, (q)uit"
|
||||
|
||||
instance Show Vty where show = const "a Vty"
|
||||
|
||||
-- | The application state when running the ui command.
|
||||
data AppState = AppState {
|
||||
av :: Vty -- ^ the vty context
|
||||
,aw :: Int -- ^ window width
|
||||
,ah :: Int -- ^ window height
|
||||
,amsg :: String -- ^ status message
|
||||
,aopts :: UIOpts -- ^ command-line opts
|
||||
,aargs :: [String] -- ^ command-line args at startup
|
||||
,ajournal :: Journal -- ^ parsed journal
|
||||
,abuf :: [String] -- ^ lines of the current buffered view
|
||||
,alocs :: [Loc] -- ^ user's navigation trail within the UI
|
||||
-- ^ never null, head is current location
|
||||
} deriving (Show)
|
||||
|
||||
-- | A location within the user interface.
|
||||
data Loc = Loc {
|
||||
scr :: Screen -- ^ one of the available screens
|
||||
,sy :: Int -- ^ viewport y scroll position
|
||||
,cy :: Int -- ^ cursor y position
|
||||
,largs :: [String] -- ^ command-line args, possibly narrowed for this location
|
||||
} deriving (Show)
|
||||
|
||||
-- | The screens available within the user interface.
|
||||
data Screen = BalanceScreen -- ^ like hledger balance, shows accounts
|
||||
| RegisterScreen -- ^ like hledger register, shows transaction-postings
|
||||
| PrintScreen -- ^ like hledger print, shows journal transactions
|
||||
-- | LedgerScreen -- ^ shows the raw journal entries
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- | Run the curses-style ui.
|
||||
ui :: UIOpts -> Journal -> IO ()
|
||||
ui opts j = do
|
||||
cfg <- standardIOConfig
|
||||
vty <- mkVty cfg
|
||||
|
||||
-- let line0 = string (defAttr ` withForeColor ` green) "first line"
|
||||
-- line1 = string (defAttr ` withBackColor ` blue) "second line"
|
||||
-- img = line0 <-> line1
|
||||
-- pic = picForImage img
|
||||
-- update vty pic
|
||||
-- e <- nextEvent vty
|
||||
-- shutdown vty
|
||||
-- print ("Last event was: " ++ show e)
|
||||
|
||||
Output{displayBounds=getdisplayregion} <- outputForConfig cfg
|
||||
(w,h) <- getdisplayregion
|
||||
runBrickUi :: UIOpts -> Journal -> IO ()
|
||||
runBrickUi opts j = do
|
||||
d <- getCurrentDay
|
||||
let a = enter d BalanceScreen (words' $ query_ $ reportopts_ $ cliopts_ opts)
|
||||
AppState {
|
||||
av=vty
|
||||
,aw=w
|
||||
,ah=h
|
||||
,amsg=helpmsg
|
||||
,aopts=opts
|
||||
,aargs=words' $ query_ $ reportopts_ $ cliopts_ opts
|
||||
,ajournal=j
|
||||
,abuf=[]
|
||||
,alocs=[]
|
||||
}
|
||||
go a
|
||||
|
||||
-- | Update the screen, wait for the next event, repeat.
|
||||
go :: AppState -> IO ()
|
||||
go a@AppState{av=av,aopts=opts} = do
|
||||
when (not $ debug_ui_ opts) $ update av (renderScreen a)
|
||||
k <- nextEvent av
|
||||
d <- getCurrentDay
|
||||
case k of
|
||||
EvResize x y -> go $ resize' x y a
|
||||
EvKey (KChar 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg}
|
||||
-- EvKey (KChar 'b') [] -> go $ resetTrailAndEnter d BalanceScreen a
|
||||
-- EvKey (KChar 'r') [] -> go $ resetTrailAndEnter d RegisterScreen a
|
||||
-- EvKey (KChar 'p') [] -> go $ resetTrailAndEnter d PrintScreen a
|
||||
EvKey KRight [] -> go $ drilldown d a
|
||||
EvKey KEnter [] -> go $ drilldown d a
|
||||
EvKey KLeft [] -> go $ backout d a
|
||||
EvKey KUp [] -> go $ moveUpAndPushEdge a
|
||||
EvKey KDown [] -> go $ moveDownAndPushEdge a
|
||||
EvKey KHome [] -> go $ moveToTop a
|
||||
EvKey KUp [MCtrl] -> go $ moveToTop a
|
||||
EvKey KUp [MShift] -> go $ moveToTop a
|
||||
EvKey KEnd [] -> go $ moveToBottom a
|
||||
EvKey KDown [MCtrl] -> go $ moveToBottom a
|
||||
EvKey KDown [MShift] -> go $ moveToBottom a
|
||||
EvKey KPageUp [] -> go $ prevpage a
|
||||
EvKey KBS [] -> go $ prevpage a
|
||||
EvKey (KChar ' ') [MShift] -> go $ prevpage a
|
||||
EvKey KPageDown [] -> go $ nextpage a
|
||||
EvKey (KChar ' ') [] -> go $ nextpage a
|
||||
EvKey (KChar 'q') [] -> shutdown av >> return ()
|
||||
-- EvKey KEsc [] -> shutdown av >> return ()
|
||||
_ -> go a
|
||||
let
|
||||
args = words' $ query_ $ reportopts_ $ cliopts_ opts
|
||||
scr = head appScreens
|
||||
st = (sInitFn scr) d args
|
||||
AppState{
|
||||
aopts=opts
|
||||
,aargs=args
|
||||
,ajournal=j
|
||||
,aScreen=scr
|
||||
,aPrevScreens=[]
|
||||
}
|
||||
|
||||
-- app state modifiers
|
||||
app :: M.App (AppState) V.Event
|
||||
app = M.App {
|
||||
M.appLiftVtyEvent = id
|
||||
, M.appStartEvent = return
|
||||
, M.appAttrMap = const attrMap
|
||||
, M.appChooseCursor = M.showFirstCursor
|
||||
, M.appHandleEvent = \st ev -> (sHandleFn $ aScreen st) st ev
|
||||
, M.appDraw = \st -> (sDrawFn $ aScreen st) st
|
||||
}
|
||||
|
||||
-- | The number of lines currently available for the main data display area.
|
||||
pageHeight :: AppState -> Int
|
||||
pageHeight a = ah a - 1
|
||||
|
||||
setLocCursorY, setLocScrollY :: Int -> Loc -> Loc
|
||||
setLocCursorY y l = l{cy=y}
|
||||
setLocScrollY y l = l{sy=y}
|
||||
|
||||
cursorY, scrollY, posY :: AppState -> Int
|
||||
cursorY = cy . loc
|
||||
scrollY = sy . loc
|
||||
posY a = scrollY a + cursorY a
|
||||
|
||||
setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState
|
||||
setCursorY _ AppState{alocs=[]} = error' "shouldn't happen" -- silence warnings
|
||||
setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l
|
||||
|
||||
setScrollY _ AppState{alocs=[]} = error' "shouldn't happen" -- silence warnings
|
||||
setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l
|
||||
|
||||
setPosY _ AppState{alocs=[]} = error' "shouldn't happen" -- silence warnings
|
||||
setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)}
|
||||
where
|
||||
l' = setLocScrollY sy $ setLocCursorY cy l
|
||||
ph = pageHeight a
|
||||
cy = y `mod` ph
|
||||
sy = y - cy
|
||||
|
||||
updateCursorY, updateScrollY {-, updatePosY-} :: (Int -> Int) -> AppState -> AppState
|
||||
updateCursorY f a = setCursorY (f $ cursorY a) a
|
||||
updateScrollY f a = setScrollY (f $ scrollY a) a
|
||||
-- updatePosY f a = setPosY (f $ posY a) a
|
||||
|
||||
resize' :: Int -> Int -> AppState -> AppState
|
||||
resize' x y a = setCursorY cy' a{aw=x,ah=y}
|
||||
where
|
||||
cy = cursorY a
|
||||
cy' = min cy (y-2)
|
||||
|
||||
moveToTop :: AppState -> AppState
|
||||
moveToTop = setPosY 0
|
||||
|
||||
moveToBottom :: AppState -> AppState
|
||||
moveToBottom a = setPosY (length $ abuf a) a
|
||||
|
||||
moveUpAndPushEdge :: AppState -> AppState
|
||||
moveUpAndPushEdge a
|
||||
| cy > 0 = updateCursorY (subtract 1) a
|
||||
| sy > 0 = updateScrollY (subtract 1) a
|
||||
| otherwise = a
|
||||
where Loc{sy=sy,cy=cy} = head $ alocs a
|
||||
|
||||
moveDownAndPushEdge :: AppState -> AppState
|
||||
moveDownAndPushEdge a
|
||||
| sy+cy >= bh = a
|
||||
| cy < ph-1 = updateCursorY (+1) a
|
||||
| otherwise = updateScrollY (+1) a
|
||||
where
|
||||
Loc{sy=sy,cy=cy} = head $ alocs a
|
||||
ph = pageHeight a
|
||||
bh = length $ abuf a
|
||||
|
||||
-- | Scroll down by page height or until we can just see the last line,
|
||||
-- without moving the cursor, or if we are already scrolled as far as
|
||||
-- possible then move the cursor to the last line.
|
||||
nextpage :: AppState -> AppState
|
||||
nextpage (a@AppState{abuf=b})
|
||||
| sy < bh-jump = setScrollY sy' a
|
||||
| otherwise = setCursorY (bh-sy) a
|
||||
where
|
||||
sy = scrollY a
|
||||
jump = pageHeight a - 1
|
||||
bh = length b
|
||||
sy' = min (sy+jump) (bh-jump)
|
||||
|
||||
-- | Scroll up by page height or until we can just see the first line,
|
||||
-- without moving the cursor, or if we are scrolled as far as possible
|
||||
-- then move the cursor to the first line.
|
||||
prevpage :: AppState -> AppState
|
||||
prevpage a
|
||||
| sy > 0 = setScrollY sy' a
|
||||
| otherwise = setCursorY 0 a
|
||||
where
|
||||
sy = scrollY a
|
||||
jump = pageHeight a - 1
|
||||
sy' = max (sy-jump) 0
|
||||
|
||||
-- | Push a new UI location on to the stack.
|
||||
pushLoc :: Loc -> AppState -> AppState
|
||||
pushLoc l a = a{alocs=(l:alocs a)}
|
||||
|
||||
popLoc :: AppState -> AppState
|
||||
popLoc a@AppState{alocs=locs}
|
||||
| length locs > 1 = a{alocs=drop 1 locs}
|
||||
| otherwise = a
|
||||
|
||||
clearLocs :: AppState -> AppState
|
||||
clearLocs a = a{alocs=[]}
|
||||
|
||||
-- exit :: AppState -> AppState
|
||||
-- exit = popLoc
|
||||
|
||||
loc :: AppState -> Loc
|
||||
loc = head . alocs
|
||||
|
||||
-- | Get the filter pattern args in effect for the current ui location.
|
||||
currentArgs :: AppState -> [String]
|
||||
currentArgs (AppState {alocs=Loc{largs=as}:_}) = as
|
||||
currentArgs (AppState {aargs=as}) = as
|
||||
|
||||
screen :: AppState -> Screen
|
||||
screen a = scr where (Loc scr _ _ _) = loc a
|
||||
|
||||
-- | Enter a new screen, with possibly new args, adding the new ui location to the stack.
|
||||
enter :: Day -> Screen -> [String] -> AppState -> AppState
|
||||
enter d scr@BalanceScreen args a = updateData d $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
||||
enter d scr@RegisterScreen args a = updateData d $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
||||
enter d scr@PrintScreen args a = updateData d $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
||||
|
||||
resetTrailAndEnter :: Day -> Screen -> AppState -> AppState
|
||||
resetTrailAndEnter d scr a = enter d scr (aargs a) $ clearLocs a
|
||||
|
||||
-- | Regenerate the display data appropriate for the current screen.
|
||||
updateData :: Day -> AppState -> AppState
|
||||
updateData d a@AppState{aopts=opts,ajournal=j} =
|
||||
case screen a of
|
||||
BalanceScreen -> a{abuf=lines $ balanceReportAsText ropts $ balanceReport ropts q j}
|
||||
RegisterScreen -> a{abuf=lines $ postingsReportAsText cliopts $ postingsReport ropts q j}
|
||||
PrintScreen -> a{abuf=lines $ entriesReportAsText $ entriesReport ropts q j}
|
||||
where q = queryFromOpts d ropts{query_=unwords' $ currentArgs a}
|
||||
ropts = reportopts_ cliopts
|
||||
cliopts = cliopts_ opts
|
||||
|
||||
backout :: Day -> AppState -> AppState
|
||||
backout d a | screen a == BalanceScreen = a
|
||||
| otherwise = updateData d $ popLoc a
|
||||
|
||||
drilldown :: Day -> AppState -> AppState
|
||||
drilldown d a =
|
||||
case screen a of
|
||||
BalanceScreen -> enter d RegisterScreen [currentAccountName a] a
|
||||
RegisterScreen -> scrollToTransaction e $ enter d PrintScreen (currentArgs a) a
|
||||
PrintScreen -> a
|
||||
where e = currentTransaction a
|
||||
|
||||
-- | Get the account name currently highlighted by the cursor on the
|
||||
-- balance screen. Results undefined while on other screens.
|
||||
currentAccountName :: AppState -> AccountName
|
||||
currentAccountName a = accountNameAt (abuf a) (posY a)
|
||||
|
||||
-- | Get the full name of the account being displayed at a specific line
|
||||
-- within the balance command's output.
|
||||
accountNameAt :: [String] -> Int -> AccountName
|
||||
accountNameAt buf lineno = accountNameFromComponents anamecomponents
|
||||
where
|
||||
namestohere = map (drop 22) $ take (lineno+1) buf
|
||||
(indented, nonindented) = span (" " `isPrefixOf`) $ reverse namestohere
|
||||
thisbranch = indented ++ take 1 nonindented
|
||||
anamecomponents = reverse $ map strip $ dropsiblings thisbranch
|
||||
dropsiblings :: [AccountName] -> [AccountName]
|
||||
dropsiblings [] = []
|
||||
dropsiblings (x:xs) = x : dropsiblings xs'
|
||||
where
|
||||
xs' = dropWhile moreindented xs
|
||||
moreindented = (>= myindent) . indentof
|
||||
myindent = indentof x
|
||||
indentof = length . takeWhile (==' ')
|
||||
|
||||
-- | If on the print screen, move the cursor to highlight the specified entry
|
||||
-- (or a reasonable guess). Doesn't work.
|
||||
scrollToTransaction :: Maybe Transaction -> AppState -> AppState
|
||||
scrollToTransaction Nothing a = a
|
||||
scrollToTransaction (Just t) a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
|
||||
where
|
||||
entryfirstline = head $ lines $ showTransaction t
|
||||
halfph = pageHeight a `div` 2
|
||||
y = fromMaybe 0 $ findIndex (== entryfirstline) buf
|
||||
sy = max 0 $ y - halfph
|
||||
cy = y - sy
|
||||
|
||||
-- | Get the transaction containing the posting currently highlighted by
|
||||
-- the cursor on the register screen (or best guess). Results undefined
|
||||
-- while on other screens.
|
||||
currentTransaction :: AppState -> Maybe Transaction
|
||||
currentTransaction a@AppState{ajournal=j,abuf=buf} = ptransaction p
|
||||
where
|
||||
p = headDef nullposting $ filter ismatch $ journalPostings j
|
||||
ismatch p = postingDate p == parsedate (take 10 datedesc)
|
||||
&& take 70 (showPostingWithBalanceForUI p nullmixedamt) == (datedesc ++ acctamt)
|
||||
datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above
|
||||
acctamt = drop 32 $ headDef "" rest
|
||||
(above,rest) = splitAt y buf
|
||||
y = posY a
|
||||
|
||||
showPostingWithBalanceForUI p b =
|
||||
postingsReportItemAsText defcliopts $
|
||||
mkpostingsReportItem False False PrimaryDate Nothing p b
|
||||
|
||||
-- renderers
|
||||
|
||||
renderScreen :: AppState -> Picture
|
||||
renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
|
||||
Picture {picCursor = Cursor (fromIntegral cx) (fromIntegral cy)
|
||||
,picLayers = [mainimg
|
||||
<->
|
||||
renderStatus w msg
|
||||
]
|
||||
,picBackground = Background ' ' defAttr
|
||||
}
|
||||
where
|
||||
(cx, cy) = (0, cursorY a)
|
||||
sy = scrollY a
|
||||
-- mainimg = (renderString attr $ unlines $ above)
|
||||
-- <->
|
||||
-- (renderString reverseattr $ thisline)
|
||||
-- <->
|
||||
-- (renderString attr $ unlines $ below)
|
||||
-- (above,(thisline:below))
|
||||
-- | null ls = ([],[""])
|
||||
-- | otherwise = splitAt y ls
|
||||
-- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf
|
||||
-- trying for more speed
|
||||
mainimg = vertCat (map (string defaultattr) above)
|
||||
<->
|
||||
string currentlineattr thisline
|
||||
<->
|
||||
vertCat (map (string defaultattr) below)
|
||||
(thisline,below) | null rest = (blankline,[])
|
||||
| otherwise = (head rest, tail rest)
|
||||
(above,rest) = splitAt cy linestorender
|
||||
linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
|
||||
padclipline = take w . (++ blankline)
|
||||
blankline = replicate w ' '
|
||||
|
||||
-- padClipString :: Int -> Int -> String -> [String]
|
||||
-- padClipString h w s = rows
|
||||
-- where
|
||||
-- rows = map padclipline $ take h $ lines s ++ replicate h blankline
|
||||
-- padclipline = take w . (++ blankline)
|
||||
-- blankline = replicate w ' '
|
||||
|
||||
-- renderString :: Attr -> String -> Image
|
||||
-- renderString attr s = vertCat $ map (string attr) rows
|
||||
-- where
|
||||
-- rows = lines $ fitto w h s
|
||||
-- w = maximum $ map length ls
|
||||
-- h = length ls
|
||||
-- ls = lines s
|
||||
|
||||
renderStatus :: Int -> String -> Image
|
||||
renderStatus w = string statusattr . take w . (++ repeat ' ')
|
||||
|
||||
-- the all-important theming engine!
|
||||
|
||||
-- theme = Restrained
|
||||
theme = Colorful
|
||||
-- theme = Blood
|
||||
|
||||
data UITheme = Restrained | Colorful | Blood
|
||||
|
||||
(defaultattr,
|
||||
currentlineattr,
|
||||
statusattr
|
||||
) = case theme of
|
||||
Restrained -> (defAttr
|
||||
,defAttr `withStyle` bold
|
||||
,defAttr `withStyle` reverseVideo
|
||||
)
|
||||
Colorful -> (defAttr `withStyle` reverseVideo
|
||||
,defAttr `withForeColor` white `withBackColor` red
|
||||
,defAttr `withForeColor` black `withBackColor` green
|
||||
)
|
||||
Blood -> (defAttr `withStyle` reverseVideo
|
||||
,defAttr `withForeColor` white `withBackColor` red
|
||||
,defAttr `withStyle` reverseVideo
|
||||
)
|
||||
|
||||
-- halfbrightattr = defAttr `withStyle` dim
|
||||
-- reverseattr = defAttr `withStyle` reverseVideo
|
||||
-- redattr = defAttr `withForeColor` red
|
||||
-- greenattr = defAttr `withForeColor` green
|
||||
-- reverseredattr = defAttr `withStyle` reverseVideo `withForeColor` red
|
||||
-- reversegreenattr= defAttr `withStyle` reverseVideo `withForeColor` green
|
||||
void $ M.defaultMain app st
|
||||
|
||||
@ -22,6 +22,11 @@ prognameandversion = progname ++ " " ++ version :: String
|
||||
|
||||
uiflags = [
|
||||
flagNone ["debug-ui"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console"
|
||||
,flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show full account names, unindented"
|
||||
,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components"
|
||||
,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format"
|
||||
,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "no eliding at all, stronger than --empty"
|
||||
-- ,flagNone ["no-total"] (\opts -> setboolopt "no-total" opts) "don't show the final total"
|
||||
]
|
||||
|
||||
--uimode :: Mode [([Char], [Char])]
|
||||
|
||||
100
hledger-ui/Hledger/UI/RegisterScreen.hs
Normal file
100
hledger-ui/Hledger/UI/RegisterScreen.hs
Normal file
@ -0,0 +1,100 @@
|
||||
-- The register screen, showing account postings, like the CLI register command.
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.UI.RegisterScreen
|
||||
(screen)
|
||||
where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Data.List
|
||||
import Data.Time.Calendar (Day)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Brick.Types as T
|
||||
import qualified Brick.Main as M
|
||||
-- import qualified Brick.AttrMap as A
|
||||
import qualified Brick.Widgets.Border as B
|
||||
import qualified Brick.Widgets.Center as C
|
||||
import qualified Brick.Widgets.List as L
|
||||
-- import Brick.Util (fg, on)
|
||||
import Brick.Widgets.Core
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,prognameandversion,green)
|
||||
import Hledger.UI.Options
|
||||
import Hledger.UI.UITypes
|
||||
import Hledger.UI.UIUtils
|
||||
|
||||
screen = RegisterScreen{
|
||||
rsState = L.list "register" V.empty
|
||||
,sInitFn = initRegisterScreen
|
||||
,sDrawFn = drawRegisterScreen
|
||||
,sHandleFn = handleRegisterScreen
|
||||
}
|
||||
|
||||
initRegisterScreen :: Day -> [String] -> AppState -> AppState
|
||||
initRegisterScreen d args st@AppState{aopts=opts, ajournal=j, aScreen=s@RegisterScreen{}} =
|
||||
st{aScreen=s{rsState=is'}}
|
||||
where
|
||||
is' =
|
||||
L.listMoveTo (length items) $
|
||||
L.list (T.Name "register") (V.fromList items)
|
||||
(_label,items) = postingsReport ropts q j
|
||||
where
|
||||
q = queryFromOpts d ropts
|
||||
-- query_="cur:\\$"} -- XXX limit to one commodity to ensure one-line items
|
||||
--{query_=unwords' $ locArgs l}
|
||||
ropts = (reportopts_ cliopts)
|
||||
{query_=unwords' args}
|
||||
cliopts = cliopts_ opts
|
||||
initRegisterScreen _ _ _ = error "init function called with wrong screen type, should not happen"
|
||||
|
||||
drawRegisterScreen :: AppState -> [Widget]
|
||||
drawRegisterScreen AppState{aopts=_opts, aScreen=RegisterScreen{rsState=is}} = [ui]
|
||||
where
|
||||
label = "Posting " <+> cur <+> " of " <+> total <+> " in this account and subaccounts" -- " <+> str query <+> "and subaccounts"
|
||||
cur = case is^.(L.listSelectedL) of
|
||||
Nothing -> "-"
|
||||
Just i -> str (show (i + 1))
|
||||
total = str $ show $ length $ is^.(L.listElementsL)
|
||||
-- query = query_ $ reportopts_ $ cliopts_ opts
|
||||
box = B.borderWithLabel label $
|
||||
-- hLimit 25 $
|
||||
-- vLimit 15 $
|
||||
L.renderList is drawRegisterItem 1
|
||||
ui = box
|
||||
_ui = C.vCenter $ vBox [ C.hCenter box
|
||||
, " "
|
||||
, C.hCenter "Press Esc to exit."
|
||||
]
|
||||
drawRegisterScreen _ = error "draw function called with wrong screen type, should not happen"
|
||||
|
||||
drawRegisterItem :: Bool -> PostingsReportItem -> Widget
|
||||
drawRegisterItem sel item =
|
||||
let selStr i = if sel
|
||||
then withAttr customAttr (str $ showitem i)
|
||||
else str $ showitem i
|
||||
showitem (_,_,_,p,b) =
|
||||
intercalate ", " $ map strip $ lines $
|
||||
postingsReportItemAsText defcliopts $
|
||||
mkpostingsReportItem True True PrimaryDate Nothing p b
|
||||
-- fmt = BottomAligned [
|
||||
-- FormatField False (Just 20) Nothing TotalField
|
||||
-- , FormatLiteral " "
|
||||
-- , FormatField True (Just 2) Nothing DepthSpacerField
|
||||
-- , FormatField True Nothing Nothing AccountField
|
||||
-- ]
|
||||
in
|
||||
selStr item
|
||||
|
||||
handleRegisterScreen :: AppState -> Vty.Event -> M.EventM (M.Next AppState)
|
||||
handleRegisterScreen st@AppState{aScreen=s@RegisterScreen{rsState=is}} e =
|
||||
case e of
|
||||
Vty.EvKey Vty.KEsc [] -> M.halt st
|
||||
Vty.EvKey (Vty.KChar 'q') [] -> M.halt st
|
||||
Vty.EvKey (Vty.KLeft) [] -> M.continue $ popScreen st
|
||||
-- Vty.EvKey (Vty.KRight) [] -> error (show curItem) where curItem = L.listSelectedElement is
|
||||
-- fall through to the list's event handler (handles up/down)
|
||||
ev -> M.continue st{aScreen=s{rsState=T.handleEvent ev is}}
|
||||
handleRegisterScreen _ _ = error "event handler called with wrong screen type, should not happen"
|
||||
34
hledger-ui/Hledger/UI/Theme.hs
Normal file
34
hledger-ui/Hledger/UI/Theme.hs
Normal file
@ -0,0 +1,34 @@
|
||||
----------------------------------------------------------------------
|
||||
-- Theme
|
||||
-- the all-important theming engine!
|
||||
|
||||
-- theme = Restrained
|
||||
-- -- theme = Colorful
|
||||
-- -- theme = Blood
|
||||
|
||||
-- data UITheme = Restrained | Colorful | Blood
|
||||
|
||||
-- (defaultattr,
|
||||
-- currentlineattr,
|
||||
-- statusattr
|
||||
-- ) = case theme of
|
||||
-- Restrained -> (defAttr
|
||||
-- ,defAttr `withStyle` bold
|
||||
-- ,defAttr `withStyle` reverseVideo
|
||||
-- )
|
||||
-- Colorful -> (defAttr `withStyle` reverseVideo
|
||||
-- ,defAttr `withForeColor` white `withBackColor` red
|
||||
-- ,defAttr `withForeColor` black `withBackColor` green
|
||||
-- )
|
||||
-- Blood -> (defAttr `withStyle` reverseVideo
|
||||
-- ,defAttr `withForeColor` white `withBackColor` red
|
||||
-- ,defAttr `withStyle` reverseVideo
|
||||
-- )
|
||||
|
||||
-- -- halfbrightattr = defAttr `withStyle` dim
|
||||
-- -- reverseattr = defAttr `withStyle` reverseVideo
|
||||
-- -- redattr = defAttr `withForeColor` red
|
||||
-- -- greenattr = defAttr `withForeColor` green
|
||||
-- -- reverseredattr = defAttr `withStyle` reverseVideo `withForeColor` red
|
||||
-- -- reversegreenattr= defAttr `withStyle` reverseVideo `withForeColor` green
|
||||
|
||||
44
hledger-ui/Hledger/UI/UITypes.hs
Normal file
44
hledger-ui/Hledger/UI/UITypes.hs
Normal file
@ -0,0 +1,44 @@
|
||||
module Hledger.UI.UITypes where
|
||||
|
||||
import Data.Time.Calendar (Day)
|
||||
import qualified Graphics.Vty as V
|
||||
import qualified Brick.Main as M
|
||||
import qualified Brick.Widgets.List as L
|
||||
import Brick.Widgets.Core
|
||||
( Widget(..)
|
||||
)
|
||||
|
||||
import Hledger
|
||||
import Hledger.UI.Options
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- | hledger-ui's application state. This is part of, but distinct
|
||||
-- from, brick's M.App.
|
||||
data AppState = AppState {
|
||||
aopts :: UIOpts -- ^ command-line options at startup
|
||||
,aargs :: [String] -- ^ command-line arguments at startup
|
||||
,ajournal :: Journal -- ^ the parsed journal
|
||||
,aScreen :: Screen -- ^ the currently active screen
|
||||
,aPrevScreens :: [Screen] -- ^ previously visited screens
|
||||
} deriving (Show)
|
||||
|
||||
-- | Types of screen available within the app, along with their state.
|
||||
-- Screen types are distinguished by their constructor and by the type
|
||||
-- of their state (hence the unique accessor names for the latter).
|
||||
data Screen =
|
||||
AccountsScreen {
|
||||
asState :: L.List BalanceReportItem -- ^ the screen's state (data being displayed and widget state)
|
||||
,sInitFn :: Day -> [String] -> AppState -> AppState -- ^ function to initialise the screen's state on entry
|
||||
,sHandleFn :: AppState -> V.Event -> M.EventM (M.Next AppState) -- ^ brick event handler to use for this screen
|
||||
,sDrawFn :: AppState -> [Widget] -- ^ brick renderer to use for this screen
|
||||
}
|
||||
| RegisterScreen {
|
||||
rsState :: L.List PostingsReportItem
|
||||
,sInitFn :: Day -> [String] -> AppState -> AppState
|
||||
,sHandleFn :: AppState -> V.Event -> M.EventM (M.Next AppState)
|
||||
,sDrawFn :: AppState -> [Widget]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Show (L.List a) where show _ = "<List>"
|
||||
51
hledger-ui/Hledger/UI/UIUtils.hs
Normal file
51
hledger-ui/Hledger/UI/UIUtils.hs
Normal file
@ -0,0 +1,51 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.UI.UIUtils
|
||||
where
|
||||
|
||||
-- import Control.Lens ((^.))
|
||||
-- import Control.Monad
|
||||
-- import Data.Default
|
||||
import Data.Monoid --
|
||||
import Data.Time.Calendar (Day)
|
||||
import qualified Graphics.Vty as V
|
||||
-- import qualified Brick.Types as T
|
||||
-- import qualified Brick.Main as M
|
||||
import qualified Brick.AttrMap as A
|
||||
-- import qualified Brick.Widgets.Border as B
|
||||
-- import qualified Brick.Widgets.Center as C
|
||||
import qualified Brick.Widgets.List as L
|
||||
import Brick.Util
|
||||
|
||||
import Hledger.UI.UITypes
|
||||
|
||||
pushScreen :: Screen -> AppState -> AppState
|
||||
pushScreen scr st = st{aPrevScreens=(aScreen st:aPrevScreens st)
|
||||
,aScreen=scr
|
||||
}
|
||||
|
||||
popScreen :: AppState -> AppState
|
||||
popScreen st@AppState{aPrevScreens=s:ss} = st{aScreen=s, aPrevScreens=ss}
|
||||
popScreen st = st
|
||||
|
||||
-- clearScreens :: AppState -> AppState
|
||||
-- clearScreens st = st{aPrevScreens=[]}
|
||||
|
||||
-- | Enter a new screen, saving the old screen & state in the
|
||||
-- navigation history and initialising the new screen's state.
|
||||
-- Extra args can be passed to the new screen's init function,
|
||||
-- these can be eg query arguments.
|
||||
screenEnter :: Day -> [String] -> Screen -> AppState -> AppState
|
||||
screenEnter d args scr st = (sInitFn scr) d args $
|
||||
pushScreen scr
|
||||
st
|
||||
|
||||
attrMap :: A.AttrMap
|
||||
attrMap = A.attrMap V.defAttr
|
||||
[ (L.listAttr, V.white `on` V.blue)
|
||||
, (L.listSelectedAttr, V.black `on` V.white)
|
||||
-- , (customAttr, fg V.cyan)
|
||||
]
|
||||
|
||||
customAttr :: A.AttrName
|
||||
customAttr = L.listSelectedAttr <> "custom"
|
||||
@ -54,9 +54,14 @@ executable hledger-ui
|
||||
hledger == 0.26.98
|
||||
, hledger-lib == 0.26.98
|
||||
, base >= 3 && < 5
|
||||
, brick
|
||||
, cmdargs >= 0.8
|
||||
, data-default
|
||||
, HUnit
|
||||
, lens >= 4.12.3 && < 4.13
|
||||
, safe >= 0.2
|
||||
, transformers
|
||||
, vector
|
||||
, vty >= 5.2 && < 5.4
|
||||
if impl(ghc >= 7.4)
|
||||
build-depends: pretty-show >= 1.6.4
|
||||
@ -68,4 +73,8 @@ executable hledger-ui
|
||||
Hledger.UI
|
||||
Hledger.UI.Main
|
||||
Hledger.UI.Options
|
||||
Hledger.UI.UITypes
|
||||
Hledger.UI.UIUtils
|
||||
Hledger.UI.AccountsScreen
|
||||
Hledger.UI.RegisterScreen
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -68,6 +68,8 @@ executables:
|
||||
- cmdargs >= 0.8
|
||||
- HUnit
|
||||
- safe >= 0.2
|
||||
- transformers
|
||||
- vector
|
||||
- vty >= 5.2 && < 5.4
|
||||
# XXX not supported
|
||||
# if impl(ghc >= 7.4)
|
||||
|
||||
@ -236,6 +236,7 @@ module Hledger.Cli.Balance (
|
||||
balancemode
|
||||
,balance
|
||||
,balanceReportAsText
|
||||
,balanceReportItemAsText
|
||||
,periodBalanceReportAsText
|
||||
,cumulativeBalanceReportAsText
|
||||
,historicalBalanceReportAsText
|
||||
|
||||
@ -33,6 +33,7 @@ module Hledger.Cli.Options (
|
||||
checkCliOpts,
|
||||
outputFormats,
|
||||
defaultOutputFormat,
|
||||
defaultBalanceLineFormat,
|
||||
|
||||
-- possibly these should move into argsToCliOpts
|
||||
-- * CLI option accessors
|
||||
|
||||
@ -11,4 +11,6 @@ packages:
|
||||
flags:
|
||||
|
||||
extra-deps:
|
||||
- brick-0.1
|
||||
- text-zipper-0.2.1
|
||||
- vty-5.3.1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user