diff --git a/Hledger/Vty.hs b/Hledger/Vty.hs new file mode 100644 --- /dev/null +++ b/Hledger/Vty.hs @@ -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 + ] diff --git a/Hledger/Vty/Main.hs b/Hledger/Vty/Main.hs --- a/Hledger/Vty/Main.hs +++ b/Hledger/Vty/Main.hs @@ -1,61 +1,47 @@ -{-# LANGUAGE CPP #-} {-| hledger-vty - a hledger add-on providing a curses-style interface. Copyright (c) 2007-2011 Simon Michael 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 diff --git a/Hledger/Vty/Options.hs b/Hledger/Vty/Options.hs new file mode 100644 --- /dev/null +++ b/Hledger/Vty/Options.hs @@ -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 + diff --git a/hledger-vty.cabal b/hledger-vty.cabal --- a/hledger-vty.cabal +++ b/hledger-vty.cabal @@ -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 diff --git a/hledger-vty.hs b/hledger-vty.hs --- a/hledger-vty.hs +++ b/hledger-vty.hs @@ -1,2 +1,2 @@ #!/usr/bin/env runhaskell -import Hledger.Vty.Main (main) +import Hledger.Vty (main)