1 {-| 
    2 
    3 A simple text UI for hledger, based on the vty library.
    4 
    5 -}
    6 
    7 module Commands.UI
    8 where
    9 import qualified Data.Map as Map
   10 import Data.Map ((!))
   11 import Graphics.Vty
   12 import qualified Data.ByteString.Char8 as B
   13 import Ledger
   14 import Options
   15 import Commands.Balance
   16 import Commands.Register
   17 import Commands.Print
   18 
   19 
   20 helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"
   21 
   22 instance Show Vty where show v = "a Vty"
   23 
   24 -- | The application state when running the ui command.
   25 data AppState = AppState {
   26      av :: Vty                   -- ^ the vty context
   27     ,aw :: Int                   -- ^ window width
   28     ,ah :: Int                   -- ^ window height
   29     ,amsg :: String              -- ^ status message
   30     ,aopts :: [Opt]              -- ^ command-line opts
   31     ,aargs :: [String]           -- ^ command-line args
   32     ,aledger :: Ledger           -- ^ parsed ledger
   33     ,abuf :: [String]            -- ^ lines of the current buffered view
   34     ,alocs :: [Loc]              -- ^ user's navigation trail within the UI
   35                                 -- ^ never null, head is current location
   36     } deriving (Show)
   37 
   38 -- | A location within the user interface.
   39 data Loc = Loc {
   40      scr :: Screen               -- ^ one of the available screens
   41     ,sy :: Int                   -- ^ viewport y scroll position
   42     ,cy :: Int                   -- ^ cursor y position
   43     } deriving (Show)
   44 
   45 -- | The screens available within the user interface.
   46 data Screen = BalanceScreen     -- ^ like hledger balance, shows accounts
   47             | RegisterScreen    -- ^ like hledger register, shows transaction-postings
   48             | PrintScreen       -- ^ like hledger print, shows ledger transactions
   49             | LedgerScreen      -- ^ shows the raw ledger
   50               deriving (Eq,Show)
   51 
   52 -- | Run the interactive text ui.
   53 ui :: [Opt] -> [String] -> Ledger -> IO ()
   54 ui opts args l = do
   55   v <- mkVty
   56   (w,h) <- getSize v
   57   let opts' = SubTotal:opts
   58   let a = enter BalanceScreen $ 
   59           AppState {
   60                   av=v
   61                  ,aw=w
   62                  ,ah=h
   63                  ,amsg=helpmsg
   64                  ,aopts=opts'
   65                  ,aargs=args
   66                  ,aledger=l
   67                  ,abuf=[]
   68                  ,alocs=[]
   69                  }
   70   go a 
   71 
   72 -- | Update the screen, wait for the next event, repeat.
   73 go :: AppState -> IO ()
   74 go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do
   75   when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a)
   76   k <- getEvent av
   77   case k of 
   78     EvResize x y                -> go $ resize x y a
   79     EvKey (KASCII 'l') [MCtrl]  -> refresh av >> go a{amsg=helpmsg}
   80     EvKey (KASCII 'b') []       -> go $ resetTrailAndEnter BalanceScreen a
   81     EvKey (KASCII 'r') []       -> go $ resetTrailAndEnter RegisterScreen a
   82     EvKey (KASCII 'p') []       -> go $ resetTrailAndEnter PrintScreen a
   83     -- EvKey (KASCII 'l') []       -> go $ resetTrailAndEnter LedgerScreen a
   84     EvKey KRight []             -> go $ drilldown a
   85     EvKey KEnter []             -> go $ drilldown a
   86     EvKey KLeft  []             -> go $ backout a
   87     EvKey KUp    []             -> go $ moveUpAndPushEdge a
   88     EvKey KDown  []             -> go $ moveDownAndPushEdge a
   89     EvKey KHome  []             -> go $ moveToTop a
   90     EvKey KUp    [MCtrl]        -> go $ moveToTop a
   91     EvKey KUp    [MShift]       -> go $ moveToTop a
   92     EvKey KEnd   []             -> go $ moveToBottom a
   93     EvKey KDown  [MCtrl]        -> go $ moveToBottom a
   94     EvKey KDown  [MShift]       -> go $ moveToBottom a
   95     EvKey KPageUp []            -> go $ prevpage a
   96     EvKey KBS []                -> go $ prevpage a
   97     EvKey (KASCII ' ') [MShift] -> go $ prevpage a
   98     EvKey KPageDown []          -> go $ nextpage a
   99     EvKey (KASCII ' ') []       -> go $ nextpage a
  100     EvKey (KASCII 'q') []       -> shutdown av >> return ()
  101 --    EvKey KEsc   []           -> shutdown av >> return ()
  102     _                           -> go a
  103     where
  104       bh = length buf
  105       y = posY a
  106 
  107 -- app state modifiers
  108 
  109 -- | The number of lines currently available for the main data display area.
  110 pageHeight :: AppState -> Int
  111 pageHeight a = ah a - 1
  112 
  113 setLocCursorY, setLocScrollY :: Int -> Loc -> Loc
  114 setLocCursorY y l = l{cy=y}
  115 setLocScrollY y l = l{sy=y}
  116 
  117 cursorY, scrollY, posY :: AppState -> Int
  118 cursorY = cy . loc
  119 scrollY = sy . loc
  120 posY a = scrollY a + cursorY a
  121 
  122 setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState
  123 setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l
  124 setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l
  125 setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)}
  126     where 
  127       l' = setLocScrollY sy $ setLocCursorY cy l
  128       ph = pageHeight a
  129       cy = y `mod` ph
  130       sy = y - cy
  131 
  132 updateCursorY, updateScrollY, updatePosY :: (Int -> Int) -> AppState -> AppState
  133 updateCursorY f a = setCursorY (f $ cursorY a) a
  134 updateScrollY f a = setScrollY (f $ scrollY a) a
  135 updatePosY f a = setPosY (f $ posY a) a
  136 
  137 resize :: Int -> Int -> AppState -> AppState
  138 resize x y a = setCursorY cy' a{aw=x,ah=y}
  139     where
  140       cy = cursorY a
  141       cy' = min cy (y-2)
  142 
  143 moveToTop :: AppState -> AppState
  144 moveToTop a = setPosY 0 a
  145 
  146 moveToBottom :: AppState -> AppState
  147 moveToBottom a = setPosY (length $ abuf a) a
  148 
  149 moveUpAndPushEdge :: AppState -> AppState
  150 moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}
  151     | cy > 0 = updateCursorY (subtract 1) a
  152     | sy > 0 = updateScrollY (subtract 1) a
  153     | otherwise = a
  154 
  155 moveDownAndPushEdge :: AppState -> AppState
  156 moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}
  157     | sy+cy >= bh = a
  158     | cy < ph-1 = updateCursorY (+1) a
  159     | otherwise = updateScrollY (+1) a
  160     where 
  161       ph = pageHeight a
  162       bh = length $ abuf a
  163 
  164 -- | Scroll down by page height or until we can just see the last line,
  165 -- without moving the cursor, or if we are already scrolled as far as
  166 -- possible then move the cursor to the last line.
  167 nextpage :: AppState -> AppState
  168 nextpage (a@AppState{abuf=b})
  169     | sy < bh-jump = setScrollY sy' a
  170     | otherwise    = setCursorY (bh-sy) a
  171     where
  172       sy = scrollY a
  173       jump = pageHeight a - 1
  174       bh = length b
  175       sy' = min (sy+jump) (bh-jump)
  176 
  177 -- | Scroll up by page height or until we can just see the first line,
  178 -- without moving the cursor, or if we are scrolled as far as possible
  179 -- then move the cursor to the first line.
  180 prevpage :: AppState -> AppState
  181 prevpage (a@AppState{abuf=b})
  182     | sy > 0    = setScrollY sy' a
  183     | otherwise = setCursorY 0 a
  184     where
  185       sy = scrollY a
  186       jump = pageHeight a - 1
  187       sy' = max (sy-jump) 0
  188 
  189 -- | Push a new UI location on to the stack.
  190 pushLoc :: Loc -> AppState -> AppState
  191 pushLoc l a = a{alocs=(l:alocs a)}
  192 
  193 popLoc :: AppState -> AppState
  194 popLoc a@AppState{alocs=locs}
  195     | length locs > 1 = a{alocs=drop 1 locs}
  196     | otherwise = a
  197 
  198 clearLocs :: AppState -> AppState
  199 clearLocs a = a{alocs=[]}
  200 
  201 exit :: AppState -> AppState 
  202 exit = popLoc
  203 
  204 loc :: AppState -> Loc
  205 loc = head . alocs
  206 
  207 screen :: AppState -> Screen
  208 screen a = scr where (Loc scr _ _) = loc a
  209 
  210 -- | Enter a new screen, saving the old ui location on the stack.
  211 enter :: Screen -> AppState -> AppState 
  212 enter scr@BalanceScreen a  = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
  213 enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
  214 enter scr@PrintScreen a    = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
  215 enter scr@LedgerScreen a   = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
  216 
  217 resetTrailAndEnter scr a = enter scr $ clearLocs a
  218 
  219 -- | Regenerate the display data appropriate for the current screen.
  220 updateData :: AppState -> AppState
  221 updateData a@AppState{aopts=opts,aargs=args,aledger=l}
  222     | scr == BalanceScreen  = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}
  223     | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l}
  224     | scr == PrintScreen    = a{abuf=lines $ showLedgerTransactions opts args l}
  225     | scr == LedgerScreen   = a{abuf=lines $ rawledgertext l}
  226     where scr = screen a
  227 
  228 backout :: AppState -> AppState
  229 backout a
  230     | screen a == BalanceScreen = a
  231     | otherwise = updateData $ popLoc a
  232 
  233 drilldown :: AppState -> AppState
  234 drilldown a
  235     | screen a == BalanceScreen  = enter RegisterScreen a{aargs=[currentAccountName a]}
  236     | screen a == RegisterScreen = scrollToLedgerTransaction e $ enter PrintScreen a
  237     | screen a == PrintScreen   = a
  238     -- screen a == PrintScreen   = enter LedgerScreen a
  239     -- screen a == LedgerScreen   = a
  240     where e = currentLedgerTransaction a
  241 
  242 -- | Get the account name currently highlighted by the cursor on the
  243 -- balance screen. Results undefined while on other screens.
  244 currentAccountName :: AppState -> AccountName
  245 currentAccountName a = accountNameAt (abuf a) (posY a)
  246 
  247 -- | Get the full name of the account being displayed at a specific line
  248 -- within the balance command's output.
  249 accountNameAt :: [String] -> Int -> AccountName
  250 accountNameAt buf lineno = accountNameFromComponents anamecomponents
  251     where
  252       namestohere = map (drop 22) $ take (lineno+1) buf
  253       (indented, nonindented) = span (" " `isPrefixOf`) $ reverse namestohere
  254       thisbranch = indented ++ take 1 nonindented
  255       anamecomponents = reverse $ map strip $ dropsiblings thisbranch
  256 
  257       dropsiblings :: [AccountName] -> [AccountName]
  258       dropsiblings [] = []
  259       dropsiblings (x:xs) = [x] ++ dropsiblings xs'
  260           where
  261             xs' = dropWhile moreindented xs
  262             moreindented = (>= myindent) . indentof
  263             myindent = indentof x
  264             indentof = length . takeWhile (==' ')
  265 
  266 -- | If on the print screen, move the cursor to highlight the specified entry
  267 -- (or a reasonable guess). Doesn't work.
  268 scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState
  269 scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
  270     where
  271       entryfirstline = head $ lines $ showLedgerTransaction $ e
  272       halfph = pageHeight a `div` 2
  273       y = fromMaybe 0 $ findIndex (== entryfirstline) buf
  274       sy = max 0 $ y - halfph
  275       cy = y - sy
  276 
  277 -- | Get the entry containing the transaction currently highlighted by the
  278 -- cursor on the register screen (or best guess). Results undefined while
  279 -- on other screens. Doesn't work.
  280 currentLedgerTransaction :: AppState -> LedgerTransaction
  281 currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t
  282     where
  283       t = safehead nulltxn $ filter ismatch $ ledgerTransactions l
  284       ismatch t = tdate t == (parsedate $ take 10 datedesc)
  285                   && (take 70 $ showtxn False t nullmixedamt) == (datedesc ++ acctamt)
  286       datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ [safehead "" rest] ++ reverse above
  287       acctamt = drop 32 $ safehead "" rest
  288       safehead d ls = if null ls then d else head ls
  289       (above,rest) = splitAt y buf
  290       y = posY a
  291 
  292 -- | Get the entry which contains the given transaction.
  293 -- Will raise an error if there are problems.
  294 entryContainingTransaction :: AppState -> Transaction -> LedgerTransaction
  295 entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !! tnum t
  296 
  297 -- renderers
  298 
  299 renderScreen :: AppState -> Picture
  300 renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
  301     pic {pCursor = Cursor cx cy,
  302          pImage = mainimg
  303                   <->
  304                   renderStatus w msg
  305         }
  306     where 
  307       (cx, cy) = (0, cursorY a)
  308       sy = scrollY a
  309       -- trying for more speed
  310       mainimg = (vertcat $ map (render defaultattr) above)
  311                <->
  312                (render currentlineattr thisline)
  313                <->
  314                (vertcat $ map (render defaultattr) below)
  315       render attr = renderBS attr . B.pack
  316       (thisline,below) | null rest = (blankline,[])
  317                        | otherwise = (head rest, tail rest)
  318       (above,rest) = splitAt cy linestorender
  319       linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
  320       padclipline l = take w $ l ++ blankline
  321       blankline = replicate w ' '
  322 --       mainimg = (renderString attr $ unlines $ above)
  323 --           <->
  324 --           (renderString reverseattr $ thisline)
  325 --           <->
  326 --           (renderString attr $ unlines $ below)
  327 --       (above,(thisline:below)) 
  328 --           | null ls   = ([],[""])
  329 --           | otherwise = splitAt y ls
  330 --       ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf
  331 
  332 padClipString :: Int -> Int -> String -> [String]
  333 padClipString h w s = rows
  334     where
  335       rows = map padclipline $ take h $ lines s ++ replicate h blankline
  336       padclipline l = take w $ l ++ blankline
  337       blankline = replicate w ' '
  338 
  339 renderString :: Attr -> String -> Image
  340 renderString attr s = vertcat $ map (renderBS attr . B.pack) rows
  341     where
  342       rows = lines $ fitto w h s
  343       w = maximum $ map length $ ls
  344       h = length ls
  345       ls = lines s
  346 
  347 renderStatus :: Int -> String -> Image
  348 renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) 
  349 
  350 
  351 -- the all-important theming engine
  352 
  353 theme = 1
  354 
  355 (defaultattr, 
  356  currentlineattr, 
  357  statusattr
  358  ) = 
  359     case theme of
  360       1 -> ( -- restrained
  361            attr
  362           ,setBold attr
  363           ,setRV attr
  364           )
  365       2 -> ( -- colorful
  366            setRV attr
  367           ,setFG white $ setBG red $ attr
  368           ,setFG black $ setBG green $ attr
  369           )
  370       3 -> ( -- 
  371            setRV attr
  372           ,setFG white $ setBG red $ attr
  373           ,setRV attr
  374           )
  375 
  376 halfbrightattr = setHalfBright attr
  377 reverseattr = setRV attr
  378 redattr = setFG red attr
  379 greenattr = setFG green attr
  380 reverseredattr = setRV $ setFG red attr
  381 reversegreenattr= setRV $ setFG green attr
  382 
  383 --     pic { pCursor = Cursor x y,
  384 --           pImage = renderFill pieceA ' ' w y 
  385 --           <->
  386 --           renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1) 
  387 --           <->
  388 --           renderFill pieceA ' ' w (h - y - 1) 
  389 --           <->
  390 --           renderStatus w msg
  391 --         }