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

@@ -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 ['f'] ["file"]         (ReqArg File "FILE")   filehelp
- Option ['b'] ["begin"]        (ReqArg Begin "DATE") "report on entries on or after this date",
+ ,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 ['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" ++
+ ,Option ['p'] ["period"]       (ReqArg Period "EXPR") ("report on entries during the specified period\n" ++
-                                                       "and/or with the specified reporting interval\n"),
+                                                       "and/or with the specified reporting interval\n")
- Option ['C'] ["cleared"]      (NoArg  Cleared)       "report only on cleared entries",
+ ,Option ['C'] ["cleared"]      (NoArg  Cleared)       "report only on cleared entries"
- Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost basis of commodities",
+ ,Option ['B'] ["cost","basis"] (NoArg  CostBasis)     "report cost basis of commodities"
- Option []    ["depth"]        (ReqArg Depth "N")     "balance report: maximum account depth to show",
+ ,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" ++
+ ,Option ['d'] ["display"]      (ReqArg Display "EXPR") ("display only transactions matching simple EXPR\n" ++
-                                                        "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)"),
+                                                        "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)")
- Option ['E'] ["empty"]        (NoArg  Empty)         "balance report: show accounts with zero balance",
+ ,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 ['R'] ["real"]         (NoArg  Real)          "report only on real (non-virtual) transactions"
- Option []    ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns",
+ ,Option []    ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns"
- Option ['n'] ["collapse"]     (NoArg  Collapse)      "balance report: no grand total",
+ ,Option ['n'] ["collapse"]     (NoArg  Collapse)      "balance report: no grand total"
- Option ['s'] ["subtotal"]     (NoArg  SubTotal)      "balance report: show subaccounts",
+ ,Option ['s'] ["subtotal"]     (NoArg  SubTotal)      "balance report: show subaccounts"
- Option ['W'] ["weekly"]       (NoArg  WeeklyOpt)        "register report: show weekly summary",
+ ,Option ['W'] ["weekly"]       (NoArg  WeeklyOpt)     "register report: show weekly summary"
- Option ['M'] ["monthly"]      (NoArg  MonthlyOpt)       "register report: show monthly summary",
+ ,Option ['M'] ["monthly"]      (NoArg  MonthlyOpt)    "register report: show monthly summary"
- Option ['Y'] ["yearly"]       (NoArg  YearlyOpt)        "register report: show yearly summary",
+ ,Option ['Y'] ["yearly"]       (NoArg  YearlyOpt)     "register report: show yearly summary"
- Option ['h'] ["help"] (NoArg  Help)                  "show this help",
+ ,Option ['h'] ["help"] (NoArg  Help)                  "show this help"
- Option ['v'] ["verbose"]      (NoArg  Verbose)       "verbose test output",
+ ,Option ['v'] ["verbose"]      (NoArg  Verbose)       "verbose test output"
- Option ['V'] ["version"]      (NoArg  Version)       "show version"
+ ,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..

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
+--         }

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

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