simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-11-08 07:09:28 +03:00
Code Issues Projects Releases Wiki Activity

ui: rewrite the ui using brick

Browse Source 
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 2015-08-17 17:44:18 -07:00
parent 8f18560b05
commit 49e1840a0f
12 changed files with 449 additions and 394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
hledger-ui/Hledger/UI/AccountsScreen.hs Normal file
View 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"

470
hledger-ui/Hledger/UI/Main.hs
View File

@ -1,38 +1,77 @@
{-| {-|
hledger-ui - a hledger add-on providing a curses-style interface. 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. 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 Control.Monad
import Data.List -- import Data.Default
import Data.Maybe -- import Data.Monoid --
import Data.Time.Calendar -- import Data.List
import Graphics.Vty -- import Data.Maybe
import Safe -- import Data.Time.Calendar
-- import Safe
import System.Exit 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
import Hledger.Cli hiding (progname,prognameandversion,green) import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.Options 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 :: IO ()
main = do main = do
opts <- getHledgerUIOpts opts <- getHledgerUIOpts
-- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts) -- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
runWith opts run opts
runWith :: UIOpts -> IO ()
runWith opts = run opts
where where
run opts run opts
| "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp uimode) >> exitSuccess | "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp uimode) >> exitSuccess
| "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess | "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
| "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname) | "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
| otherwise = withJournalDo' opts ui | otherwise = withJournalDo' opts runBrickUi
withJournalDo' :: UIOpts -> (UIOpts -> Journal -> IO ()) -> IO () withJournalDo' :: UIOpts -> (UIOpts -> Journal -> IO ()) -> IO ()
withJournalDo' opts cmd = do withJournalDo' opts cmd = do
@ -42,385 +81,30 @@ withJournalDo' opts cmd = do
(head `fmap` journalFilePathFromOpts (cliopts_ opts)) >>= readJournalFile Nothing Nothing True >>= (head `fmap` journalFilePathFromOpts (cliopts_ opts)) >>= readJournalFile Nothing Nothing True >>=
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts)) either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
helpmsg = "(right) drill down, (left) back up, (q)uit" runBrickUi :: UIOpts -> Journal -> IO ()
runBrickUi opts j = do
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
d <- getCurrentDay 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. let
go :: AppState -> IO () args = words' $ query_ $ reportopts_ $ cliopts_ opts
go a@AppState{av=av,aopts=opts} = do scr = head appScreens
when (not $ debug_ui_ opts) $ update av (renderScreen a) st = (sInitFn scr) d args
k <- nextEvent av AppState{
d <- getCurrentDay aopts=opts
case k of ,aargs=args
EvResize x y -> go $ resize' x y a ,ajournal=j
EvKey (KChar 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg} ,aScreen=scr
-- EvKey (KChar 'b') [] -> go $ resetTrailAndEnter d BalanceScreen a ,aPrevScreens=[]
-- 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
-- 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. void $ M.defaultMain app st
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

5
hledger-ui/Hledger/UI/Options.hs
View File

@ -22,6 +22,11 @@ prognameandversion = progname ++ " " ++ version :: String
uiflags = [ uiflags = [
flagNone ["debug-ui"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console" 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])] --uimode :: Mode [([Char], [Char])]

100
hledger-ui/Hledger/UI/RegisterScreen.hs Normal file
View 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
View 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
View 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
View 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"

9
hledger-ui/hledger-ui.cabal
View File

@ -54,9 +54,14 @@ executable hledger-ui
hledger == 0.26.98 hledger == 0.26.98
, hledger-lib == 0.26.98 , hledger-lib == 0.26.98
, base >= 3 && < 5 , base >= 3 && < 5
, brick
, cmdargs >= 0.8 , cmdargs >= 0.8
, data-default
, HUnit , HUnit
, lens >= 4.12.3 && < 4.13
, safe >= 0.2 , safe >= 0.2
, transformers
, vector
, vty >= 5.2 && < 5.4 , vty >= 5.2 && < 5.4
if impl(ghc >= 7.4) if impl(ghc >= 7.4)
build-depends: pretty-show >= 1.6.4 build-depends: pretty-show >= 1.6.4
@ -68,4 +73,8 @@ executable hledger-ui
Hledger.UI Hledger.UI
Hledger.UI.Main Hledger.UI.Main
Hledger.UI.Options Hledger.UI.Options
Hledger.UI.UITypes
Hledger.UI.UIUtils
Hledger.UI.AccountsScreen
Hledger.UI.RegisterScreen
default-language: Haskell2010 default-language: Haskell2010

2
hledger-ui/package.yaml
View File

@ -68,6 +68,8 @@ executables:
- cmdargs >= 0.8 - cmdargs >= 0.8
- HUnit - HUnit
- safe >= 0.2 - safe >= 0.2
- transformers
- vector
- vty >= 5.2 && < 5.4 - vty >= 5.2 && < 5.4
# XXX not supported # XXX not supported
# if impl(ghc >= 7.4) # if impl(ghc >= 7.4)

1
hledger/Hledger/Cli/Balance.hs
View File

@ -236,6 +236,7 @@ module Hledger.Cli.Balance (
balancemode balancemode
,balance ,balance
,balanceReportAsText ,balanceReportAsText
,balanceReportItemAsText
,periodBalanceReportAsText ,periodBalanceReportAsText
,cumulativeBalanceReportAsText ,cumulativeBalanceReportAsText
,historicalBalanceReportAsText ,historicalBalanceReportAsText

1
hledger/Hledger/Cli/Options.hs
View File

@ -33,6 +33,7 @@ module Hledger.Cli.Options (
checkCliOpts, checkCliOpts,
outputFormats, outputFormats,
defaultOutputFormat, defaultOutputFormat,
defaultBalanceLineFormat,
-- possibly these should move into argsToCliOpts -- possibly these should move into argsToCliOpts
-- * CLI option accessors -- * CLI option accessors

2
stack.yaml
View File

@ -11,4 +11,6 @@ packages:
flags: flags:
extra-deps: extra-deps:
- brick-0.1
- text-zipper-0.2.1
- vty-5.3.1 - vty-5.3.1