From dd040f9ca29e166ae63df86d2dc412eb9e1ff4dc Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 8 Dec 2008 17:27:16 +0000 Subject: [PATCH] a simple interactive text ui Lets you navigate around the balance, register, print reports and the raw ledger, and drill down on a single account. Adds a dependency on vty. --- Options.hs | 44 +++--- UICommand.hs | 381 ++++++++++++++++++++++++++++++++++++++++++++++++++ hledger.cabal | 2 +- hledger.hs | 3 + 4 files changed, 408 insertions(+), 22 deletions(-) create mode 100644 UICommand.hs diff --git a/Options.hs b/Options.hs index f45706c96..0b6236e74 100644 --- a/Options.hs +++ b/Options.hs @@ -36,27 +36,28 @@ usage = usageInfo usagehdr options ++ usageftr -- | Command-line options we accept. options :: [OptDescr Opt] options = [ - Option ['f'] ["file"] (ReqArg File "FILE") filehelp, - Option ['b'] ["begin"] (ReqArg Begin "DATE") "report on entries on or after this date", - Option ['e'] ["end"] (ReqArg End "DATE") "report on entries prior to this date", - Option ['p'] ["period"] (ReqArg Period "EXPR") ("report on entries during the specified period\n" ++ - "and/or with the specified reporting interval\n"), - Option ['C'] ["cleared"] (NoArg Cleared) "report only on cleared entries", - Option ['B'] ["cost","basis"] (NoArg CostBasis) "report cost basis of commodities", - Option [] ["depth"] (ReqArg Depth "N") "balance report: maximum account depth to show", - Option ['d'] ["display"] (ReqArg Display "EXPR") ("display only transactions matching simple EXPR\n" ++ - "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)"), - Option ['E'] ["empty"] (NoArg Empty) "balance report: show accounts with zero balance", - Option ['R'] ["real"] (NoArg Real) "report only on real (non-virtual) transactions", - Option [] ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns", - Option ['n'] ["collapse"] (NoArg Collapse) "balance report: no grand total", - Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts", - Option ['W'] ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary", - Option ['M'] ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary", - Option ['Y'] ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary", - Option ['h'] ["help"] (NoArg Help) "show this help", - Option ['v'] ["verbose"] (NoArg Verbose) "verbose test output", - Option ['V'] ["version"] (NoArg Version) "show version" + Option ['f'] ["file"] (ReqArg File "FILE") filehelp + ,Option ['b'] ["begin"] (ReqArg Begin "DATE") "report on entries on or after this date" + ,Option ['e'] ["end"] (ReqArg End "DATE") "report on entries prior to this date" + ,Option ['p'] ["period"] (ReqArg Period "EXPR") ("report on entries during the specified period\n" ++ + "and/or with the specified reporting interval\n") + ,Option ['C'] ["cleared"] (NoArg Cleared) "report only on cleared entries" + ,Option ['B'] ["cost","basis"] (NoArg CostBasis) "report cost basis of commodities" + ,Option [] ["depth"] (ReqArg Depth "N") "balance report: maximum account depth to show" + ,Option ['d'] ["display"] (ReqArg Display "EXPR") ("display only transactions matching simple EXPR\n" ++ + "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)") + ,Option ['E'] ["empty"] (NoArg Empty) "balance report: show accounts with zero balance" + ,Option ['R'] ["real"] (NoArg Real) "report only on real (non-virtual) transactions" + ,Option [] ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns" + ,Option ['n'] ["collapse"] (NoArg Collapse) "balance report: no grand total" + ,Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts" + ,Option ['W'] ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary" + ,Option ['M'] ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary" + ,Option ['Y'] ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary" + ,Option ['h'] ["help"] (NoArg Help) "show this help" + ,Option ['v'] ["verbose"] (NoArg Verbose) "verbose test output" + ,Option ['V'] ["version"] (NoArg Version) "show version" + ,Option [] ["debug-no-ui"] (NoArg DebugNoUI) "when running in ui mode, don't display anything (mostly)" ] where filehelp = printf "ledger file; - means use standard input. Defaults\nto the %s environment variable or %s" @@ -83,6 +84,7 @@ data Opt = Help | Verbose | Version + | DebugNoUI deriving (Show,Eq) -- yow.. diff --git a/UICommand.hs b/UICommand.hs new file mode 100644 index 000000000..7bedccc3c --- /dev/null +++ b/UICommand.hs @@ -0,0 +1,381 @@ +{-| + +A simple text UI for hledger. + +-} + +module UICommand +where +import qualified Data.Map as Map +import Data.Map ((!)) +import Graphics.Vty +import qualified Data.ByteString.Char8 as B +import Ledger +import Options +import BalanceCommand +import RegisterCommand +import PrintCommand + + +helpmsg = "Welcome to hledger. (b)alances, (r)egister, (p)rint entries, (l)edger, (right) to drill down, (left) to back up, or (q)uit" + +instance Show Vty where show v = "a Vty" + +data AppState = AppState { + av :: Vty -- the vty context + ,aw :: Int -- window width + ,ah :: Int -- window height + ,amsg :: String -- status message + ,aopts :: [Opt] -- command-line opts + ,aargs :: [String] -- command-line args + ,aledger :: Ledger -- parsed ledger + ,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) + +data Loc = Loc { + scr :: Screen -- ui screen + ,sy :: Int -- viewport y scroll position + ,cy :: Int -- cursor y position + } deriving (Show) + +data Screen = BalanceScreen -- like "hledger balance".. shows accounts + | RegisterScreen -- like "hledger register".. shows transactions + | PrintScreen -- like "hledger print".. shows entries + | LedgerScreen -- shows the raw ledger + deriving (Eq,Show) + +-- | Run the interactive text ui. +ui :: [Opt] -> [String] -> Ledger -> IO () +ui opts args l = do + v <- mkVty + (w,h) <- getSize v + let opts' = SubTotal:opts + let a = enter BalanceScreen $ + AppState { + av=v + ,aw=w + ,ah=h + ,amsg=helpmsg + ,aopts=opts' + ,aargs=args + ,aledger=l + ,abuf=[] + ,alocs=[] + } + go a + +-- | Update the screen, wait for the next event, repeat. +go :: AppState -> IO () +go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do + when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a) + k <- getEvent av + case k of + EvResize x y -> go $ resize x y a + EvKey (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg} + EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter BalanceScreen a + EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter RegisterScreen a + EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter PrintScreen a + EvKey (KASCII 'l') [] -> go $ resetTrailAndEnter LedgerScreen a + EvKey KRight [] -> go $ drilldown a + EvKey KEnter [] -> go $ drilldown a + EvKey KLeft [] -> go $ backout 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 (KASCII ' ') [MShift] -> go $ prevpage a + EvKey KPageDown [] -> go $ nextpage a + EvKey (KASCII ' ') [] -> go $ nextpage a + EvKey (KASCII 'q') [] -> shutdown av >> return () +-- EvKey KEsc [] -> shutdown av >> return () + _ -> go a + where + bh = length buf + y = posY a + +-- 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 y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l +setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l +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 x y a = setCursorY cy' a{aw=x,ah=y} + where + cy = cursorY a + cy' = min cy (y-2) + +moveToTop a = setPosY 0 a + +moveToBottom a = setPosY (length $ abuf a) a + +moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)} + | cy > 0 = updateCursorY (subtract 1) a + | sy > 0 = updateScrollY (subtract 1) a + | otherwise = a + +moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)} + | sy+cy >= bh = a + | cy < ph-1 = updateCursorY (+1) a + | otherwise = updateScrollY (+1) a + where + 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 (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 (a@AppState{abuf=b}) + | 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 + +screen :: AppState -> Screen +screen a = scr where (Loc scr _ _) = loc a + +-- | Enter a new screen, saving the old ui location on the stack. +enter :: Screen -> AppState -> AppState +enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter scr@LedgerScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a + +resetTrailAndEnter scr a = enter scr $ clearLocs a + +-- | Regenerate the display data based on current UI location. +updateData :: AppState -> AppState +updateData a@AppState{aopts=opts,aargs=args,aledger=l} + | scr == BalanceScreen = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} + | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l} + | scr == PrintScreen = a{abuf=lines $ showEntries opts args l} + | scr == LedgerScreen = a{abuf=lines $ rawledgertext l} + where scr = screen a + +backout :: AppState -> AppState +backout a + | screen a == BalanceScreen = a + | otherwise = updateData $ popLoc a + +drilldown :: AppState -> AppState +drilldown a + | screen a == BalanceScreen = enter RegisterScreen a{aargs=[currentAccountName a]} + | screen a == RegisterScreen = scrollToEntry e $ enter PrintScreen a + | screen a == PrintScreen = enter LedgerScreen a + | screen a == LedgerScreen = a + where e = currentEntry 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 (==' ') + +-- currentEntry/scrollToEntry doesn't work +-- | If on the print screen, move the cursor to highlight the specified entry +-- (or a reasonable guess). +scrollToEntry :: Entry -> AppState -> AppState +scrollToEntry e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a + where + entryfirstline = head $ lines $ showEntry $ e + halfph = pageHeight a `div` 2 + y = fromMaybe 0 $ findIndex (== entryfirstline) buf + sy = max 0 $ y - halfph + cy = y - sy + +-- | Get the entry containing the transaction currently highlighted by the +-- cursor on the register screen (or best guess). Results undefined while +-- on other screens. +currentEntry :: AppState -> Entry +currentEntry a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t + where + t = safehead nulltxn $ filter ismatch $ ledgerTransactions l + ismatch t = date t == (parsedate $ take 10 datedesc) + && (take 70 $ showtxn False t nullmixedamt) == (datedesc ++ acctamt) + datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ [safehead "" rest] ++ reverse above + acctamt = drop 32 $ safehead "" rest + safehead d ls = if null ls then d else head ls + (above,rest) = splitAt y buf + y = posY a + +-- | Get the entry which contains the given transaction. +-- Will raise an error if there are problems. +entryContainingTransaction :: AppState -> Transaction -> Entry +entryContainingTransaction AppState{aledger=l} t = (entries $ rawledger l) !! entryno t + +-- renderers + +renderScreen :: AppState -> Picture +renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) = + pic {pCursor = Cursor cx cy, + pImage = mainimg + <-> + renderStatus w msg + } + where + (cx, cy) = (0, cursorY a) + sy = scrollY a + -- trying for more speed + mainimg = (vertcat $ map (render defaultattr) above) + <-> + (render currentlineattr thisline) + <-> + (vertcat $ map (render defaultattr) below) + render attr = renderBS attr . B.pack + (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 l = take w $ l ++ blankline + blankline = replicate w ' ' +-- 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 + +padClipString :: Int -> Int -> String -> [String] +padClipString h w s = rows + where + rows = map padclipline $ take h $ lines s ++ replicate h blankline + padclipline l = take w $ l ++ blankline + blankline = replicate w ' ' + +renderString :: Attr -> String -> Image +renderString attr s = vertcat $ map (renderBS attr . B.pack) 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 s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) + + +-- the all-important theming engine + +theme = 1 + +(defaultattr, + currentlineattr, + statusattr + ) = + case theme of + 1 -> ( -- restrained + attr + ,setBold attr + ,setRV attr + ) + 2 -> ( -- colorful + setRV attr + ,setFG white $ setBG red $ attr + ,setFG black $ setBG green $ attr + ) + 3 -> ( -- + setRV attr + ,setFG white $ setBG red $ attr + ,setRV attr + ) + +halfbrightattr = setHalfBright attr +reverseattr = setRV attr +redattr = setFG red attr +greenattr = setFG green attr +reverseredattr = setRV $ setFG red attr +reversegreenattr= setRV $ setFG green attr + +-- pic { pCursor = Cursor x y, +-- pImage = renderFill pieceA ' ' w y +-- <-> +-- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1) +-- <-> +-- renderFill pieceA ' ' w (h - y - 1) +-- <-> +-- renderStatus w msg +-- } diff --git a/hledger.cabal b/hledger.cabal index 2f2ae7191..d5cb278c0 100644 --- a/hledger.cabal +++ b/hledger.cabal @@ -20,7 +20,7 @@ Cabal-Version: >= 1.2 Executable hledger Build-Depends: base, containers, haskell98, directory, parsec, regex-compat, regexpr - old-locale, time, HUnit + old-locale, time, HUnit, vty Main-Is: hledger.hs Other-Modules: BalanceCommand diff --git a/hledger.hs b/hledger.hs index b60586631..408221bc1 100644 --- a/hledger.hs +++ b/hledger.hs @@ -39,6 +39,7 @@ module Main ( module BalanceCommand, module PrintCommand, module RegisterCommand, + module UICommand, ) where import qualified Data.Map as Map (lookup) @@ -48,6 +49,7 @@ import Options import BalanceCommand import PrintCommand import RegisterCommand +import UICommand import Tests @@ -62,6 +64,7 @@ main = do | cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance | cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print' | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register + | cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr $ usage