hledger-vty 0.14 → 0.15
raw patch · 5 files changed
+188/−114 lines, 5 filesdep +HUnitdep +cmdargsdep +timedep ~hledgerdep ~hledger-libdep ~vty
Dependencies added: HUnit, cmdargs, time
Dependency ranges changed: hledger, hledger-lib, vty
Files
- Hledger/Vty.hs +21/−0
- Hledger/Vty/Main.hs +90/−104
- Hledger/Vty/Options.hs +60/−0
- hledger-vty.cabal +16/−9
- hledger-vty.hs +1/−1
+ Hledger/Vty.hs view
@@ -0,0 +1,21 @@+{-|+Re-export the modules of the hledger-vty program.+-}++module Hledger.Vty (+ module Hledger.Vty.Main,+ module Hledger.Vty.Options,+ tests_Hledger_Vty+ )+where+import Test.HUnit++import Hledger.Vty.Main+import Hledger.Vty.Options++tests_Hledger_Vty :: Test+tests_Hledger_Vty = TestList+ [+ -- tests_Hledger_Vty_Main+ -- tests_Hledger_Vty_Options+ ]
Hledger/Vty/Main.hs view
@@ -1,61 +1,47 @@-{-# LANGUAGE CPP #-} {-| hledger-vty - a hledger add-on providing a curses-style interface. Copyright (c) 2007-2011 Simon Michael <simon@joyful.com> Released under GPL version 3 or later. -} -module Hledger.Vty.Main where+module Hledger.Vty.Main (main) where +import Control.Monad+import Data.List+import Data.Maybe+import Data.Time.Calendar import Graphics.Vty-import Safe (headDef)-import System.Console.GetOpt+import Safe+import System.Exit+import Text.Printf -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-import Prelude hiding (putStr, putStrLn)-import Hledger.Data.UTF8 (putStr, putStrLn)+import Hledger+import Hledger.Cli hiding (progname,progversion)+import Hledger.Vty.Options+import Prelude hiding (putStrLn)+import Hledger.Utils.UTF8 (putStrLn) -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, args) <- parseArgumentsWith $ options_cli++options_vty- run opts args+ opts <- getHledgerVtyOpts+ when (debug_ $ cliopts_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts)+ runWith opts++runWith :: VtyOpts -> IO ()+runWith opts = run opts 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+ run opts+ | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp vtymode) >> exitSuccess+ | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn progversion >> exitSuccess+ | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)+ | otherwise = withJournalDo' opts vty +withJournalDo' :: VtyOpts -> (VtyOpts -> Journal -> IO ()) -> IO ()+withJournalDo' opts cmd = do+ journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=+ either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))+ 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"@@ -63,10 +49,10 @@ -- | The application state when running the vty command. data AppState = AppState { av :: Vty -- ^ the vty context- ,aw :: Int -- ^ window width- ,ah :: Int -- ^ window height+ ,aw :: Int -- ^ window width+ ,ah :: Int -- ^ window height ,amsg :: String -- ^ status message- ,aopts :: [Opt] -- ^ command-line opts+ ,aopts :: VtyOpts -- ^ command-line opts ,aargs :: [String] -- ^ command-line args at startup ,ajournal :: Journal -- ^ parsed journal ,abuf :: [String] -- ^ lines of the current buffered view@@ -86,24 +72,23 @@ 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+ -- | LedgerScreen -- ^ shows the raw journal entries deriving (Eq,Show) -- | Run the vty (curses-style) ui.-vty :: [Opt] -> [String] -> Journal -> IO ()-vty opts args j = do+vty :: VtyOpts -> Journal -> IO ()+vty opts j = do v <- mkVty DisplayRegion w h <- display_bounds $ terminal v- let opts' = SubTotal:opts- t <- getCurrentLocalTime- let a = enter t BalanceScreen args+ d <- getCurrentDay+ let a = enter d BalanceScreen (patterns_ $ reportopts_ $ cliopts_ opts) AppState { av=v ,aw=fromIntegral w ,ah=fromIntegral h ,amsg=helpmsg- ,aopts=opts'- ,aargs=args+ ,aopts=opts+ ,aargs=patterns_ $ reportopts_ $ cliopts_ opts ,ajournal=j ,abuf=[] ,alocs=[]@@ -113,18 +98,18 @@ -- | 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)+ when (not $ debug_vty_ opts) $ update av (renderScreen a) k <- next_event av- t <- getCurrentLocalTime+ d <- getCurrentDay 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 (KASCII 'b') [] -> go $ resetTrailAndEnter d BalanceScreen a+ EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter d RegisterScreen a+ EvKey (KASCII '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@@ -172,10 +157,10 @@ cy = y `mod` ph sy = y - cy -updateCursorY, updateScrollY, updatePosY :: (Int -> Int) -> AppState -> AppState+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+-- updatePosY f a = setPosY (f $ posY a) a resize :: Int -> Int -> AppState -> AppState resize x y a = setCursorY cy' a{aw=x,ah=y}@@ -243,8 +228,8 @@ clearLocs :: AppState -> AppState clearLocs a = a{alocs=[]} -exit :: AppState -> AppState -exit = popLoc+-- exit :: AppState -> AppState+-- exit = popLoc loc :: AppState -> Loc loc = head . alocs@@ -258,32 +243,33 @@ 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+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 :: LocalTime -> Screen -> AppState -> AppState-resetTrailAndEnter t scr a = enter t scr (aargs a) $ clearLocs 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 :: LocalTime -> AppState -> AppState-updateData t a@AppState{aopts=opts,ajournal=j} =+updateData :: Day -> AppState -> AppState+updateData d 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+ BalanceScreen -> a{abuf=accountsReportAsText ropts $ accountsReport ropts fspec j}+ RegisterScreen -> a{abuf=lines $ postingsReportAsText ropts $ postingsReport ropts fspec j}+ PrintScreen -> a{abuf=lines $ showTransactions ropts fspec j}+ where fspec = optsToFilterSpec ropts{patterns_=currentArgs a} d+ ropts = reportopts_ $ cliopts_ opts -backout :: LocalTime -> AppState -> AppState-backout t a | screen a == BalanceScreen = a- | otherwise = updateData t $ popLoc a+backout :: Day -> AppState -> AppState+backout d a | screen a == BalanceScreen = a+ | otherwise = updateData d $ popLoc a -drilldown :: LocalTime -> AppState -> AppState-drilldown t a =+drilldown :: Day -> AppState -> AppState+drilldown d a = case screen a of- BalanceScreen -> enter t RegisterScreen [currentAccountName a] a- RegisterScreen -> scrollToTransaction e $ enter t PrintScreen (currentArgs a) a+ BalanceScreen -> enter d RegisterScreen [currentAccountName a] a+ RegisterScreen -> scrollToTransaction e $ enter d PrintScreen (currentArgs a) a PrintScreen -> a where e = currentTransaction a @@ -371,20 +357,20 @@ 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 ' '+-- 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+-- 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 ' ')@@ -412,9 +398,9 @@ ,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+-- 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
+ Hledger/Vty/Options.hs view
@@ -0,0 +1,60 @@+{-|++-}++module Hledger.Vty.Options+where+import System.Console.CmdArgs+import System.Console.CmdArgs.Explicit++import Hledger.Cli hiding (progname,progversion)+import qualified Hledger.Cli (progname)++progname = Hledger.Cli.progname ++ "-vty"+progversion = progversionstr progname++vtyflags = [+ flagNone ["debug-vty"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console"+ ]++vtymode = (mode "hledger-vty" [("command","vty")]+ "browse accounts, postings and entries in a full-window curses interface"+ commandargsflag []){+ modeGroupFlags = Group {+ groupUnnamed = vtyflags+ ,groupHidden = []+ ,groupNamed = [(generalflagstitle, generalflags1)]+ }+ ,modeHelpSuffix=[+ -- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."+ ]+ }++-- hledger-vty options, used in hledger-vty and above+data VtyOpts = VtyOpts {+ debug_vty_ :: Bool+ ,cliopts_ :: CliOpts+ } deriving (Show)++defvtyopts = VtyOpts+ def+ def++-- instance Default CliOpts where def = defcliopts++toVtyOpts :: RawOpts -> IO VtyOpts+toVtyOpts rawopts = do+ cliopts <- toCliOpts rawopts+ return defvtyopts {+ debug_vty_ = boolopt "debug-vty" rawopts+ ,cliopts_ = cliopts+ }++checkVtyOpts :: VtyOpts -> IO VtyOpts+checkVtyOpts opts = do+ checkCliOpts $ cliopts_ opts+ return opts++getHledgerVtyOpts :: IO VtyOpts+getHledgerVtyOpts = processArgs vtymode >>= return . decodeRawOpts >>= toVtyOpts >>= checkVtyOpts+
hledger-vty.cabal view
@@ -1,10 +1,14 @@ name: hledger-vty-version: 0.14+version: 0.15 category: Finance-synopsis: A curses-style interface for the hledger accounting tool.+synopsis: A curses-style console interface for the hledger accounting tool. description: - hledger is a haskell port and friendly fork of John Wiegley's ledger accounting tool.- This package provides a simple curses-style console interface as an alternative to the hledger command line interface.+ hledger is a library and set of user tools for working+ with financial data (or anything that can be tracked in a+ double-entry accounting ledger.) It is a haskell port and+ friendly fork of John Wiegley's Ledger. hledger provides+ command-line, curses and web interfaces, and aims to be a+ reliable, practical tool for daily use. license: GPL license-file: LICENSE@@ -29,12 +33,15 @@ main-is: hledger-vty.hs ghc-options: -threaded -W other-modules:+ Hledger.Vty Hledger.Vty.Main+ Hledger.Vty.Options build-depends:- hledger == 0.14- ,hledger-lib == 0.14- -- ,HUnit+ hledger == 0.15+ ,hledger-lib == 0.15+ ,HUnit ,base >= 3 && < 5+ ,cmdargs >= 0.8 && < 0.9 -- ,containers -- ,csv -- ,directory@@ -47,6 +54,6 @@ -- ,regexpr >= 0.5.1 ,safe >= 0.2 -- ,split == 0.1.*- -- ,time+ ,time -- ,utf8-string >= 0.3.5 && < 0.4- ,vty >= 4.6.0.1 && < 4.7+ ,vty >= 4.6.0.1 && < 4.8
hledger-vty.hs view
@@ -1,2 +1,2 @@ #!/usr/bin/env runhaskell-import Hledger.Vty.Main (main)+import Hledger.Vty (main)