diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs new file mode 100644 index 000000000..2ea571cb9 --- /dev/null +++ b/hledger-ui/Hledger/UI/AccountsScreen.hs @@ -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" diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 7ddc077f8..05737c955 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -1,38 +1,77 @@ {-| hledger-ui - a hledger add-on providing a curses-style interface. -Copyright (c) 2007-2011 Simon Michael +Copyright (c) 2007-2015 Simon Michael 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 :: 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 + } --- app state modifiers - --- | 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 diff --git a/hledger-ui/Hledger/UI/Options.hs b/hledger-ui/Hledger/UI/Options.hs index cb7b5f3a0..a44086457 100644 --- a/hledger-ui/Hledger/UI/Options.hs +++ b/hledger-ui/Hledger/UI/Options.hs @@ -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])] diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs new file mode 100644 index 000000000..d84eb7693 --- /dev/null +++ b/hledger-ui/Hledger/UI/RegisterScreen.hs @@ -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" diff --git a/hledger-ui/Hledger/UI/Theme.hs b/hledger-ui/Hledger/UI/Theme.hs new file mode 100644 index 000000000..758ebc8a4 --- /dev/null +++ b/hledger-ui/Hledger/UI/Theme.hs @@ -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 + diff --git a/hledger-ui/Hledger/UI/UITypes.hs b/hledger-ui/Hledger/UI/UITypes.hs new file mode 100644 index 000000000..1aec5ba8d --- /dev/null +++ b/hledger-ui/Hledger/UI/UITypes.hs @@ -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 _ = "" diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs new file mode 100644 index 000000000..f76f8a27f --- /dev/null +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -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" diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index 15c095e9e..7e9593bec 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -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 diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index 61923dd39..b4842832f 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -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) diff --git a/hledger/Hledger/Cli/Balance.hs b/hledger/Hledger/Cli/Balance.hs index ba9f7fc8d..1559147ae 100644 --- a/hledger/Hledger/Cli/Balance.hs +++ b/hledger/Hledger/Cli/Balance.hs @@ -236,6 +236,7 @@ module Hledger.Cli.Balance ( balancemode ,balance ,balanceReportAsText + ,balanceReportItemAsText ,periodBalanceReportAsText ,cumulativeBalanceReportAsText ,historicalBalanceReportAsText diff --git a/hledger/Hledger/Cli/Options.hs b/hledger/Hledger/Cli/Options.hs index 0619a1ebf..c54609c63 100644 --- a/hledger/Hledger/Cli/Options.hs +++ b/hledger/Hledger/Cli/Options.hs @@ -33,6 +33,7 @@ module Hledger.Cli.Options ( checkCliOpts, outputFormats, defaultOutputFormat, + defaultBalanceLineFormat, -- possibly these should move into argsToCliOpts -- * CLI option accessors diff --git a/stack.yaml b/stack.yaml index ed58c0106..f111201e3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,4 +11,6 @@ packages: flags: extra-deps: +- brick-0.1 +- text-zipper-0.2.1 - vty-5.3.1