slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

vty: make hledger-vty buildable again

Browse Source 
Just for fun and curiousity, hledger-vty once again builds, with hledger
HEAD and GHC 7.10, and has a stack config. To see it once again in all
its glory:

$ cd extra/hledger-vty
$ stack install
$ hledger vty [-- ARGS]

[ci skip]
This commit is contained in:
Simon Michael 2015-08-11 19:08:33 -07:00
parent 986896b021
commit 1d957720e3
4 changed files with 103 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
extra/hledger-vty/Hledger/Vty/Main.hs
View File

@ -13,33 +13,33 @@ import Data.Time.Calendar
import Graphics.Vty import Graphics.Vty
import Safe import Safe
import System.Exit import System.Exit
import Text.Printf
import Hledger import Hledger
import Hledger.Cli hiding (progname,progversion) import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.Vty.Options import Hledger.Vty.Options
import Prelude hiding (putStrLn)
import Hledger.Utils.UTF8 (putStrLn)
main :: IO () main :: IO ()
main = do main = do
opts <- getHledgerVtyOpts opts <- getHledgerVtyOpts
when (debug_ $ cliopts_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts) -- when (debug_ $ cliopts_ opts) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
runWith opts runWith opts
runWith :: VtyOpts -> IO () runWith :: VtyOpts -> IO ()
runWith opts = run opts runWith opts = run opts
where where
run opts run opts
| "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp vtymode) >> exitSuccess | "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp vtymode) >> exitSuccess
| "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn progversion >> exitSuccess | "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
| "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname) | "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
| otherwise = withJournalDo' opts vty | otherwise = withJournalDo' opts vty
withJournalDo' :: VtyOpts -> (VtyOpts -> Journal -> IO ()) -> IO () withJournalDo' :: VtyOpts -> (VtyOpts -> Journal -> IO ()) -> IO ()
withJournalDo' opts cmd = do withJournalDo' opts cmd = do
journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>= -- journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=
-- either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts))
-- XXX head should be safe for now
(head `fmap` journalFilePathFromOpts (cliopts_ opts)) >>= readJournalFile Nothing Nothing True >>=
either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts)) 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" helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"
@ -78,17 +78,29 @@ data Screen = BalanceScreen -- ^ like hledger balance, shows accounts
-- | Run the vty (curses-style) ui. -- | Run the vty (curses-style) ui.
vty :: VtyOpts -> Journal -> IO () vty :: VtyOpts -> Journal -> IO ()
vty opts j = do vty opts j = do
v <- mkVty cfg <- standardIOConfig
DisplayRegion w h <- display_bounds $ terminal v v <- mkVty cfg
-- let line0 = string (defAttr ` withForeColor ` green) "first line"
-- line1 = string (defAttr ` withBackColor ` blue) "second line"
-- img = line0 <-> line1
-- pic = picForImage img
-- update vty pic
-- e <- nextEvent vty
-- shutdown vty
-- print ("Last event was: " ++ show e)
Output{displayBounds=getdisplayregion} <- outputForConfig cfg
(w,h) <- getdisplayregion
d <- getCurrentDay d <- getCurrentDay
let a = enter d BalanceScreen (patterns_ $ reportopts_ $ cliopts_ opts) let a = enter d BalanceScreen (words' $ query_ $ reportopts_ $ cliopts_ opts)
AppState { AppState {
av=v av=v
,aw=fromIntegral w ,aw=w
,ah=fromIntegral h ,ah=h
,amsg=helpmsg ,amsg=helpmsg
,aopts=opts ,aopts=opts
,aargs=patterns_ $ reportopts_ $ cliopts_ opts ,aargs=words' $ query_ $ reportopts_ $ cliopts_ opts
,ajournal=j ,ajournal=j
,abuf=[] ,abuf=[]
,alocs=[] ,alocs=[]
@ -99,14 +111,14 @@ vty opts j = do
go :: AppState -> IO () go :: AppState -> IO ()
go a@AppState{av=av,aopts=opts} = do go a@AppState{av=av,aopts=opts} = do
when (not $ debug_vty_ opts) $ update av (renderScreen a) when (not $ debug_vty_ opts) $ update av (renderScreen a)
k <- next_event av k <- nextEvent av
d <- getCurrentDay d <- getCurrentDay
case k of case k of
EvResize x y -> go $ resize x y a EvResize x y -> go $ resize' x y a
EvKey (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg} EvKey (KChar 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg}
EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter d BalanceScreen a EvKey (KChar 'b') [] -> go $ resetTrailAndEnter d BalanceScreen a
EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter d RegisterScreen a EvKey (KChar 'r') [] -> go $ resetTrailAndEnter d RegisterScreen a
EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter d PrintScreen a EvKey (KChar 'p') [] -> go $ resetTrailAndEnter d PrintScreen a
EvKey KRight [] -> go $ drilldown d a EvKey KRight [] -> go $ drilldown d a
EvKey KEnter [] -> go $ drilldown d a EvKey KEnter [] -> go $ drilldown d a
EvKey KLeft [] -> go $ backout d a EvKey KLeft [] -> go $ backout d a
@ -120,10 +132,10 @@ go a@AppState{av=av,aopts=opts} = do
EvKey KDown [MShift] -> go $ moveToBottom a EvKey KDown [MShift] -> go $ moveToBottom a
EvKey KPageUp [] -> go $ prevpage a EvKey KPageUp [] -> go $ prevpage a
EvKey KBS [] -> go $ prevpage a EvKey KBS [] -> go $ prevpage a
EvKey (KASCII ' ') [MShift] -> go $ prevpage a EvKey (KChar ' ') [MShift] -> go $ prevpage a
EvKey KPageDown [] -> go $ nextpage a EvKey KPageDown [] -> go $ nextpage a
EvKey (KASCII ' ') [] -> go $ nextpage a EvKey (KChar ' ') [] -> go $ nextpage a
EvKey (KASCII 'q') [] -> shutdown av >> return () EvKey (KChar 'q') [] -> shutdown av >> return ()
-- EvKey KEsc [] -> shutdown av >> return () -- EvKey KEsc [] -> shutdown av >> return ()
_ -> go a _ -> go a
@ -162,8 +174,8 @@ updateCursorY f a = setCursorY (f $ cursorY a) a
updateScrollY f a = setScrollY (f $ scrollY 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' :: Int -> Int -> AppState -> AppState
resize x y a = setCursorY cy' a{aw=x,ah=y} resize' x y a = setCursorY cy' a{aw=x,ah=y}
where where
cy = cursorY a cy = cursorY a
cy' = min cy (y-2) cy' = min cy (y-2)
@ -255,11 +267,12 @@ resetTrailAndEnter d scr a = enter d scr (aargs a) $ clearLocs a
updateData :: Day -> AppState -> AppState updateData :: Day -> AppState -> AppState
updateData d a@AppState{aopts=opts,ajournal=j} = updateData d a@AppState{aopts=opts,ajournal=j} =
case screen a of case screen a of
BalanceScreen -> a{abuf=accountsReportAsText ropts $ accountsReport ropts fspec j} BalanceScreen -> a{abuf=lines $ balanceReportAsText ropts $ balanceReport ropts q j}
RegisterScreen -> a{abuf=lines $ postingsReportAsText ropts $ postingsReport ropts fspec j} RegisterScreen -> a{abuf=lines $ postingsReportAsText cliopts $ postingsReport ropts q j}
PrintScreen -> a{abuf=lines $ showTransactions ropts fspec j} -- XXX use entriesReport/entriesReportAsText now PrintScreen -> a{abuf=lines $ entriesReportAsText $ entriesReport ropts q j}
where fspec = optsToFilterSpec ropts{patterns_=currentArgs a} d where q = queryFromOpts d ropts{query_=unwords' $ currentArgs a}
ropts = reportopts_ $ cliopts_ opts ropts = reportopts_ cliopts
cliopts = cliopts_ opts
backout :: Day -> AppState -> AppState backout :: Day -> AppState -> AppState
backout d a | screen a == BalanceScreen = a backout d a | screen a == BalanceScreen = a
@ -316,21 +329,26 @@ currentTransaction a@AppState{ajournal=j,abuf=buf} = ptransaction p
where where
p = headDef nullposting $ filter ismatch $ journalPostings j p = headDef nullposting $ filter ismatch $ journalPostings j
ismatch p = postingDate p == parsedate (take 10 datedesc) ismatch p = postingDate p == parsedate (take 10 datedesc)
&& take 70 (showPostingWithBalanceForVty False p nullmixedamt) == (datedesc ++ acctamt) && take 70 (showPostingWithBalanceForVty p nullmixedamt) == (datedesc ++ acctamt)
datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above
acctamt = drop 32 $ headDef "" rest acctamt = drop 32 $ headDef "" rest
(above,rest) = splitAt y buf (above,rest) = splitAt y buf
y = posY a y = posY a
showPostingWithBalanceForVty p b =
postingsReportItemAsText defcliopts $
mkpostingsReportItem False False PrimaryDate Nothing p b
-- renderers -- renderers
renderScreen :: AppState -> Picture renderScreen :: AppState -> Picture
renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) = renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy) Picture {picCursor = Cursor (fromIntegral cx) (fromIntegral cy)
,pic_image = mainimg ,picLayers = [mainimg
<-> <->
renderStatus w msg renderStatus w msg
,pic_background = Background ' ' def_attr ]
,picBackground = Background ' ' defAttr
} }
where where
(cx, cy) = (0, cursorY a) (cx, cy) = (0, cursorY a)
@ -345,11 +363,11 @@ renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
-- | otherwise = splitAt y ls -- | otherwise = splitAt y ls
-- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf -- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf
-- trying for more speed -- trying for more speed
mainimg = vert_cat (map (string defaultattr) above) mainimg = vertCat (map (string defaultattr) above)
<-> <->
string currentlineattr thisline string currentlineattr thisline
<-> <->
vert_cat (map (string defaultattr) below) vertCat (map (string defaultattr) below)
(thisline,below) | null rest = (blankline,[]) (thisline,below) | null rest = (blankline,[])
| otherwise = (head rest, tail rest) | otherwise = (head rest, tail rest)
(above,rest) = splitAt cy linestorender (above,rest) = splitAt cy linestorender
@ -365,7 +383,7 @@ renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
-- blankline = replicate w ' ' -- blankline = replicate w ' '
-- renderString :: Attr -> String -> Image -- renderString :: Attr -> String -> Image
-- renderString attr s = vert_cat $ map (string attr) rows -- renderString attr s = vertCat $ map (string attr) rows
-- where -- where
-- rows = lines $ fitto w h s -- rows = lines $ fitto w h s
-- w = maximum $ map length ls -- w = maximum $ map length ls
@ -385,22 +403,22 @@ data UITheme = Restrained | Colorful | Blood
currentlineattr, currentlineattr,
statusattr statusattr
) = case theme of ) = case theme of
Restrained -> (def_attr Restrained -> (defAttr
,def_attr `with_style` bold ,defAttr `withStyle` bold
,def_attr `with_style` reverse_video ,defAttr `withStyle` reverseVideo
) )
Colorful -> (def_attr `with_style` reverse_video Colorful -> (defAttr `withStyle` reverseVideo
,def_attr `with_fore_color` white `with_back_color` red ,defAttr `withForeColor` white `withBackColor` red
,def_attr `with_fore_color` black `with_back_color` green ,defAttr `withForeColor` black `withBackColor` green
) )
Blood -> (def_attr `with_style` reverse_video Blood -> (defAttr `withStyle` reverseVideo
,def_attr `with_fore_color` white `with_back_color` red ,defAttr `withForeColor` white `withBackColor` red
,def_attr `with_style` reverse_video ,defAttr `withStyle` reverseVideo
) )
-- halfbrightattr = def_attr `with_style` dim -- halfbrightattr = defAttr `withStyle` dim
-- reverseattr = def_attr `with_style` reverse_video -- reverseattr = defAttr `withStyle` reverseVideo
-- redattr = def_attr `with_fore_color` red -- redattr = defAttr `withForeColor` red
-- greenattr = def_attr `with_fore_color` green -- greenattr = defAttr `withForeColor` green
-- reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red -- reverseredattr = defAttr `withStyle` reverseVideo `withForeColor` red
-- reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green -- reversegreenattr= defAttr `withStyle` reverseVideo `withForeColor` green

