c6a85c4b88
All this stuff has been split up, except for the moment it's still necessary to define all option constructors in Hledger.Cli.Options.
423 lines
16 KiB
Haskell
423 lines
16 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-|
|
|
hledger-vty - a hledger add-on providing a curses-style interface.
|
|
Copyright (c) 2007-2010 Simon Michael <simon@joyful.com>
|
|
Released under GPL version 3 or later.
|
|
-}
|
|
|
|
module Hledger.Vty.Main where
|
|
|
|
#if __GLASGOW_HASKELL__ <= 610
|
|
import Prelude hiding (putStr, putStrLn)
|
|
import System.IO.UTF8 (putStr, putStrLn)
|
|
#endif
|
|
import Graphics.Vty
|
|
import Safe (headDef)
|
|
import System.Console.GetOpt
|
|
|
|
import Hledger.Cli.Balance
|
|
import Hledger.Cli.Options
|
|
import Hledger.Cli.Print
|
|
import Hledger.Cli.Register
|
|
import Hledger.Cli.Utils (withJournalDo)
|
|
import Hledger.Cli.Version (progversionstr, binaryfilename)
|
|
import Hledger.Data
|
|
|
|
|
|
progname_vty = progname_cli ++ "-vty"
|
|
|
|
options_vty :: [OptDescr Opt]
|
|
options_vty = [
|
|
Option "" ["debug-vty"] (NoArg DebugVty) "run with no terminal output, showing console"
|
|
]
|
|
|
|
usage_preamble_vty =
|
|
"Usage: hledger-vty [OPTIONS] [PATTERNS]\n" ++
|
|
"\n" ++
|
|
"Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++
|
|
"starts the full-window curses ui.\n" ++
|
|
"\n"
|
|
|
|
usage_options_vty = usageInfo "hledger-vty options:" options_vty ++ "\n"
|
|
|
|
usage_vty = concat [
|
|
usage_preamble_vty
|
|
,usage_options_vty
|
|
,usage_options_cli
|
|
,usage_postscript_cli
|
|
]
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(opts, cmd, args) <- parseArgumentsWith (options_cli++options_vty) usage_vty
|
|
run opts (cmd:args)
|
|
where
|
|
run opts args
|
|
| Help `elem` opts = putStr usage_vty
|
|
| Version `elem` opts = putStrLn $ progversionstr progname_vty
|
|
| BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_vty
|
|
| otherwise = withJournalDo opts args "vty" vty
|
|
|
|
helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"
|
|
|
|
instance Show Vty where show = const "a Vty"
|
|
|
|
-- | The application state when running the vty command.
|
|
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 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
|
|
deriving (Eq,Show)
|
|
|
|
-- | Run the vty (curses-style) ui.
|
|
vty :: [Opt] -> [String] -> Journal -> IO ()
|
|
vty opts args j = do
|
|
v <- mkVty
|
|
DisplayRegion w h <- display_bounds $ terminal v
|
|
let opts' = SubTotal:opts
|
|
t <- getCurrentLocalTime
|
|
let a = enter t BalanceScreen args
|
|
AppState {
|
|
av=v
|
|
,aw=fromIntegral w
|
|
,ah=fromIntegral h
|
|
,amsg=helpmsg
|
|
,aopts=opts'
|
|
,aargs=args
|
|
,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 (notElem DebugVty opts) $ update av (renderScreen a)
|
|
k <- next_event av
|
|
t <- getCurrentLocalTime
|
|
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 t BalanceScreen a
|
|
EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter t RegisterScreen a
|
|
EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter t PrintScreen a
|
|
EvKey KRight [] -> go $ drilldown t a
|
|
EvKey KEnter [] -> go $ drilldown t a
|
|
EvKey KLeft [] -> go $ backout t 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
|
|
|
|
-- 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 :: LocalTime -> Screen -> [String] -> AppState -> AppState
|
|
enter t scr@BalanceScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
|
enter t scr@RegisterScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
|
enter t scr@PrintScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
|
|
|
|
resetTrailAndEnter :: LocalTime -> Screen -> AppState -> AppState
|
|
resetTrailAndEnter t scr a = enter t scr (aargs a) $ clearLocs a
|
|
|
|
-- | Regenerate the display data appropriate for the current screen.
|
|
updateData :: LocalTime -> AppState -> AppState
|
|
updateData t a@AppState{aopts=opts,ajournal=j} =
|
|
case screen a of
|
|
BalanceScreen -> a{abuf=lines $ balanceReportAsText opts $ balanceReport opts fspec j}
|
|
RegisterScreen -> a{abuf=lines $ registerReportAsText opts $ registerReport opts fspec j}
|
|
PrintScreen -> a{abuf=lines $ showTransactions fspec j}
|
|
where fspec = optsToFilterSpec opts (currentArgs a) t
|
|
|
|
backout :: LocalTime -> AppState -> AppState
|
|
backout t a | screen a == BalanceScreen = a
|
|
| otherwise = updateData t $ popLoc a
|
|
|
|
drilldown :: LocalTime -> AppState -> AppState
|
|
drilldown t a =
|
|
case screen a of
|
|
BalanceScreen -> enter t RegisterScreen [currentAccountName a] a
|
|
RegisterScreen -> scrollToTransaction e $ enter t 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 (showPostingWithBalanceForVty False 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
|
|
|
|
-- renderers
|
|
|
|
renderScreen :: AppState -> Picture
|
|
renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
|
|
Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy)
|
|
,pic_image = mainimg
|
|
<->
|
|
renderStatus w msg
|
|
,pic_background = Background ' ' def_attr
|
|
}
|
|
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 = vert_cat (map (string defaultattr) above)
|
|
<->
|
|
string currentlineattr thisline
|
|
<->
|
|
vert_cat (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 = vert_cat $ 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
|
|
|
|
data UITheme = Restrained | Colorful | Blood
|
|
|
|
(defaultattr,
|
|
currentlineattr,
|
|
statusattr
|
|
) = case theme of
|
|
Restrained -> (def_attr
|
|
,def_attr `with_style` bold
|
|
,def_attr `with_style` reverse_video
|
|
)
|
|
Colorful -> (def_attr `with_style` reverse_video
|
|
,def_attr `with_fore_color` white `with_back_color` red
|
|
,def_attr `with_fore_color` black `with_back_color` green
|
|
)
|
|
Blood -> (def_attr `with_style` reverse_video
|
|
,def_attr `with_fore_color` white `with_back_color` red
|
|
,def_attr `with_style` reverse_video
|
|
)
|
|
|
|
halfbrightattr = def_attr `with_style` dim
|
|
reverseattr = def_attr `with_style` reverse_video
|
|
redattr = def_attr `with_fore_color` red
|
|
greenattr = def_attr `with_fore_color` green
|
|
reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red
|
|
reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green
|