simplify: drop the ansi ui, and enable the vty ui by default

If what I'm hearing is correct, cabal on windows will turn off the vty
flag automatically. The alternative ansi ui is not worth the hassle.
This commit is contained in:
Simon Michael 2009-04-03 04:17:48 +00:00
parent 938abfbbfa
commit 3c1d3a6d7f
8 changed files with 14 additions and 403 deletions

View File

@ -1,357 +0,0 @@
{-|
A simple text UI for hledger, based on the ansi-terminal library.
Duplicates most of UICommand.hs for now.
-}
module ANSICommand
where
import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.ByteString.Char8 as B
import System.Console.ANSI
import System.IO
import Ledger
import Options
import BalanceCommand
import RegisterCommand
import PrintCommand
helpmsg = "Welcome to hledger ansi ui. (n)ext, (p)revious, (enter), (b)ack, or (q)uit"
-- | The application state when running the ui command.
data AppState = AppState {
aw :: Int -- ^ window width
,ah :: Int -- ^ window height
,amsg :: String -- ^ status message
,aopts :: [Opt] -- ^ command-line opts
,aargs :: [String] -- ^ command-line args
,aledger :: Ledger -- ^ parsed ledger
,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
} deriving (Show)
-- | The screens available within the user interface.
data Screen = BalanceScreen -- ^ like hledger balance, shows accounts
| RegisterScreen -- ^ like hledger register, shows transactions
| PrintScreen -- ^ like hledger print, shows entries
| LedgerScreen -- ^ shows the raw ledger
deriving (Eq,Show)
-- | Run the interactive text ui.
ansi :: [Opt] -> [String] -> Ledger -> IO ()
ansi opts args l = do
let (w,h) = (80,25)
let opts' = SubTotal:opts
let a = enter BalanceScreen $
AppState {
aw=w
,ah=h
,amsg=helpmsg
,aopts=opts'
,aargs=args
,aledger=l
,abuf=[]
,alocs=[]
}
hSetBuffering stdin NoBuffering
hSetEcho stdin False
go a
-- | Update the screen, wait for the next event, repeat.
go :: AppState -> IO ()
go a@AppState{aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do
when (not $ DebugNoUI `elem` opts) $ updateScreen a
c <- getChar
case c of
-- EvResize x y -> go $ resize x y a
-- EvKey (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg}
-- EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter BalanceScreen a
-- EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter RegisterScreen a
-- EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter PrintScreen a
-- EvKey (KASCII 'l') [] -> go $ resetTrailAndEnter LedgerScreen a
-- EvKey KRight [] -> go $ drilldown a
'\n' -> go $ drilldown a
'b' -> go $ backout a
'p' -> go $ moveUpAndPushEdge a
'n' -> go $ moveDownAndPushEdge a
'<' -> go $ moveToTop a
'>' -> go $ moveToBottom 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 ()
'q' -> resetScreen 0 0
_ -> print c >> go a
where
bh = length buf
y = posY 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 y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l
setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l
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 a = setPosY 0 a
moveToBottom :: AppState -> AppState
moveToBottom a = setPosY (length $ abuf a) a
moveUpAndPushEdge :: AppState -> AppState
moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}
| cy > 0 = updateCursorY (subtract 1) a
| sy > 0 = updateScrollY (subtract 1) a
| otherwise = a
moveDownAndPushEdge :: AppState -> AppState
moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}
| sy+cy >= bh = a
| cy < ph-1 = updateCursorY (+1) a
| otherwise = updateScrollY (+1) a
where
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@AppState{abuf=b})
| 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
screen :: AppState -> Screen
screen a = scr where (Loc scr _ _) = loc a
-- | Enter a new screen, saving the old ui location on the stack.
enter :: Screen -> AppState -> AppState
enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
enter scr@LedgerScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
resetTrailAndEnter scr a = enter scr $ clearLocs a
-- | Regenerate the display data appropriate for the current screen.
updateData :: AppState -> AppState
updateData a@AppState{aopts=opts,aargs=args,aledger=l}
| scr == BalanceScreen = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}
| scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l}
| scr == PrintScreen = a{abuf=lines $ showEntries opts args l}
| scr == LedgerScreen = a{abuf=lines $ rawledgertext l}
where scr = screen a
backout :: AppState -> AppState
backout a
| screen a == BalanceScreen = a
| otherwise = updateData $ popLoc a
drilldown :: AppState -> AppState
drilldown a
| screen a == BalanceScreen = enter RegisterScreen a{aargs=[currentAccountName a]}
| screen a == RegisterScreen = scrollToEntry e $ enter PrintScreen a
| screen a == PrintScreen = enter LedgerScreen a
| screen a == LedgerScreen = a
where e = currentEntry 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.
scrollToEntry :: Entry -> AppState -> AppState
scrollToEntry e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
where
entryfirstline = head $ lines $ showEntry $ e
halfph = pageHeight a `div` 2
y = fromMaybe 0 $ findIndex (== entryfirstline) buf
sy = max 0 $ y - halfph
cy = y - sy
-- | Get the entry containing the transaction currently highlighted by the
-- cursor on the register screen (or best guess). Results undefined while
-- on other screens. Doesn't work.
currentEntry :: AppState -> Entry
currentEntry a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t
where
t = safehead nulltxn $ filter ismatch $ ledgerTransactions l
ismatch t = date t == (parsedate $ take 10 datedesc)
&& (take 70 $ showtxn False t nullmixedamt) == (datedesc ++ acctamt)
datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ [safehead "" rest] ++ reverse above
acctamt = drop 32 $ safehead "" rest
safehead d ls = if null ls then d else head ls
(above,rest) = splitAt y buf
y = posY a
-- | Get the entry which contains the given transaction.
-- Will raise an error if there are problems.
entryContainingTransaction :: AppState -> Transaction -> Entry
entryContainingTransaction AppState{aledger=l} t = (entries $ rawledger l) !! entryno t
-- renderers
renderScreen :: AppState -> String
renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) = maintext ++ renderStatus w msg
where
(cx, cy) = (0, cursorY a)
sy = scrollY a
-- maintext = (vertcat $ map (render defaultattr) above)
-- (render currentlineattr thisline)
-- (vertcat $ map (render defaultattr) below)
-- (thisline,below) | null rest = (blankline,[])
-- | otherwise = (head rest, tail rest)
-- (above,rest) = splitAt cy linestorender
maintext = unlines $ map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
padclipline l = take w $ l ++ blankline
blankline = replicate w ' '
-- 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
-- padClipString :: Int -> Int -> String -> [String]
-- padClipString h w s = rows
-- where
-- rows = map padclipline $ take h $ lines s ++ replicate h blankline
-- padclipline l = take w $ l ++ blankline
-- blankline = replicate w ' '
-- renderString :: Attr -> String -> Image
-- renderString attr s = vertcat $ map (renderBS attr . B.pack) rows
-- where
-- rows = lines $ fitto w h s
-- w = maximum $ map length $ ls
-- h = length ls
-- ls = lines s
renderStatus :: Int -> String -> String
renderStatus w s = {- statusattr -} take w (s ++ repeat ' ')
-- ansi output
updateScreen :: AppState -> IO ()
updateScreen a = putAnsiStr (renderScreen a) 0 (cursorY a)
putAnsiStr :: String -> Int -> Int -> IO ()
putAnsiStr s cx cy = do
resetScreen 0 0
putStr s
setCursorPosition cy cx
hFlush stdout
resetScreen :: Int -> Int -> IO ()
resetScreen cx cy = clearScreen >> setSGR [Reset] >> setCursorPosition cy cx