23
extra/hledger-vty/Hledger/Vty/Options.hs
View File

@ -1,30 +1,37 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-}
{-| {-|
-} -}
module Hledger.Vty.Options module Hledger.Vty.Options
where where
import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion)
import System.Console.CmdArgs import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Explicit
import Hledger.Cli hiding (progname,progversion) import Hledger.Cli hiding (progname,version,prognameandversion)
progname = $(packageVariable (pkgName . package)) progname, version :: String
progversion = progname ++ " " ++ $(packageVariable (pkgVersion . package)) :: String progname = "hledger-vty"
#ifdef VERSION
version = VERSION
#else
version = ""
#endif
prognameandversion :: String
prognameandversion = progname ++ " " ++ version :: String
vtyflags = [ vtyflags = [
flagNone ["debug-vty"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console" flagNone ["debug-vty"] (\opts -> setboolopt "rules-file" opts) "run with no terminal output, showing console"
] ]
--vtymode :: Mode [([Char], [Char])]
vtymode = (mode "hledger-vty" [("command","vty")] vtymode = (mode "hledger-vty" [("command","vty")]
"browse accounts, postings and entries in a full-window curses interface" "browse accounts, postings and entries in a full-window curses interface"
commandargsflag []){ (argsFlag "[PATTERNS]") []){
modeGroupFlags = Group { modeGroupFlags = Group {
groupUnnamed = vtyflags groupUnnamed = vtyflags
,groupHidden = [] ,groupHidden = []
,groupNamed = [(generalflagstitle, generalflags1)] ,groupNamed = [(generalflagsgroup1)]
} }
,modeHelpSuffix=[ ,modeHelpSuffix=[
-- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui." -- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
@ -45,7 +52,7 @@ defvtyopts = VtyOpts
toVtyOpts :: RawOpts -> IO VtyOpts toVtyOpts :: RawOpts -> IO VtyOpts
toVtyOpts rawopts = do toVtyOpts rawopts = do
cliopts <- toCliOpts rawopts cliopts <- rawOptsToCliOpts rawopts
return defvtyopts { return defvtyopts {
debug_vty_ = boolopt "debug-vty" rawopts debug_vty_ = boolopt "debug-vty" rawopts
,cliopts_ = cliopts ,cliopts_ = cliopts

13
extra/hledger-vty/hledger-vty.cabal
View File

@ -1,5 +1,5 @@
name: hledger-vty name: hledger-vty
version: 0.16.1 version: 0.26.98
category: Finance category: Finance
synopsis: A curses-style console interface for the hledger accounting tool. synopsis: A curses-style console interface for the hledger accounting tool.
description: description:
@ -17,7 +17,7 @@ maintainer: Simon Michael <simon@joyful.com>
homepage: http://hledger.org homepage: http://hledger.org
bug-reports: http://code.google.com/p/hledger/issues bug-reports: http://code.google.com/p/hledger/issues
stability: beta stability: beta
tested-with: GHC==6.10, GHC==6.12 tested-with: GHC==7.10
cabal-version: >= 1.6 cabal-version: >= 1.6
build-type: Simple build-type: Simple
-- data-dir: data -- data-dir: data
@ -37,12 +37,11 @@ executable hledger-vty
Hledger.Vty.Main Hledger.Vty.Main
Hledger.Vty.Options Hledger.Vty.Options
build-depends: build-depends:
hledger == 0.16.1 hledger == 0.26.98
,hledger-lib == 0.16.1 ,hledger-lib == 0.26.98
,HUnit ,HUnit
,base >= 3 && < 5 ,base >= 3 && < 5
,cabal-file-th ,cmdargs >= 0.8
,cmdargs == 0.8.*
-- ,containers -- ,containers
-- ,csv -- ,csv
-- ,directory -- ,directory
@ -57,4 +56,4 @@ executable hledger-vty
-- ,split == 0.1.* -- ,split == 0.1.*
,time ,time
-- ,utf8-string >= 0.3.5 && < 0.4 -- ,utf8-string >= 0.3.5 && < 0.4
,vty >= 4.6.0.1 && < 4.8 ,vty >= 5.2 && < 5.3

8
extra/hledger-vty/stack.yaml Normal file
View File

@ -0,0 +1,8 @@
packages:
- '../../hledger-lib'
- '../../hledger'
- '.'
flags:
resolver: nightly-2015-08-03
extra-deps:
- vty-5.2.10