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

ui: upgrade to vty 4, fixes non-ascii symbol display (issue #3)

Browse Source
This commit is contained in:
Simon Michael 2009-09-03 14:29:34 +00:00
parent 53e9aec63f
commit 6b2e735ba1
2 changed files with 33 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
Commands/UI.hs
View File

@ -7,7 +7,6 @@ A simple text UI for hledger, based on the vty library.
module Commands.UI module Commands.UI
where where
import Graphics.Vty import Graphics.Vty
import qualified Data.ByteString.Char8 as B
import Ledger import Ledger
import Options import Options
import Commands.Balance import Commands.Balance
@ -22,8 +21,8 @@ instance Show Vty where show = const "a Vty"
-- | The application state when running the ui command. -- | The application state when running the ui command.
data AppState = AppState { data AppState = AppState {
av :: Vty -- ^ the vty context av :: Vty -- ^ the vty context
,aw :: Int -- ^ window width ,aw :: Int -- ^ window width
,ah :: Int -- ^ window height ,ah :: Int -- ^ window height
,amsg :: String -- ^ status message ,amsg :: String -- ^ status message
,aopts :: [Opt] -- ^ command-line opts ,aopts :: [Opt] -- ^ command-line opts
,aargs :: [String] -- ^ command-line args ,aargs :: [String] -- ^ command-line args
@ -51,13 +50,13 @@ data Screen = BalanceScreen -- ^ like hledger balance, shows accounts
ui :: [Opt] -> [String] -> Ledger -> IO () ui :: [Opt] -> [String] -> Ledger -> IO ()
ui opts args l = do ui opts args l = do
v <- mkVty v <- mkVty
(w,h) <- getSize v DisplayBounds w h <- display_bounds $ terminal v
let opts' = SubTotal:opts let opts' = SubTotal:opts
let a = enter BalanceScreen $ let a = enter BalanceScreen $
AppState { AppState {
av=v av=v
,aw=w ,aw=fromIntegral w
,ah=h ,ah=fromIntegral h
,amsg=helpmsg ,amsg=helpmsg
,aopts=opts' ,aopts=opts'
,aargs=args ,aargs=args
@ -71,7 +70,7 @@ ui opts args l = do
go :: AppState -> IO () go :: AppState -> IO ()
go a@AppState{av=av,aw=_,ah=_,abuf=_,amsg=_,aopts=opts,aargs=_,aledger=_} = do go a@AppState{av=av,aw=_,ah=_,abuf=_,amsg=_,aopts=opts,aargs=_,aledger=_} = do
when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a) when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a)
k <- getEvent av k <- next_event av
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 (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg}
@ -300,21 +299,21 @@ entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !
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}) =
pic {pCursor = Cursor cx cy, Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy)
pImage = mainimg ,pic_image = mainimg
<-> <->
renderStatus w msg renderStatus w msg
} ,pic_background = Background ' ' def_attr
}
where where
(cx, cy) = (0, cursorY a) (cx, cy) = (0, cursorY a)
sy = scrollY a sy = scrollY a
-- trying for more speed -- trying for more speed
mainimg = (vertcat $ map (render defaultattr) above) mainimg = (vert_cat $ map (string defaultattr) above)
<-> <->
(render currentlineattr thisline) (string currentlineattr thisline)
<-> <->
(vertcat $ map (render defaultattr) below) (vert_cat $ map (string defaultattr) below)
render attr = renderBS attr . B.pack
(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
@ -339,7 +338,7 @@ padClipString h w s = rows
blankline = replicate w ' ' blankline = replicate w ' '
renderString :: Attr -> String -> Image renderString :: Attr -> String -> Image
renderString attr s = vertcat $ map (renderBS attr . B.pack) rows renderString attr s = vert_cat $ 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
@ -347,7 +346,7 @@ renderString attr s = vertcat $ map (renderBS attr . B.pack) rows
ls = lines s ls = lines s
renderStatus :: Int -> String -> Image renderStatus :: Int -> String -> Image
renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) renderStatus w s = string statusattr (take w (s ++ repeat ' '))
-- the all-important theming engine -- the all-important theming engine
@ -360,25 +359,25 @@ data UITheme = Restrained | Colorful | Blood
currentlineattr, currentlineattr,
statusattr statusattr
) = case theme of ) = case theme of
Restrained -> (attr Restrained -> (def_attr
,setBold attr ,def_attr `with_style` bold
,setRV attr ,def_attr `with_style` reverse_video
) )
Colorful -> (setRV attr Colorful -> (def_attr `with_style` reverse_video
,setFG white $ setBG red $ attr ,def_attr `with_fore_color` white `with_back_color` red
,setFG black $ setBG green $ attr ,def_attr `with_fore_color` black `with_back_color` green
) )
Blood -> (setRV attr Blood -> (def_attr `with_style` reverse_video
,setFG white $ setBG red $ attr ,def_attr `with_fore_color` white `with_back_color` red
,setRV attr ,def_attr `with_style` reverse_video
) )
halfbrightattr = setHalfBright attr halfbrightattr = def_attr `with_style` dim
reverseattr = setRV attr reverseattr = def_attr `with_style` reverse_video
redattr = setFG red attr redattr = def_attr `with_fore_color` red
greenattr = setFG green attr greenattr = def_attr `with_fore_color` green
reverseredattr = setRV $ setFG red attr reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red
reversegreenattr= setRV $ setFG green attr reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green
-- pic { pCursor = Cursor x y, -- pic { pCursor = Cursor x y,
-- pImage = renderFill pieceA ' ' w y -- pImage = renderFill pieceA ' ' w y

2
hledger.cabal
View File

@ -122,7 +122,7 @@ executable hledger
cpp-options: -DVTY cpp-options: -DVTY
other-modules:Commands.UI other-modules:Commands.UI
build-depends: build-depends:
vty >= 3.1.8.2 && < 3.2 vty >= 4.0.0.1 && < 4.1
if flag(happs) if flag(happs)
cpp-options: -DHAPPS cpp-options: -DHAPPS