View File

@ -9,7 +9,7 @@ PATCHES:=$(shell expr `darcs changes --count --from-tag=\\\\\.` - 1)
BUILD=ghc --make hledger.hs -o hledger -O BUILD=ghc --make hledger.hs -o hledger -O
FLAGS=-DPATCHES=$(PATCHES) FLAGS=-DPATCHES=$(PATCHES)
# optional extras described in README, turn em on if you've got the libs # optional extras described in README, turn em on if you've got the libs
OPTFLAGS=-DVTY -DHAPPS # -DANSI OPTFLAGS= #-DVTY -DHAPPS
BUILDFLAGS=$(FLAGS) $(OPTFLAGS) BUILDFLAGS=$(FLAGS) $(OPTFLAGS)
build: setversion build: setversion
@$(BUILD) $(BUILDFLAGS) @$(BUILD) $(BUILDFLAGS)

8
NEWS
View File

@ -1,5 +1,3 @@
NEWS
----
2009/04/03 hledger 0.4 released 2009/04/03 hledger 0.4 released
------------------------------- -------------------------------
@ -7,9 +5,8 @@ NEWS
Changes: Changes:
........ ........
* avoid bulky/non-portable dependencies by default, curses ui now requires a build flag (-f vty) * new "web" command serves reports in a web browser (install with -f happs to build this)
* on MS windows, provide a simple ansi-based ui in place of vty (-f ansi) * make the vty-based curses ui a cabal build option, which will be ignored on MS windows
* new "web" command starts a webserver and shows reports in a browser (-f happs)
* drop the --options-anywhere flag, that is now the default * drop the --options-anywhere flag, that is now the default
* patterns now use not: and desc: prefixes instead of ^ and ^^ * patterns now use not: and desc: prefixes instead of ^ and ^^
* patterns are now case-insensitive, like ledger * patterns are now case-insensitive, like ledger
@ -161,4 +158,3 @@ Stats:
Contributors: Contributors:
* Simon Michael * Simon Michael

View File

@ -31,8 +31,6 @@ usagehdr = printf (
" register - show register transactions\n" ++ " register - show register transactions\n" ++
#ifdef VTY #ifdef VTY
" ui - run a simple curses-based text ui\n" ++ " ui - run a simple curses-based text ui\n" ++
#elif ANSI
" ui - run a simple ansi-based text ui\n" ++
#endif #endif
#ifdef HAPPS #ifdef HAPPS
" web - run a simple web ui\n" ++ " web - run a simple web ui\n" ++

21
README
View File

@ -27,20 +27,9 @@ hledger.cabal from hackage.org, but installing cabal is much quicker.)
Here's how to download and install the latest hledger release:: Here's how to download and install the latest hledger release::
cabal update cabal update
cabal install hledger cabal install hledger (add -f happs to include the web ui)
Or, to build with all optional features enabled (downloads additional Or, to get the latest development code::
dependencies)::
cabal install --flags="happs vty" hledger
The available flags are::
happs - enable the webserver ui
vty - enable the curses text ui
ansi - enable the ansi text ui (use instead of vty on MS windows)
For developers, here's how to get the latest code::
darcs get http://joyful.com/repos/hledger darcs get http://joyful.com/repos/hledger
@ -65,7 +54,7 @@ Here are some commands to try::
hledger register hledger register
hledger reg income hledger reg income
hledger reg desc:shop hledger reg desc:shop
hledger ui # if you installed with -f vty or ansi hledger ui
hledger web # if you installed with -f happs hledger web # if you installed with -f happs
@ -139,8 +128,8 @@ We handle (almost) the full period expression syntax, and very limited
display expressions consisting of a simple date predicate. Also the display expressions consisting of a simple date predicate. Also the
following new commands are supported:: following new commands are supported::
ui a simple curses-based text ui (on windows, ansi-based) ui a simple interactive text ui (only on unix platforms)
web a simple web-based ui web a simple web ui
test run self-tests test run self-tests
ledger features not supported ledger features not supported

View File

@ -39,8 +39,6 @@ versionmsg = progname ++ " " ++ versionstr ++ configmsg ++ "\n"
configflags = tail ["" configflags = tail [""
#ifdef VTY #ifdef VTY
,"vty" ,"vty"
#elif ANSI
,"ansi"
#endif #endif
#ifdef HAPPS #ifdef HAPPS
,"happs" ,"happs"

View File

@ -18,16 +18,12 @@ Extra-Source-Files: README sample.ledger
Extra-Tmp-Files: Extra-Tmp-Files:
Cabal-Version: >= 1.2 Cabal-Version: >= 1.2
Flag happs
description: enable the webserver ui
default: False
Flag vty Flag vty
description: enable the curses test ui description: enable the curses ui
default: False default: True
Flag ansi Flag happs
description: enable the ansi text ui (use instead of vty on MS windows) description: enable the web ui
default: False default: False
Library Library
@ -86,21 +82,16 @@ Executable hledger
cpp-options: -DPATCHES=0 cpp-options: -DPATCHES=0
if flag(vty) if flag(vty)
cpp-options: -DVTY
Build-Depends:vty >= 3.1.8.2 && < 3.2 Build-Depends:vty >= 3.1.8.2 && < 3.2
Other-Modules:UICommand Other-Modules:UICommand
cpp-options: -DVTY
if flag(ansi)
Build-Depends:ansi-terminal >= 0.5 && < 0.6
Other-Modules:ANSICommand
cpp-options: -DANSI
if flag(happs) if flag(happs)
cpp-options: -DHAPPS
Build-Depends:happstack >= 0.2 && < 0.3 Build-Depends:happstack >= 0.2 && < 0.3
,happstack-data >= 0.2 && < 0.3 ,happstack-data >= 0.2 && < 0.3
,happstack-server >= 0.2 && < 0.3 ,happstack-server >= 0.2 && < 0.3
,happstack-state >= 0.2 && < 0.3 ,happstack-state >= 0.2 && < 0.3
,utf8-string >= 0.3 && < 0.4 ,utf8-string >= 0.3 && < 0.4
Other-Modules:WebCommand Other-Modules:WebCommand
cpp-options: -DHAPPS

View File

@ -59,8 +59,6 @@ import PrintCommand
import RegisterCommand import RegisterCommand
#ifdef VTY #ifdef VTY
import UICommand import UICommand
#elif ANSI
import ANSICommand
#endif #endif
#ifdef HAPPS #ifdef HAPPS
import WebCommand import WebCommand
@ -80,8 +78,6 @@ main = do
| cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register
#ifdef VTY #ifdef VTY
| cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui | cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui
#elif ANSI
| cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ansi
#endif #endif
#ifdef HAPPS #ifdef HAPPS
| cmd `isPrefixOf` "web" = parseLedgerAndDo opts args web | cmd `isPrefixOf` "web" = parseLedgerAndDo opts args web