diff --git a/AddCommand.hs b/AddCommand.hs deleted file mode 100644 --- a/AddCommand.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-| - -An add command to help with data entry. - --} - -module AddCommand -where -import Prelude hiding (putStr, putStrLn, getLine, appendFile) -import Ledger -import Options -import RegisterCommand (showRegisterReport) -import System.IO.UTF8 -import System.IO (stderr, hFlush) -import System.IO.Error -import Text.ParserCombinators.Parsec -import Utils (ledgerFromStringWithOpts) - - --- | Read ledger transactions from the terminal, prompting for each field, --- and append them to the ledger file. If the ledger came from stdin, this --- command has no effect. -add :: [Opt] -> [String] -> Ledger -> IO () -add opts args l - | filepath (rawledger l) == "-" = return () - | otherwise = do - hPutStrLn stderr - "Enter one or more transactions, which will be added to your ledger file.\n\ - \To complete a transaction, enter . as account name.\n\ - \To finish input, enter control-d (discards any transaction in progress)." - getAndAddTransactions l args - return () - --- | Read a number of ledger transactions from the command line, --- prompting, validating, displaying and appending them to the ledger --- file, until end of input. -getAndAddTransactions :: Ledger -> [String] -> IO [LedgerTransaction] -getAndAddTransactions l args = do - -- for now, thread the eoi flag throughout rather than muck about with monads - (t, eoi) <- getTransaction l args - l <- if isJust t then addTransaction l (fromJust t) else return l - if eoi then return $ maybe [] (:[]) t - else liftM (fromJust t:) (getAndAddTransactions l args) - --- | Get a transaction from the command line, if possible, and a flag --- indicating end of input. -getTransaction :: Ledger -> [String] -> IO (Maybe LedgerTransaction, Bool) -getTransaction l args = do - today <- getCurrentDay - (datestr, eoi) <- askFor "date" - (Just $ showDate today) - (Just $ \s -> null s || - (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) - if eoi - then return (Nothing, True) - else do - (description, eoi) <- if null args - then askFor "description" Nothing (Just $ not . null) - else (do - let description = unwords args - hPutStrLn stderr $ "description: " ++ description - return (description, False)) - if eoi - then return (Nothing, True) - else do - let historymatches = transactionsSimilarTo l description - when (not $ null historymatches) (do - hPutStrLn stderr "Similar past transactions found:" - hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches) - let bestmatch | null historymatches = Nothing - | otherwise = Just $ snd $ head $ historymatches - bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch - date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr - getpostingsandvalidate = do - (ps, eoi) <- getPostings bestmatchpostings [] - let t = nullledgertxn{ltdate=date - ,ltstatus=False - ,ltdescription=description - ,ltpostings=ps - } - if eoi && null ps - then return (Nothing, eoi) - else either (const retry) (return . flip (,) eoi . Just) $ balanceLedgerTransaction t - retry = do - hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:" - getpostingsandvalidate - getpostingsandvalidate - --- | Get two or more postings from the command line, if possible, and a --- flag indicating end of input. -getPostings :: Maybe [Posting] -> [Posting] -> IO ([Posting], Bool) -getPostings bestmatchps enteredps = do - (account, eoi) <- askFor (printf "account %d" n) defaultaccount validateaccount - if account=="." || eoi - then return (enteredps, eoi) - else do - (amountstr, eoi) <- askFor (printf "amount %d" n) defaultamount validateamount - let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr - let p = nullrawposting{paccount=account,pamount=amount} - if eoi - then if null enteredps - then return ([], True) - else return (enteredps ++ [p], True) - else if amount == missingamt - then return $ (enteredps ++ [p], eoi) - else getPostings bestmatchps $ enteredps ++ [p] - where - n = length enteredps + 1 - bestmatch | isNothing bestmatchps = Nothing - | n <= length ps = Just $ ps !! (n-1) - | otherwise = Nothing - where Just ps = bestmatchps - defaultaccount = maybe Nothing (Just . paccount) bestmatch - validateaccount = Just $ \s -> not $ null s - defaultamount | n==1 = maybe Nothing (Just . show . pamount) bestmatch -- previously used amount - | otherwise = Just $ show $ negate $ sum $ map pamount enteredps -- balancing amount - validateamount = Just $ \s -> - (null s && (not $ null enteredps)) || - (isRight $ parse (someamount>>many spacenonewline>>eof) "" s) - - --- | Prompt for and read a string value and a flag indicating whether --- input has ended (control-d was pressed), optionally with a default --- value and a validator. A validator will cause the prompt to repeat --- until the input is valid (unless the input is just ctrl-d). -askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO (String, Bool) -askFor prompt def validator = do - hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": " - hFlush stderr - -- ugly - l <- getLine `catch` (\e -> if isEOFError e then return "*EOF*" else ioError e) - let (l', eoi) = case l of "*EOF*" -> ("", True) - _ -> (l, False) - let input = if null l' then fromMaybe l' def else l' - case validator of - Just valid -> if valid input || (null input && eoi) - then return (input, eoi) - else askFor prompt def validator - Nothing -> return (input, eoi) - where showdef s = " [" ++ s ++ "]" - --- | Append this transaction to the ledger's file. Also, to the ledger's --- transaction list, but we don't bother updating the other fields - this --- is enough to include new transactions in the history matching. -addTransaction :: Ledger -> LedgerTransaction -> IO Ledger -addTransaction l t = do - appendToLedgerFile l $ show t - putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l) - putStrLn =<< registerFromString (show t) - return l{rawledger=rl{ledger_txns=ts}} - where rl = rawledger l - ts = ledger_txns rl ++ [t] - --- | Append data to the ledger's file, ensuring proper separation from any --- existing data; or if the file is "-", dump it to stdout. -appendToLedgerFile :: Ledger -> String -> IO () -appendToLedgerFile l s = - if f == "-" - then putStr $ sep ++ s - else appendFile f $ sep++s - where - f = filepath $ rawledger l - -- we keep looking at the original raw text from when the ledger - -- was first read, but that's good enough for now - t = rawledgertext l - sep | null $ strip t = "" - | otherwise = replicate (2 - min 2 (length lastnls)) '\n' - where lastnls = takeWhile (=='\n') $ reverse t - --- | Convert a string of ledger data into a register report. -registerFromString :: String -> IO String -registerFromString s = do - now <- getCurrentLocalTime - l <- ledgerFromStringWithOpts [] [] now s - return $ showRegisterReport [Empty] [] l - --- | Return a similarity measure, from 0 to 1, for two strings. --- This is Simon White's letter pairs algorithm from --- http://www.catalysoft.com/articles/StrikeAMatch.html --- with a modification for short strings. -compareStrings :: String -> String -> Float -compareStrings "" "" = 1 -compareStrings (a:[]) "" = 0 -compareStrings "" (b:[]) = 0 -compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0 -compareStrings s1 s2 = 2.0 * (fromIntegral i) / (fromIntegral u) - where - i = length $ intersect pairs1 pairs2 - u = length pairs1 + length pairs2 - pairs1 = wordLetterPairs $ uppercase s1 - pairs2 = wordLetterPairs $ uppercase s2 -wordLetterPairs = concatMap letterPairs . words -letterPairs (a:b:rest) = [a,b]:(letterPairs (b:rest)) -letterPairs _ = [] - -compareLedgerDescriptions s t = compareStrings s' t' - where s' = simplify s - t' = simplify t - simplify = filter (not . (`elem` "0123456789")) - -transactionsSimilarTo :: Ledger -> String -> [(Float,LedgerTransaction)] -transactionsSimilarTo l s = - sortBy compareRelevanceAndRecency - $ filter ((> threshold).fst) - $ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts] - where - compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1) - ts = ledger_txns $ rawledger l - threshold = 0 - -{- doctests - -@ -$ echo "2009/13/1"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a bad date is not accepted -date : date : -@ - -@ -$ echo|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank date is ok -date : description: -@ - -@ -$ printf "\n\n"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank description should fail -date : description: description: -@ - --} diff --git a/BalanceCommand.hs b/BalanceCommand.hs deleted file mode 100644 --- a/BalanceCommand.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-| - -A ledger-compatible @balance@ command. - -ledger's balance command is easy to use but not easy to describe -precisely. In the examples below we'll use sample.ledger, which has the -following account tree: - -@ - assets - bank - checking - saving - cash - expenses - food - supplies - income - gifts - salary - liabilities - debts -@ - -The balance command shows accounts with their aggregate balances. -Subaccounts are displayed indented below their parent. Each balance is the -sum of any transactions in that account plus any balances from -subaccounts: - -@ - $ hledger -f sample.ledger balance - $-1 assets - $1 bank:saving - $-2 cash - $2 expenses - $1 food - $1 supplies - $-2 income - $-1 gifts - $-1 salary - $1 liabilities:debts -@ - -Usually, the non-interesting accounts are elided or omitted. Above, -@checking@ is omitted because it has no subaccounts and a zero balance. -@bank@ is elided because it has only a single displayed subaccount -(@saving@) and it would be showing the same balance as that ($1). Ditto -for @liabilities@. We will return to this in a moment. - -The --depth argument can be used to limit the depth of the balance report. -So, to see just the top level accounts: - -@ -$ hledger -f sample.ledger balance --depth 1 - $-1 assets - $2 expenses - $-2 income - $1 liabilities -@ - -This time liabilities has no displayed subaccounts (due to --depth) and -is not elided. - -With one or more account pattern arguments, the balance command shows -accounts whose name matches one of the patterns, plus their parents -(elided) and subaccounts. So with the pattern o we get: - -@ - $ hledger -f sample.ledger balance o - $1 expenses:food - $-2 income - $-1 gifts - $-1 salary --------------------- - $-1 -@ - -The o pattern matched @food@ and @income@, so they are shown. Unmatched -parents of matched accounts are also shown (elided) for context (@expenses@). - -Also, the balance report shows the total of all displayed accounts, when -that is non-zero. Here, it is displayed because the accounts shown add up -to $-1. - -Here is a more precise definition of \"interesting\" accounts in ledger's -balance report: - -- an account which has just one interesting subaccount branch, and which - is not at the report's maximum depth, is interesting if the balance is - different from the subaccount's, and otherwise boring. - -- any other account is interesting if it has a non-zero balance, or the -E - flag is used. - --} - -module BalanceCommand -where -import Prelude hiding (putStr) -import Ledger.Utils -import Ledger.Types -import Ledger.Amount -import Ledger.AccountName -import Ledger.Transaction -import Ledger.Ledger -import Ledger.Parse -import Options -import Utils -import System.IO.UTF8 - - --- | Print a balance report. -balance :: [Opt] -> [String] -> Ledger -> IO () -balance opts args l = putStr $ showBalanceReport opts args l - --- | Generate a balance report with the specified options for this ledger. -showBalanceReport :: [Opt] -> [String] -> Ledger -> String -showBalanceReport opts args l = acctsstr ++ totalstr - where - acctsstr = unlines $ map showacct interestingaccts - where - showacct = showInterestingAccount l interestingaccts - interestingaccts = filter (isInteresting opts l) acctnames - acctnames = sort $ tail $ flatten $ treemap aname accttree - accttree = ledgerAccountTree (depthFromOpts opts) l - totalstr | NoTotal `elem` opts = "" - | not (Empty `elem` opts) && isZeroMixedAmount total = "" - | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total - where - total = sum $ map abalance $ ledgerTopAccounts l - --- | Display one line of the balance report with appropriate indenting and eliding. -showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String -showInterestingAccount l interestingaccts a = concatTopPadded [amt, " ", depthspacer ++ partialname] - where - amt = padleft 20 $ showMixedAmount $ abalance $ ledgerAccount l a - -- the depth spacer (indent) is two spaces for each interesting parent - parents = parentAccountNames a - interestingparents = filter (`elem` interestingaccts) parents - depthspacer = replicate (2 * length interestingparents) ' ' - -- the partial name is the account's leaf name, prefixed by the - -- names of any boring parents immediately above - partialname = accountNameFromComponents $ (reverse $ map accountLeafName ps) ++ [accountLeafName a] - where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) - --- | Is the named account considered interesting for this ledger's balance report ? -isInteresting :: [Opt] -> Ledger -> AccountName -> Bool -isInteresting opts l a - | numinterestingsubs==1 && not atmaxdepth = notlikesub - | otherwise = notzero || emptyflag - where - atmaxdepth = accountNameLevel a == depthFromOpts opts - emptyflag = Empty `elem` opts - acct = ledgerAccount l a - notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct - notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct - numinterestingsubs = length $ filter isInterestingTree subtrees - where - isInterestingTree t = treeany (isInteresting opts l . aname) t - subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a - diff --git a/Commands/Add.hs b/Commands/Add.hs new file mode 100644 --- /dev/null +++ b/Commands/Add.hs @@ -0,0 +1,211 @@ +{-| + +A history-aware add command to help with data entry. + +-} + +module Commands.Add +where +import Prelude hiding (putStr, putStrLn, getLine, appendFile) +import Ledger +import Options +import Commands.Register (showRegisterReport) +import System.IO.UTF8 +import System.IO (stderr, hFlush) +import System.IO.Error +import Text.ParserCombinators.Parsec +import Utils (ledgerFromStringWithOpts) + + +-- | Read ledger transactions from the terminal, prompting for each field, +-- and append them to the ledger file. If the ledger came from stdin, this +-- command has no effect. +add :: [Opt] -> [String] -> Ledger -> IO () +add _ args l + | filepath (rawledger l) == "-" = return () + | otherwise = do + hPutStrLn stderr + "Enter one or more transactions, which will be added to your ledger file.\n\ + \To complete a transaction, enter . as account name. To quit, enter control-d." + getAndAddTransactions l args `catch` (\e -> if isEOFError e then return () else ioError e) + +-- | Read a number of ledger transactions from the command line, +-- prompting, validating, displaying and appending them to the ledger +-- file, until end of input (then raise an EOF exception). Any +-- command-line arguments are used as the first transaction's description. +getAndAddTransactions :: Ledger -> [String] -> IO () +getAndAddTransactions l args = do + l <- getTransaction l args >>= addTransaction l + getAndAddTransactions l [] + +-- | Read a transaction from the command line, with history-aware prompting. +getTransaction :: Ledger -> [String] -> IO LedgerTransaction +getTransaction l args = do + today <- getCurrentDay + datestr <- askFor "date" + (Just $ showDate today) + (Just $ \s -> null s || + (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) + description <- if null args + then askFor "description" Nothing (Just $ not . null) + else do + let description = unwords args + hPutStrLn stderr $ "description: " ++ description + return description + let historymatches = transactionsSimilarTo l description + bestmatch | null historymatches = Nothing + | otherwise = Just $ snd $ head $ historymatches + bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch + date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr + getpostingsandvalidate = do + ps <- getPostings bestmatchpostings [] + let t = nullledgertxn{ltdate=date + ,ltstatus=False + ,ltdescription=description + ,ltpostings=ps + } + retry = do + hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:" + getpostingsandvalidate + either (const retry) return $ balanceLedgerTransaction t + when (not $ null historymatches) + (do + hPutStrLn stderr "Similar transactions found, using the first for defaults:\n" + hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches) + getpostingsandvalidate + +-- | Read postings from the command line until . is entered, using the +-- provided historical postings, if any, to guess defaults. +getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting] +getPostings historicalps enteredps = do + account <- askFor (printf "account %d" n) defaultaccount (Just $ not . null) + if account=="." + then return enteredps + else do + amountstr <- askFor (printf "amount %d" n) defaultamount validateamount + let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr + let p = nullrawposting{paccount=stripbrackets account, + pamount=amount, + ptype=postingtype account} + getPostings historicalps $ enteredps ++ [p] + where + n = length enteredps + 1 + enteredrealps = filter isReal enteredps + bestmatch | isNothing historicalps = Nothing + | n <= length ps = Just $ ps !! (n-1) + | otherwise = Nothing + where Just ps = historicalps + defaultaccount = maybe Nothing (Just . showacctname) bestmatch + showacctname p = showAccountName Nothing (ptype p) $ paccount p + defaultamount = maybe balancingamount (Just . show . pamount) bestmatch + where balancingamount = Just $ show $ negate $ sum $ map pamount enteredrealps + postingtype ('[':_) = BalancedVirtualPosting + postingtype ('(':_) = VirtualPosting + postingtype _ = RegularPosting + stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse + validateamount = Just $ \s -> (null s && (not $ null enteredrealps)) + || (isRight $ parse (someamount>>many spacenonewline>>eof) "" s) + +-- | Prompt for and read a string value, optionally with a default value +-- and a validator. A validator causes the prompt to repeat until the +-- input is valid. May also raise an EOF exception if control-d is pressed. +askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO String +askFor prompt def validator = do + hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": " + hFlush stderr + l <- getLine + let input = if null l then fromMaybe l def else l + case validator of + Just valid -> if valid input + then return input + else askFor prompt def validator + Nothing -> return input + where showdef s = " [" ++ s ++ "]" + +-- | Append this transaction to the ledger's file. Also, to the ledger's +-- transaction list, but we don't bother updating the other fields - this +-- is enough to include new transactions in the history matching. +addTransaction :: Ledger -> LedgerTransaction -> IO Ledger +addTransaction l t = do + appendToLedgerFile l $ show t + putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l) + putStrLn =<< registerFromString (show t) + return l{rawledger=rl{ledger_txns=ts}} + where rl = rawledger l + ts = ledger_txns rl ++ [t] + +-- | Append data to the ledger's file, ensuring proper separation from any +-- existing data; or if the file is "-", dump it to stdout. +appendToLedgerFile :: Ledger -> String -> IO () +appendToLedgerFile l s = + if f == "-" + then putStr $ sep ++ s + else appendFile f $ sep++s + where + f = filepath $ rawledger l + -- we keep looking at the original raw text from when the ledger + -- was first read, but that's good enough for now + t = rawledgertext l + sep | null $ strip t = "" + | otherwise = replicate (2 - min 2 (length lastnls)) '\n' + where lastnls = takeWhile (=='\n') $ reverse t + +-- | Convert a string of ledger data into a register report. +registerFromString :: String -> IO String +registerFromString s = do + now <- getCurrentLocalTime + l <- ledgerFromStringWithOpts [] [] now s + return $ showRegisterReport [Empty] [] l + +-- | Return a similarity measure, from 0 to 1, for two strings. +-- This is Simon White's letter pairs algorithm from +-- http://www.catalysoft.com/articles/StrikeAMatch.html +-- with a modification for short strings. +compareStrings :: String -> String -> Double +compareStrings "" "" = 1 +compareStrings (_:[]) "" = 0 +compareStrings "" (_:[]) = 0 +compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0 +compareStrings s1 s2 = 2.0 * (fromIntegral i) / (fromIntegral u) + where + i = length $ intersect pairs1 pairs2 + u = length pairs1 + length pairs2 + pairs1 = wordLetterPairs $ uppercase s1 + pairs2 = wordLetterPairs $ uppercase s2 +wordLetterPairs = concatMap letterPairs . words +letterPairs (a:b:rest) = [a,b]:(letterPairs (b:rest)) +letterPairs _ = [] + +compareLedgerDescriptions s t = compareStrings s' t' + where s' = simplify s + t' = simplify t + simplify = filter (not . (`elem` "0123456789")) + +transactionsSimilarTo :: Ledger -> String -> [(Double,LedgerTransaction)] +transactionsSimilarTo l s = + sortBy compareRelevanceAndRecency + $ filter ((> threshold).fst) + $ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts] + where + compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1) + ts = ledger_txns $ rawledger l + threshold = 0 + +{- doctests + +@ +$ echo "2009/13/1"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a bad date is not accepted +date : date : +@ + +@ +$ echo|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank date is ok +date : description: +@ + +@ +$ printf "\n\n"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank description should fail +date : description: description: +@ + +-} diff --git a/Commands/All.hs b/Commands/All.hs new file mode 100644 --- /dev/null +++ b/Commands/All.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -cpp #-} +{-| + +The Commands package defines all the commands offered by the hledger +application, like \"register\" and \"balance\". This module exports all +the commands; you can also import individual modules if you prefer. + +-} + +module Commands.All ( + module Commands.Add, + module Commands.Balance, + module Commands.Convert, + module Commands.Histogram, + module Commands.Print, + module Commands.Register, + module Commands.Stats, +#ifdef VTY + module Commands.UI, +#endif +#ifdef HAPPS + module Commands.Web, +#endif + ) +where +import Commands.Add +import Commands.Balance +import Commands.Convert +import Commands.Histogram +import Commands.Print +import Commands.Register +import Commands.Stats +#ifdef VTY +import Commands.UI +#endif +#ifdef HAPPS +import Commands.Web +#endif diff --git a/Commands/Balance.hs b/Commands/Balance.hs new file mode 100644 --- /dev/null +++ b/Commands/Balance.hs @@ -0,0 +1,159 @@ +{-| + +A ledger-compatible @balance@ command. + +ledger's balance command is easy to use but not easy to describe +precisely. In the examples below we'll use sample.ledger, which has the +following account tree: + +@ + assets + bank + checking + saving + cash + expenses + food + supplies + income + gifts + salary + liabilities + debts +@ + +The balance command shows accounts with their aggregate balances. +Subaccounts are displayed indented below their parent. Each balance is the +sum of any transactions in that account plus any balances from +subaccounts: + +@ + $ hledger -f sample.ledger balance + $-1 assets + $1 bank:saving + $-2 cash + $2 expenses + $1 food + $1 supplies + $-2 income + $-1 gifts + $-1 salary + $1 liabilities:debts +@ + +Usually, the non-interesting accounts are elided or omitted. Above, +@checking@ is omitted because it has no subaccounts and a zero balance. +@bank@ is elided because it has only a single displayed subaccount +(@saving@) and it would be showing the same balance as that ($1). Ditto +for @liabilities@. We will return to this in a moment. + +The --depth argument can be used to limit the depth of the balance report. +So, to see just the top level accounts: + +@ +$ hledger -f sample.ledger balance --depth 1 + $-1 assets + $2 expenses + $-2 income + $1 liabilities +@ + +This time liabilities has no displayed subaccounts (due to --depth) and +is not elided. + +With one or more account pattern arguments, the balance command shows +accounts whose name matches one of the patterns, plus their parents +(elided) and subaccounts. So with the pattern o we get: + +@ + $ hledger -f sample.ledger balance o + $1 expenses:food + $-2 income + $-1 gifts + $-1 salary +-------------------- + $-1 +@ + +The o pattern matched @food@ and @income@, so they are shown. Unmatched +parents of matched accounts are also shown (elided) for context (@expenses@). + +Also, the balance report shows the total of all displayed accounts, when +that is non-zero. Here, it is displayed because the accounts shown add up +to $-1. + +Here is a more precise definition of \"interesting\" accounts in ledger's +balance report: + +- an account which has just one interesting subaccount branch, and which + is not at the report's maximum depth, is interesting if the balance is + different from the subaccount's, and otherwise boring. + +- any other account is interesting if it has a non-zero balance, or the -E + flag is used. + +-} + +module Commands.Balance +where +import Prelude hiding (putStr) +import Ledger.Utils +import Ledger.Types +import Ledger.Amount +import Ledger.AccountName +import Ledger.Transaction +import Ledger.Ledger +import Options +import System.IO.UTF8 + + +-- | Print a balance report. +balance :: [Opt] -> [String] -> Ledger -> IO () +balance opts args l = putStr $ showBalanceReport opts args l + +-- | Generate a balance report with the specified options for this ledger. +showBalanceReport :: [Opt] -> [String] -> Ledger -> String +showBalanceReport opts _ l = acctsstr ++ totalstr + where + acctsstr = unlines $ map showacct interestingaccts + where + showacct = showInterestingAccount l interestingaccts + interestingaccts = filter (isInteresting opts l) acctnames + acctnames = sort $ tail $ flatten $ treemap aname accttree + accttree = ledgerAccountTree (depthFromOpts opts) l + totalstr | NoTotal `elem` opts = "" + | not (Empty `elem` opts) && isZeroMixedAmount total = "" + | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total + where + total = sum $ map abalance $ ledgerTopAccounts l + +-- | Display one line of the balance report with appropriate indenting and eliding. +showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String +showInterestingAccount l interestingaccts a = concatTopPadded [amt, " ", depthspacer ++ partialname] + where + amt = padleft 20 $ showMixedAmount $ abalance $ ledgerAccount l a + -- the depth spacer (indent) is two spaces for each interesting parent + parents = parentAccountNames a + interestingparents = filter (`elem` interestingaccts) parents + depthspacer = replicate (2 * length interestingparents) ' ' + -- the partial name is the account's leaf name, prefixed by the + -- names of any boring parents immediately above + partialname = accountNameFromComponents $ (reverse $ map accountLeafName ps) ++ [accountLeafName a] + where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) + +-- | Is the named account considered interesting for this ledger's balance report ? +isInteresting :: [Opt] -> Ledger -> AccountName -> Bool +isInteresting opts l a + | numinterestingsubs==1 && not atmaxdepth = notlikesub + | otherwise = notzero || emptyflag + where + atmaxdepth = accountNameLevel a == depthFromOpts opts + emptyflag = Empty `elem` opts + acct = ledgerAccount l a + notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct + notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct + numinterestingsubs = length $ filter isInterestingTree subtrees + where + isInterestingTree t = treeany (isInteresting opts l . aname) t + subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a + diff --git a/Commands/Convert.hs b/Commands/Convert.hs new file mode 100644 --- /dev/null +++ b/Commands/Convert.hs @@ -0,0 +1,124 @@ +{-| + +Convert account data in CSV format (eg downloaded from a bank) to ledger +format, and print it on stdout. + +Usage: hledger convert CSVFILE ACCOUNTNAME RULESFILE + +ACCOUNTNAME is the base account to use for transactions. RULESFILE +provides some rules to help convert the data. It should contain paragraphs +separated by one blank line. The first paragraph is a single line of five +comma-separated numbers, which are the csv field positions corresponding +to the ledger transaction's date, status, code, description, and amount. +All other paragraphs specify one or more regular expressions, followed by +the ledger account to use when a transaction's description matches any of +them. A regexp may optionally have a replacement pattern specified after =. +Here's an example rules file: + +> 0,2,3,4,1 +> +> ATM DEPOSIT +> assets:bank:checking +> +> (TO|FROM) SAVINGS +> assets:bank:savings +> +> ITUNES +> BLKBSTR=BLOCKBUSTER +> expenses:entertainment + +Roadmap: +Support for other formats will be added. To update a ledger file, pipe the +output into the import command. The rules will move to a hledger config +file. When no rule matches, accounts will be guessed based on similarity +to descriptions in the current ledger, with interactive prompting and +optional rule saving. + +-} + +module Commands.Convert where +import Data.List.Split (splitOn) +import Options -- (Opt,Debug) +import Ledger.Types (Ledger,AccountName) +import Ledger.Utils (strip) +import System.IO (stderr, hPutStrLn) +import Text.CSV (parseCSVFromFile) +import Text.Printf (printf) +import Text.RegexPR (matchRegexPR) +import Data.Maybe +import Ledger.Dates (firstJust, showDate) +import Locale (defaultTimeLocale) +import Data.Time.Format (parseTime) +import Control.Monad (when) + + +convert :: [Opt] -> [String] -> Ledger -> IO () +convert opts args _ = do + when (length args /= 3) (error "please specify a csv file, base account, and import rules file.") + let [csvfile,baseacct,rulesfile] = args + rulesstr <- readFile rulesfile + (fieldpositions,rules) <- parseRules rulesstr + parse <- parseCSVFromFile csvfile + let records = case parse of + Left e -> error $ show e + Right rs -> reverse rs + mapM_ (print_ledger_txn (Debug `elem` opts) (baseacct,fieldpositions,rules)) records + + +type Rule = ( + [(String, Maybe String)] -- list of patterns and optional replacements + ,AccountName -- account name to use for a matched transaction + ) + +parseRules :: String -> IO ([Int],[Rule]) +parseRules s = do + let ls = map strip $ lines s + let paras = splitOn [""] ls + let fieldpositions = map read $ splitOn "," $ head $ head paras + let rules = [(map parsePatRepl $ init ls, last ls) | ls <- tail paras] + return (fieldpositions,rules) + +parsePatRepl :: String -> (String, Maybe String) +parsePatRepl l = case splitOn "=" l of + (p:r:_) -> (p, Just r) + _ -> (l, Nothing) + +print_ledger_txn :: Bool -> (String,[Int],[Rule]) -> [String] -> IO () +print_ledger_txn debug (baseacct,fieldpositions,rules) record@(_:_:_:_:_:[]) = do + let [date,_,number,description,amount] = map (record !!) fieldpositions + amount' = strnegate amount where strnegate ('-':s) = s + strnegate s = '-':s + unknownacct | (read amount' :: Double) < 0 = "income:unknown" + | otherwise = "expenses:unknown" + (acct,desc) = choose_acct_desc rules (unknownacct,description) + when (debug) $ hPutStrLn stderr $ printf "using %s for %s" desc description + putStrLn $ printf "%s%s %s" (fixdate date) (if not (null number) then printf " (%s)" number else "") desc + putStrLn $ printf " %-30s %15s" acct (printf "$%s" amount' :: String) + putStrLn $ printf " %s\n" baseacct +print_ledger_txn True _ record = do + hPutStrLn stderr $ printf "ignoring %s" $ show record +print_ledger_txn _ _ _ = return () + +choose_acct_desc :: [Rule] -> (String,String) -> (String,String) +choose_acct_desc rules (acct,desc) | null matchingrules = (acct,desc) + | otherwise = (a,d) + where + matchingrules = filter ismatch rules :: [Rule] + where ismatch = any (isJust . flip matchregex desc . fst) . fst + (prs,a) = head matchingrules + mrs = filter (isJust . fst) $ map (\(p,r) -> (matchregex p desc, r)) prs + (m,repl) = head mrs + matched = fst $ fst $ fromJust m + d = fromMaybe matched repl + +matchregex s = matchRegexPR ("(?i)"++s) + +fixdate :: String -> String +fixdate s = maybe "0000/00/00" showDate $ + firstJust + [parseTime defaultTimeLocale "%Y/%m/%d" s + ,parseTime defaultTimeLocale "%Y-%m-%d" s + ,parseTime defaultTimeLocale "%m/%d/%Y" s + ,parseTime defaultTimeLocale "%m-%d-%Y" s + ] + diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs new file mode 100644 --- /dev/null +++ b/Commands/Histogram.hs @@ -0,0 +1,48 @@ +{-| + +Print a histogram report. + +-} + +module Commands.Histogram +where +import Prelude hiding (putStr) +import Ledger +import Options +import System.IO.UTF8 + + +barchar = '*' + +-- | Print a histogram of some statistic per reporting interval, such as +-- number of transactions per day. +histogram :: [Opt] -> [String] -> Ledger -> IO () +histogram opts args l = putStr $ showHistogram opts args l + +showHistogram :: [Opt] -> [String] -> Ledger -> String +showHistogram opts args l = concatMap (printDayWith countBar) daytxns + where + i = intervalFromOpts opts + interval | i == NoInterval = Daily + | otherwise = i + fullspan = rawLedgerDateSpan $ rawledger l + days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan + daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days] + -- same as Register + ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l + filterempties + | Empty `elem` opts = id + | otherwise = filter (not . isZeroMixedAmount . tamount) + matchapats t = matchpats apats $ taccount t + (apats,_) = parsePatternArgs args + filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth) + | otherwise = id + depth = depthFromOpts opts + +printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) + +countBar ts = replicate (length ts) barchar + +total ts = show $ sumTransactions ts + +-- totalBar ts = replicate (sumTransactions ts) barchar diff --git a/Commands/Print.hs b/Commands/Print.hs new file mode 100644 --- /dev/null +++ b/Commands/Print.hs @@ -0,0 +1,27 @@ +{-| + +A ledger-compatible @print@ command. + +-} + +module Commands.Print +where +import Prelude hiding (putStr) +import Ledger +import Options +import System.IO.UTF8 + + +-- | Print ledger transactions in standard format. +print' :: [Opt] -> [String] -> Ledger -> IO () +print' opts args l = putStr $ showLedgerTransactions opts args l + +showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String +showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns + where + filteredtxns = ledger_txns $ + filterRawLedgerPostingsByDepth depth $ + filterRawLedgerTransactionsByAccount apats $ + rawledger l + depth = depthFromOpts opts + (apats,_) = parsePatternArgs args diff --git a/Commands/Register.hs b/Commands/Register.hs new file mode 100644 --- /dev/null +++ b/Commands/Register.hs @@ -0,0 +1,116 @@ +{-| + +A ledger-compatible @register@ command. + +-} + +module Commands.Register +where +import Prelude hiding (putStr) +import Ledger +import Options +import System.IO.UTF8 + + +-- | Print a register report. +register :: [Opt] -> [String] -> Ledger -> IO () +register opts args l = putStr $ showRegisterReport opts args l + +{- | +Generate the register report. Each ledger entry is displayed as two or +more lines like this: + +@ +date (10) description (20) account (22) amount (11) balance (12) +DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA + aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA + ... ... ... +@ +-} +showRegisterReport :: [Opt] -> [String] -> Ledger -> String +showRegisterReport opts args l + | interval == NoInterval = showtxns displayedts nulltxn startbal + | otherwise = showtxns summaryts nulltxn startbal + where + interval = intervalFromOpts opts + ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l + filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth) + | otherwise = id + filterempties + | Empty `elem` opts = id + | otherwise = filter (not . isZeroMixedAmount . tamount) + (precedingts, ts') = break (matchdisplayopt dopt) ts + (displayedts, _) = span (matchdisplayopt dopt) ts' + startbal = sumTransactions precedingts + matchapats t = matchpats apats $ taccount t + (apats,_) = parsePatternArgs args + matchdisplayopt Nothing _ = True + matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t + dopt = displayFromOpts opts + empty = Empty `elem` opts + depth = depthFromOpts opts + summaryts = concatMap summarisespan (zip spans [1..]) + summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s) + transactionsinspan s = filter (isTransactionInDateSpan s) displayedts + spans = splitSpan interval (ledgerDateSpan l) + +-- | Convert a date span (representing a reporting interval) and a list of +-- transactions within it to a new list of transactions aggregated by +-- account, which showtxns will render as a summary for this interval. +-- +-- As usual with date spans the end date is exclusive, but for display +-- purposes we show the previous day as end date, like ledger. +-- +-- A unique tnum value is provided so that the new transactions will be +-- grouped as one entry. +-- +-- When a depth argument is present, transactions to accounts of greater +-- depth are aggregated where possible. +-- +-- The showempty flag forces the display of a zero-transaction span +-- and also zero-transaction accounts within the span. +summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction] +summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts + | null ts && showempty = [txn] + | null ts = [] + | otherwise = summaryts' + where + txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')} + b' = fromMaybe (tdate $ head ts) b + e' = fromMaybe (tdate $ last ts) e + summaryts' + | showempty = summaryts + | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts + txnanames = sort $ nub $ map taccount ts + -- aggregate balances by account, like cacheLedger, then do depth-clipping + (_,_,exclbalof,inclbalof) = groupTransactions ts + clippedanames = clipAccountNames depth txnanames + isclipped a = accountNameLevel a >= depth + balancetoshowfor a = + (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) + summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames] + +clipAccountNames :: Int -> [AccountName] -> [AccountName] +clipAccountNames d as = nub $ map (clip d) as + where clip d = accountNameFromComponents . take d . accountNameComponents + +-- | Show transactions one per line, with each date/description appearing +-- only once, and a running balance. +showtxns [] _ _ = "" +showtxns (t:ts) tprev bal = this ++ showtxns ts t bal' + where + this = showtxn (t `issame` tprev) t bal' + issame t1 t2 = tnum t1 == tnum t2 + bal' = bal + tamount t + +-- | Show one transaction line and balance with or without the entry details. +showtxn :: Bool -> Transaction -> MixedAmount -> String +showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n" + where + entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc + date = showDate $ da + desc = printf "%-20s" $ elideRight 20 de :: String + p = showPosting $ Posting s a amt "" tt + bal = padleft 12 (showMixedAmountOrZero b) + Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t + diff --git a/Commands/Stats.hs b/Commands/Stats.hs new file mode 100644 --- /dev/null +++ b/Commands/Stats.hs @@ -0,0 +1,65 @@ +{-| + +Print some statistics for the ledger. + +-} + +module Commands.Stats +where +import Prelude hiding (putStr) +import Ledger +import Options +import System.IO.UTF8 + + +-- | Print various statistics for the ledger. +stats :: [Opt] -> [String] -> Ledger -> IO () +stats opts args l = do + today <- getCurrentDay + putStr $ showStats opts args l today + +showStats :: [Opt] -> [String] -> Ledger -> Day -> String +showStats _ _ l today = + heading ++ (unlines $ map (\(a,b) -> printf fmt a b) stats) + where + heading = underline $ printf "Ledger statistics as of %s" (show today) + fmt = "%-" ++ (show w1) ++ "s: %-" ++ (show w2) ++ "s" + w1 = maximum $ map (length . fst) stats + w2 = maximum $ map (length . show . snd) stats + stats = [ + ("File", filepath $ rawledger l) + ,("Period", printf "%s to %s (%d days)" (start span) (end span) days) + ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate) + ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30) + ,("Transactions last 7 days", printf "%d (%0.1f per day)" tnum7 txnrate7) + ,("Last transaction", maybe "none" show lastdate ++ + maybe "" (printf " (%d days ago)") lastelapsed) +-- ,("Payees/descriptions", show $ length $ nub $ map ltdescription ts) + ,("Accounts", show $ length $ accounts l) + ,("Commodities", show $ length $ commodities l) + -- Transactions this month : %(monthtxns)s (last month in the same period: %(lastmonthtxns)s) + -- Uncleared transactions : %(uncleared)s + -- Days since reconciliation : %(reconcileelapsed)s + -- Days since last transaction : %(recentelapsed)s + ] + where + ts = sortBy (comparing ltdate) $ ledger_txns $ rawledger l + lastdate | null ts = Nothing + | otherwise = Just $ ltdate $ last ts + lastelapsed = maybe Nothing (Just . diffDays today) lastdate + tnum = length ts + span = rawdatespan l + start (DateSpan (Just d) _) = show d + start _ = "" + end (DateSpan _ (Just d)) = show d + end _ = "" + days = fromMaybe 0 $ daysInSpan span + txnrate | days==0 = 0 + | otherwise = fromIntegral tnum / fromIntegral days :: Double + tnum30 = length $ filter withinlast30 ts + withinlast30 t = (d>=(addDays (-30) today) && (d<=today)) where d = ltdate t + txnrate30 = fromIntegral tnum30 / 30 :: Double + tnum7 = length $ filter withinlast7 ts + withinlast7 t = (d>=(addDays (-7) today) && (d<=today)) where d = ltdate t + txnrate7 = fromIntegral tnum7 / 7 :: Double + diff --git a/Commands/UI.hs b/Commands/UI.hs new file mode 100644 --- /dev/null +++ b/Commands/UI.hs @@ -0,0 +1,391 @@ +{-| + +A simple text UI for hledger, based on the vty library. + +-} + +module Commands.UI +where +import Graphics.Vty +import qualified Data.ByteString.Char8 as B +import Ledger +import Options +import Commands.Balance +import Commands.Register +import Commands.Print + + +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" + +-- | The application state when running the ui command. +data AppState = AppState { + av :: Vty -- ^ the vty context + ,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 transaction-postings + | PrintScreen -- ^ like hledger print, shows ledger transactions + -- | LedgerScreen -- ^ shows the raw ledger + deriving (Eq,Show) + +-- | Run the interactive text ui. +ui :: [Opt] -> [String] -> Ledger -> IO () +ui opts args l = do + v <- mkVty + (w,h) <- getSize v + let opts' = SubTotal:opts + let a = enter BalanceScreen $ + AppState { + av=v + ,aw=w + ,ah=h + ,amsg=helpmsg + ,aopts=opts' + ,aargs=args + ,aledger=l + ,abuf=[] + ,alocs=[] + } + go a + +-- | Update the screen, wait for the next event, repeat. +go :: AppState -> IO () +go a@AppState{av=av,aw=_,ah=_,abuf=_,amsg=_,aopts=opts,aargs=_,aledger=_} = do + when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a) + k <- getEvent av + 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 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 + EvKey KEnter [] -> go $ drilldown a + EvKey KLeft [] -> go $ backout a + EvKey KUp [] -> go $ moveUpAndPushEdge a + EvKey KDown [] -> go $ moveDownAndPushEdge 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 () + _ -> go 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 _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings +setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l + +setScrollY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings +setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l + +setPosY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings +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 + | cy > 0 = updateCursorY (subtract 1) a + | sy > 0 = updateScrollY (subtract 1) a + | otherwise = a + where Loc{sy=sy,cy=cy} = head $ alocs a + +moveDownAndPushEdge :: AppState -> AppState +moveDownAndPushEdge a + | sy+cy >= bh = a + | cy < ph-1 = updateCursorY (+1) a + | otherwise = updateScrollY (+1) a + where + Loc{sy=sy,cy=cy} = head $ alocs a + 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 + | 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} = + case screen a of + BalanceScreen -> a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} + RegisterScreen -> a{abuf=lines $ showRegisterReport opts args l} + PrintScreen -> a{abuf=lines $ showLedgerTransactions opts args l} + -- LedgerScreen -> a{abuf=lines $ rawledgertext l} + +backout :: AppState -> AppState +backout a | screen a == BalanceScreen = a + | otherwise = updateData $ popLoc a + +drilldown :: AppState -> AppState +drilldown a = + case screen a of + BalanceScreen -> enter RegisterScreen a{aargs=[currentAccountName a]} + RegisterScreen -> scrollToLedgerTransaction e $ enter PrintScreen a + PrintScreen -> a + -- LedgerScreen -> a{abuf=lines $ rawledgertext l} + where e = currentLedgerTransaction 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. +scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState +scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a + where + entryfirstline = head $ lines $ showLedgerTransaction $ 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. +currentLedgerTransaction :: AppState -> LedgerTransaction +currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t + where + t = safehead nulltxn $ filter ismatch $ ledgerTransactions l + ismatch t = tdate 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 -> LedgerTransaction +entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !! tnum t + +-- renderers + +renderScreen :: AppState -> Picture +renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) = + pic {pCursor = Cursor cx cy, + pImage = mainimg + <-> + renderStatus w msg + } + where + (cx, cy) = (0, cursorY a) + sy = scrollY a + -- trying for more speed + mainimg = (vertcat $ map (render defaultattr) above) + <-> + (render currentlineattr thisline) + <-> + (vertcat $ map (render defaultattr) below) + render attr = renderBS attr . B.pack + (thisline,below) | null rest = (blankline,[]) + | otherwise = (head rest, tail rest) + (above,rest) = splitAt cy linestorender + linestorender = 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 -> Image +renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) + + +-- the all-important theming engine + +theme = Restrained + +data UITheme = Restrained | Colorful | Blood + +(defaultattr, + currentlineattr, + statusattr + ) = case theme of + Restrained -> (attr + ,setBold attr + ,setRV attr + ) + Colorful -> (setRV attr + ,setFG white $ setBG red $ attr + ,setFG black $ setBG green $ attr + ) + Blood -> (setRV attr + ,setFG white $ setBG red $ attr + ,setRV attr + ) + +halfbrightattr = setHalfBright attr +reverseattr = setRV attr +redattr = setFG red attr +greenattr = setFG green attr +reverseredattr = setRV $ setFG red attr +reversegreenattr= setRV $ setFG green attr + +-- pic { pCursor = Cursor x y, +-- pImage = renderFill pieceA ' ' w y +-- <-> +-- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1) +-- <-> +-- renderFill pieceA ' ' w (h - y - 1) +-- <-> +-- renderStatus w msg +-- } diff --git a/Commands/Web.hs b/Commands/Web.hs new file mode 100644 --- /dev/null +++ b/Commands/Web.hs @@ -0,0 +1,155 @@ +{-| +A happs-based web UI for hledger. +-} + +module Commands.Web +where +import Control.Concurrent +import Happstack.Server +import Happstack.State.Control (waitForTermination) +import System.Cmd (system) +import System.Info (os) +import System.Exit +import Network.HTTP (urlEncode, urlDecode) +import Text.XHtml hiding (dir) + +import Ledger +import Options hiding (value) +import Commands.Balance +import Commands.Register +import Commands.Print +import Commands.Histogram +import Utils (filterAndCacheLedgerWithOpts) + + +tcpport = 5000 + +web :: [Opt] -> [String] -> Ledger -> IO () +web opts args l = do + t <- getCurrentLocalTime -- how to get this per request ? + if Debug `elem` opts + then do + -- just run the server in the foreground + putStrLn $ printf "starting web server on port %d in debug mode" tcpport + simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t + else do + -- start the server (in background, so we can..) then start the web browser + putStrLn $ printf "starting web server on port %d" tcpport + tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t + putStrLn "starting web browser" + openBrowserOn $ printf "http://localhost:%d/" tcpport + waitForTermination + putStrLn "shutting down web server..." + killThread tid + putStrLn "shutdown complete" + +webHandlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response +webHandlers opts args l t = msum + [ + methodSP GET $ view showBalanceReport + ,dir "balance" $ view showBalanceReport + ,dir "register" $ view showRegisterReport + ,dir "print" $ view showLedgerTransactions + ,dir "histogram" $ view showHistogram + ] + where + view f = withDataFn rqdata $ render f + render f (a,p) = renderPage (a,p) $ f opts' args' l' + where + opts' = opts ++ [Period p] + args' = args ++ (map urlDecode $ words a) + -- re-filter the full ledger with the new opts + l' = filterAndCacheLedgerWithOpts opts' args' t (rawledgertext l) (rawledger l) + rqdata = do + a <- look "a" `mplus` return "" -- filter patterns + p <- look "p" `mplus` return "" -- reporting period + return (a,p) + renderPage :: (String, String) -> String -> ServerPartT IO Response + renderPage (a,p) s = do + r <- askRq + return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s + +{- +
+
+   filter by:  +   reporting period:  + %s +
+
+
+ balance + | register + | print + | histogram +
+ 
%s
+-} +hledgerview :: Request -> String -> String -> String -> Html +hledgerview r a p' s = body << topbar r a p' +++ pre << s + +topbar :: Request -> String -> String -> Html +topbar r a p' = concatHtml + [thediv ! [thestyle "float:right; text-align:right;"] << searchform r a p' + ,thediv ! [thestyle "width:100%; font-weight:bold;"] << navlinks r a p'] + +searchform :: Request -> String -> String -> Html +searchform r a p' = + form ! [action u] << concatHtml + [spaceHtml +++ stringToHtml "filter by:" +++ spaceHtml + ,textfield "a" ! [size s, value a] + ,spaceHtml + ,spaceHtml +++ stringToHtml "reporting period:" +++ spaceHtml + ,textfield "p" ! [size s, value p'] + ,resetlink] + where + -- another way to get them + -- a = fromMaybe "" $ queryValue "a" r + -- p = fromMaybe "" $ queryValue "p" r + u = dropWhile (=='/') $ rqUri r + s = "20" + resetlink | null a && null p' = noHtml + | otherwise = spaceHtml +++ anchor ! [href u] << stringToHtml "reset" + +navlinks :: Request -> String -> String -> Html +navlinks _ a p' = + concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"] + where + sep = stringToHtml " | " + linkto s = anchor ! [href (s++q)] << s + q' = intercalate "&" $ + (if null a then [] else [(("a="++).urlEncode) a]) ++ + (if null p' then [] else [(("p="++).urlEncode) p']) + q = if null q' then "" else '?':q' + +-- queryValues :: String -> Request -> [String] +-- queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r + +-- queryValue :: String -> Request -> Maybe String +-- queryValue q r = case filter ((==q).fst) $ rqInputs r of +-- [] -> Nothing +-- is -> Just $ B.unpack $ inputValue $ snd $ head is + +-- | Attempt to open a web browser on the given url, all platforms. +openBrowserOn :: String -> IO ExitCode +openBrowserOn u = trybrowsers browsers u + where + trybrowsers (b:bs) u = do + e <- system $ printf "%s %s" b u + case e of + ExitSuccess -> return ExitSuccess + ExitFailure _ -> trybrowsers bs u + trybrowsers [] u = do + putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers + putStrLn $ printf "Please open your browser and visit %s" u + return $ ExitFailure 127 + browsers | os=="darwin" = ["open"] + | os=="mingw32" = ["start","firefox","safari","opera","iexplore"] + | otherwise = ["sensible-browser","firefox"] + -- jeffz: write a ffi binding for it using the Win32 package as a basis + -- start by adding System/Win32/Shell.hsc and follow the style of any + -- other module in that directory for types, headers, error handling and + -- what not. + -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL); + -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL); + diff --git a/ConvertCommand.hs b/ConvertCommand.hs deleted file mode 100644 --- a/ConvertCommand.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-| - -Convert account data in CSV format (eg downloaded from a bank) to ledger -format, and print it on stdout. - -Usage: hledger convert CSVFILE ACCOUNTNAME RULESFILE - -ACCOUNTNAME is the base account to use for transactions. RULESFILE -provides some rules to help convert the data. It should contain paragraphs -separated by one blank line. The first paragraph is a single line of five -comma-separated numbers, which are the csv field positions corresponding -to the ledger transaction's date, status, code, description, and amount. -All other paragraphs specify one or more regular expressions, followed by -the ledger account to use when a transaction's description matches any of -them. A regexp may optionally have a replacement pattern specified after =. -Here's an example rules file: - -> 0,2,3,4,1 -> -> ATM DEPOSIT -> assets:bank:checking -> -> (TO|FROM) SAVINGS -> assets:bank:savings -> -> ITUNES -> BLKBSTR=BLOCKBUSTER -> expenses:entertainment - -Roadmap: -Support for other formats will be added. To update a ledger file, pipe the -output into the import command. The rules will move to a hledger config -file. When no rule matches, accounts will be guessed based on similarity -to descriptions in the current ledger, with interactive prompting and -optional rule saving. - --} - -module ConvertCommand where -import Data.Maybe (isJust) -import Data.List.Split (splitOn) -import Options -- (Opt,Debug) -import Ledger.Types (Ledger,AccountName) -import Ledger.Utils (strip) -import System (getArgs) -import System.IO (stderr, hPutStrLn) -import Text.CSV (parseCSVFromFile, Record) -import Text.Printf (printf) -import Text.Regex.PCRE ((=~)) -import Data.Maybe -import Ledger.Dates (firstJust, showDate) -import System.Locale (defaultTimeLocale) -import Data.Time.Format (parseTime) -import Control.Monad (when) - - -convert :: [Opt] -> [String] -> Ledger -> IO () -convert opts args l = do - when (length args /= 3) (error "please specify a csv file, base account, and import rules file.") - let [csvfile,baseacct,rulesfile] = args - rulesstr <- readFile rulesfile - (fieldpositions,rules) <- parseRules rulesstr - parse <- parseCSVFromFile csvfile - let records = case parse of - Left e -> error $ show e - Right rs -> reverse rs - mapM_ (print_ledger_txn (Debug `elem` opts) (baseacct,fieldpositions,rules)) records - - -type Rule = ([[String]] -- list of [pattern,replacement]. replacement may or may not be present. - ,AccountName) -- account name to use for a transaction matching this rule - -parseRules :: String -> IO ([Int],[Rule]) -parseRules s = do - let ls = map strip $ lines s - let paras = splitOn [""] ls - let fieldpositions = map read $ splitOn "," $ head $ head paras - let rules = [(map (splitOn "=") $ init p, last p) | p <- tail paras] - return (fieldpositions,rules) - -print_ledger_txn debug (baseacct,fieldpositions,rules) record@(a:b:c:d:e) = do - let [date,cleared,number,description,amount] = map (record !!) fieldpositions - amount' = strnegate amount where strnegate ('-':s) = s - strnegate s = '-':s - unknownacct | (read amount' :: Double) < 0 = "income:unknown" - | otherwise = "expenses:unknown" - (acct,desc) = choose_acct_desc rules (unknownacct,description) - when (debug) $ hPutStrLn stderr $ printf "using %s for %s" desc description - putStrLn $ printf "%s%s %s" (fixdate date) (if not (null number) then printf " (%s)" number else "") desc - putStrLn $ printf " %-30s %15s" acct (printf "$%s" amount' :: String) - putStrLn $ printf " %s\n" baseacct -print_ledger_txn True _ record = do - hPutStrLn stderr $ printf "ignoring %s" $ show record -print_ledger_txn _ _ _ = return () - -choose_acct_desc rules (acct,desc) | null matches = (acct,desc) - | otherwise = (a,d) - where - matches = filter (any (desc =~) . map head . fst) rules - (pats,a) = head matches :: Rule - ((before,match,after,groups),repl) = head $ filter isMatch $ map (\(pat:repl) -> (desc=~pat,repl)) pats - d = head $ repl ++ [match] -- show the replacement text if any, or the matched text - -isMatch :: ((String, String, String, [String]),[String]) -> Bool -isMatch ((_,m,_,_),_) = not $ null m - -fixdate :: String -> String -fixdate s = maybe "0000/00/00" showDate $ - firstJust - [parseTime defaultTimeLocale "%Y/%m/%d" s - ,parseTime defaultTimeLocale "%Y-%m-%d" s - ,parseTime defaultTimeLocale "%m/%d/%Y" s - ,parseTime defaultTimeLocale "%m-%d-%Y" s - ] diff --git a/HistogramCommand.hs b/HistogramCommand.hs deleted file mode 100644 --- a/HistogramCommand.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-| - -Print a histogram report. - --} - -module HistogramCommand -where -import Prelude hiding (putStr) -import qualified Data.Map as Map -import Data.Map ((!)) -import Ledger -import Options -import System.IO.UTF8 - - -barchar = '*' - --- | Print a histogram of some statistic per reporting interval, such as --- number of transactions per day. -histogram :: [Opt] -> [String] -> Ledger -> IO () -histogram opts args l = putStr $ showHistogram opts args l - -showHistogram :: [Opt] -> [String] -> Ledger -> String -showHistogram opts args l = concatMap (printDayWith countBar) daytxns - where - i = intervalFromOpts opts - interval | i == NoInterval = Daily - | otherwise = i - fullspan = rawLedgerDateSpan $ rawledger l - days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan - daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days] - -- same as RegisterCommand - ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l - filterempties - | Empty `elem` opts = id - | otherwise = filter (not . isZeroMixedAmount . tamount) - matchapats t = matchpats apats $ taccount t - (apats,_) = parsePatternArgs args - filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth) - | otherwise = id - depth = depthFromOpts opts - -printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) - -countBar ts = replicate (length ts) barchar - -total ts = show $ sumTransactions ts - --- totalBar ts = replicate (sumTransactions ts) barchar diff --git a/Ledger.hs b/Ledger.hs --- a/Ledger.hs +++ b/Ledger.hs @@ -1,7 +1,8 @@ {-| -The Ledger package allows parsing and querying of ledger files. -It generally provides a compatible subset of C++ ledger's functionality. +The Ledger library allows parsing and querying of ledger files. It +generally provides a compatible subset of C++ ledger's functionality. +This package re-exports all the Ledger.* modules. -} diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs --- a/Ledger/AccountName.hs +++ b/Ledger/AccountName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} {-| 'AccountName's are strings like @assets:cash:petty@. @@ -9,8 +10,11 @@ where import Ledger.Utils import Ledger.Types +import Data.Map (Map) +import qualified Data.Map as M + -- change to use a different separator for nested accounts acctsepchar = ':' @@ -46,29 +50,95 @@ parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a) isAccountNamePrefixOf :: AccountName -> AccountName -> Bool -p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar]) `isPrefixOf` s) +p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar] ) `isPrefixOf` s) isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p = (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) +-- | From a list of account names, select those which are direct +-- subaccounts of the given account name. subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts --- | We could almost get by with just the AccountName manipulations --- above, but we need smarter structures to eg display the account --- tree with boring accounts elided. This converts a list of --- AccountName to a tree (later we will convert that to a tree of --- 'Account'.) +-- | Convert a list of account names to a tree. accountNameTreeFrom :: [AccountName] -> Tree AccountName -accountNameTreeFrom accts = - Node "top" (accountsFrom (topAccountNames accts)) +accountNameTreeFrom = accountNameTreeFrom1 + +accountNameTreeFrom1 accts = + Node "top" (accounttreesfrom (topAccountNames accts)) where - accountsFrom :: [AccountName] -> [Tree AccountName] - accountsFrom [] = [] - accountsFrom as = [Node a (accountsFrom $ subs a) | a <- as] + accounttreesfrom :: [AccountName] -> [Tree AccountName] + accounttreesfrom [] = [] + accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] subs = subAccountNamesFrom (expandAccountNames accts) +accountNameTreeFrom2 accts = + Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts + where + subs = subAccountNamesFrom allaccts + allaccts = expandAccountNames accts + -- subs' a = subsmap ! a + -- subsmap :: Map AccountName [AccountName] + -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts] + +accountNameTreeFrom3 accts = + Node "top" $ forestfrom allaccts $ topAccountNames accts + where + -- drop accts from the list of potential subs as we add them to the tree + forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName + forestfrom subaccts accts = + [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts] + allaccts = expandAccountNames accts + + +-- a more efficient tree builder from Cale Gibbard +newtype Tree' a = T (Map a (Tree' a)) + deriving (Show, Eq, Ord) + +mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +emptyTree = T M.empty + +pathtree :: [a] -> Tree' a +pathtree [] = T M.empty +pathtree (x:xs) = T (M.singleton x (pathtree xs)) + +fromPaths :: (Ord a) => [[a]] -> Tree' a +fromPaths = foldl' mergeTrees emptyTree . map pathtree + +-- the above, but trying to build Tree directly + +-- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a +-- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms') + +-- emptyTree' = Node "top" [] + +-- pathtree' :: [a] -> Tree a +-- pathtree' [] = Node undefined [] +-- pathtree' (x:xs) = Node x [pathtree' xs] + +-- fromPaths' :: (Ord a) => [[a]] -> Tree a +-- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree' + + +-- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName] +-- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m] + +-- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +-- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts) + +converttree :: Tree' AccountName -> [Tree AccountName] +converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m] + +expandTreeNames :: Tree AccountName -> Tree AccountName +expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts) + +accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents + + -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news: -- @@ -95,54 +165,3 @@ | otherwise = done++ss --- | Check if a set of ledger account/description patterns matches the --- given account name or entry description. Patterns are case-insensitive --- regular expression strings; those beginning with - are anti-patterns. -matchpats :: [String] -> String -> Bool -matchpats pats str = - (null positives || any match positives) && (null negatives || not (any match negatives)) - where - (negatives,positives) = partition isnegativepat pats - match "" = True - match pat = matchregex (abspat pat) str - --- | Similar to matchpats, but follows the special behaviour of ledger --- 2.6's balance command: positive patterns which do not contain : match --- the account leaf name, other patterns match the full account name. -matchpats_balance :: [String] -> String -> Bool -matchpats_balance pats str = match_positive_pats pats str && (not $ match_negative_pats pats str) --- (null positives || any match positives) && (null negatives || not (any match negatives)) --- where --- (negatives,positives) = partition isnegativepat pats --- match "" = True --- match pat = matchregex (abspat pat) matchee --- where --- matchee = if not (':' `elem` pat) && not (isnegativepat pat) --- then accountLeafName str --- else str - --- | Do the positives in these patterns permit a match for this string ? -match_positive_pats :: [String] -> String -> Bool -match_positive_pats pats str = (null ps) || (any match ps) - where - ps = positivepats pats - match "" = True - match p = matchregex (abspat p) matchee - where - matchee | ':' `elem` p = str - | otherwise = accountLeafName str - --- | Do the negatives in these patterns prevent a match for this string ? -match_negative_pats :: [String] -> String -> Bool -match_negative_pats pats str = (not $ null ns) && (any match ns) - where - ns = map abspat $ negativepats pats - match "" = True - match p = matchregex (abspat p) str - -negateprefix = "not:" -isnegativepat pat = negateprefix `isPrefixOf` pat -abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat -positivepats = filter (not . isnegativepat) -negativepats = filter isnegativepat -matchregex pat str = null pat || containsRegex (mkRegexWithOpts pat True False) str diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs --- a/Ledger/Amount.hs +++ b/Ledger/Amount.hs @@ -39,7 +39,6 @@ module Ledger.Amount where -import qualified Data.Map as Map import Ledger.Utils import Ledger.Types import Ledger.Commodity @@ -77,13 +76,13 @@ -- any price information. (Using the second commodity is best since sum -- and other folds start with a no-commodity amount.) amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount -amountop op a@(Amount ac aq ap) b@(Amount bc bq bp) = +amountop op a@(Amount _ _ _) (Amount bc bq _) = Amount bc ((quantity $ convertAmountTo bc a) `op` bq) Nothing -- | Convert an amount to the commodity of its saved price, if any. costOfAmount :: Amount -> Amount costOfAmount a@(Amount _ _ Nothing) = a -costOfAmount a@(Amount _ q (Just price)) +costOfAmount (Amount _ q (Just price)) | isZeroMixedAmount price = nullamt | otherwise = Amount pc (pq*q) Nothing where (Amount pc pq _) = head $ amounts price @@ -91,15 +90,16 @@ -- | Convert an amount to the specified commodity using the appropriate -- exchange rate (which is currently always 1). convertAmountTo :: Commodity -> Amount -> Amount -convertAmountTo c2 (Amount c1 q p) = Amount c2 (q * conversionRate c1 c2) Nothing +convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing -- | Get the string representation of an amount, based on its commodity's -- display settings. showAmount :: Amount -> String -showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) q pri) - | sym=="AUTO" = "" -- can display one of these in an error message - | side==L = printf "%s%s%s%s" sym space quantity price - | side==R = printf "%s%s%s%s" quantity space sym price +showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message +showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) = + case side of + L -> printf "%s%s%s%s" sym space quantity price + R -> printf "%s%s%s%s" quantity space sym price where space = if spaced then " " else "" quantity = showAmount' a diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs --- a/Ledger/Commodity.hs +++ b/Ledger/Commodity.hs @@ -8,7 +8,6 @@ -} module Ledger.Commodity where -import qualified Data.Map as Map import Ledger.Utils import Ledger.Types @@ -36,5 +35,5 @@ -- | Find the conversion rate between two commodities. Currently returns 1. conversionRate :: Commodity -> Commodity -> Double -conversionRate oldc newc = 1 +conversionRate _ _ = 1 diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -19,16 +19,9 @@ module Ledger.Dates where -import Data.Time.Clock import Data.Time.Format -import Data.Time.Calendar -import Data.Time.Calendar.MonthDay import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.WeekDate -import Data.Time.LocalTime -import System.Locale (defaultTimeLocale) -import Text.Printf -import Data.Maybe +import Locale (defaultTimeLocale) import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char import Text.ParserCombinators.Parsec.Combinator @@ -49,24 +42,34 @@ -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan] -splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval s = [s] -splitSpan Daily s = splitspan start next s where (start,next) = (startofday,nextday) -splitSpan Weekly s = splitspan start next s where (start,next) = (startofweek,nextweek) -splitSpan Monthly s = splitspan start next s where (start,next) = (startofmonth,nextmonth) -splitSpan Quarterly s = splitspan start next s where (start,next) = (startofquarter,nextquarter) -splitSpan Yearly s = splitspan start next s where (start,next) = (startofyear,nextyear) +splitSpan Daily s = splitspan startofday nextday s +splitSpan Weekly s = splitspan startofweek nextweek s +splitSpan Monthly s = splitspan startofmonth nextmonth s +splitSpan Quarterly s = splitspan startofquarter nextquarter s +splitSpan Yearly s = splitspan startofyear nextyear s +splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] splitspan _ _ (DateSpan Nothing Nothing) = [] -splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)] -splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)] -splitspan startof next s@(DateSpan (Just b) (Just e)) - | b == e = [s] - | otherwise = splitspan' startof next s - where splitspan' startof next (DateSpan (Just b) (Just e)) - | b >= e = [] - | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] - ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e)) +splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)] +splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)] +splitspan start next span@(DateSpan (Just b) (Just e)) + | b == e = [span] + | otherwise = splitspan' start next span + where + splitspan' start next (DateSpan (Just b) (Just e)) + | b >= e = [] + | otherwise = [DateSpan (Just s) (Just n)] + ++ splitspan' start next (DateSpan (Just n) (Just e)) + where s = start b + n = next s + splitspan' _ _ _ = error "won't happen, avoids warnings" + +-- | Count the days in a DateSpan, or if it is open-ended return Nothing. +daysInSpan :: DateSpan -> Maybe Integer +daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 +daysInSpan _ = Nothing -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date. @@ -84,7 +87,7 @@ spanFromSmartDate :: Day -> SmartDate -> DateSpan spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) where - (ry,rm,rd) = toGregorian refdate + (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) span ("","","today") = (refdate, nextday refdate) diff --git a/Ledger/IO.hs b/Ledger/IO.hs --- a/Ledger/IO.hs +++ b/Ledger/IO.hs @@ -5,8 +5,6 @@ module Ledger.IO where import Control.Monad.Error -import Data.Time.Clock -import Data.Time.LocalTime (LocalTime) import Ledger.Ledger (cacheLedger) import Ledger.Parse (parseLedger) import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger) @@ -15,14 +13,13 @@ import System.Directory (getHomeDirectory) import System.Environment (getEnv) import System.IO -import Text.ParserCombinators.Parsec -import qualified Data.Map as Map (lookup) +import System.FilePath (()) -ledgerdefaultpath = "~/.ledger" -timelogdefaultpath = "~/.timelog" -ledgerenvvar = "LEDGER" -timelogenvvar = "TIMELOG" +ledgerenvvar = "LEDGER" +timelogenvvar = "TIMELOG" +ledgerdefaultfilename = ".ledger" +timelogdefaultfilename = ".timelog" -- | A tuple of arguments specifying how to filter a raw ledger file: -- @@ -51,12 +48,18 @@ -- | Get the user's default ledger file path. myLedgerPath :: IO String myLedgerPath = - getEnv ledgerenvvar `catch` \_ -> return ledgerdefaultpath + getEnv ledgerenvvar `catch` + (\_ -> do + home <- getHomeDirectory + return $ home ledgerdefaultfilename) -- | Get the user's default timelog file path. myTimelogPath :: IO String myTimelogPath = - getEnv timelogenvvar `catch` \_ -> return timelogdefaultpath + getEnv timelogenvvar `catch` + (\_ -> do + home <- getHomeDirectory + return $ home timelogdefaultfilename) -- | Read the user's default ledger file, or give an error. myLedger :: IO Ledger @@ -68,13 +71,12 @@ -- | Read a ledger from this file, with no filtering, or give an error. readLedger :: FilePath -> IO Ledger -readLedger f = tildeExpand f >>= readLedgerWithIOArgs noioargs +readLedger = readLedgerWithIOArgs noioargs -- | Read a ledger from this file, filtering according to the io args, -- | or give an error. readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger readLedgerWithIOArgs ioargs f = do - t <- getCurrentLocalTime s <- readFile f rl <- rawLedgerFromString s return $ filterAndCacheLedger ioargs s rl @@ -94,14 +96,14 @@ $ canonicaliseAmounts costbasis rl ){rawledgertext=rawtext} --- | Expand ~ in a file path (does not handle ~name). -tildeExpand :: FilePath -> IO FilePath -tildeExpand ('~':[]) = getHomeDirectory -tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) ---handle ~name, requires -fvia-C or ghc 6.8: ---import System.Posix.User --- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs --- pw <- getUserEntryForName user --- return (homeDirectory pw ++ path) -tildeExpand xs = return xs +-- -- | Expand ~ in a file path (does not handle ~name). +-- tildeExpand :: FilePath -> IO FilePath +-- tildeExpand ('~':[]) = getHomeDirectory +-- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) +-- --handle ~name, requires -fvia-C or ghc 6.8: +-- --import System.Posix.User +-- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs +-- -- pw <- getUserEntryForName user +-- -- return (homeDirectory pw ++ path) +-- tildeExpand xs = return xs diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -57,12 +57,10 @@ import Data.Map ((!)) import Ledger.Utils import Ledger.Types -import Ledger.Amount +import Ledger.Account () import Ledger.AccountName -import Ledger.Account import Ledger.Transaction import Ledger.RawLedger -import Ledger.LedgerTransaction instance Show Ledger where @@ -156,7 +154,7 @@ ledgerSubAccounts l Account{aname=a} = map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l --- | List a ledger's transactions. +-- | List a ledger's "transactions", ie postings with transaction info attached. ledgerTransactions :: Ledger -> [Transaction] ledgerTransactions l = rawLedgerTransactions $ rawledger l @@ -168,7 +166,7 @@ ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l --- | The date span containing all the ledger's (filtered) transactions, +-- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan l @@ -198,6 +196,9 @@ transactions :: Ledger -> [Transaction] transactions = ledgerTransactions + +commodities :: Ledger -> [Commodity] +commodities = nub . rawLedgerCommodities . rawledger accounttree :: Int -> Ledger -> Tree Account accounttree = ledgerAccountTree diff --git a/Ledger/LedgerTransaction.hs b/Ledger/LedgerTransaction.hs --- a/Ledger/LedgerTransaction.hs +++ b/Ledger/LedgerTransaction.hs @@ -57,15 +57,13 @@ showLedgerTransaction' :: Bool -> LedgerTransaction -> String showLedgerTransaction' elide t = - unlines $ [{-precedingcomment ++ -}description] ++ (showpostings $ ltpostings t) ++ [""] + unlines $ [description] ++ (showpostings $ ltpostings t) ++ [""] where - precedingcomment = ltpreceding_comment_lines t description = concat [date, status, code, desc] -- , comment] date = showdate $ ltdate t status = if ltstatus t then " *" else "" code = if (length $ ltcode t) > 0 then (printf " (%s)" $ ltcode t) else "" desc = " " ++ ltdescription t - comment = if (length $ ltcomment t) > 0 then " ; "++(ltcomment t) else "" showdate d = printf "%-10s" (showDate d) showpostings ps | elide && length ps > 1 && isLedgerTransactionBalanced t @@ -74,11 +72,22 @@ where showposting p = showacct p ++ " " ++ (showamount $ pamount p) ++ (showcomment $ pcomment p) showpostingnoamt p = rstrip $ showacct p ++ " " ++ (showcomment $ pcomment p) - showacct p = " " ++ showstatus p ++ (showaccountname $ paccount p) + showacct p = " " ++ showstatus p ++ (printf "%-34s" $ showAccountName (Just 34) (ptype p) (paccount p)) showamount = printf "%12s" . showMixedAmount - showaccountname s = printf "%-34s" s showcomment s = if (length s) > 0 then " ; "++s else "" showstatus p = if pstatus p then "* " else "" + +-- | Show an account name, clipped to the given width if any, and +-- appropriately bracketed/parenthesised for the given posting type. +showAccountName :: Maybe Int -> PostingType -> AccountName -> String +showAccountName w = fmt + where + fmt RegularPosting = take w' + fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse + fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse + w' = fromMaybe 999999 w + parenthesise s = "("++s++")" + bracket s = "["++s++"]" isLedgerTransactionBalanced :: LedgerTransaction -> Bool isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) = diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -7,26 +7,20 @@ module Ledger.Parse where import Prelude hiding (readFile, putStr, print) -import Control.Monad import Control.Monad.Error import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Combinator -import qualified Text.ParserCombinators.Parsec.Token as P import System.Directory import System.IO.UTF8 import System.IO (stdin) -import qualified Data.Map as Map -import Data.Time.LocalTime -import Data.Time.Calendar import Ledger.Utils import Ledger.Types import Ledger.Dates +import Ledger.AccountName (accountNameFromComponents,accountNameComponents) import Ledger.Amount import Ledger.LedgerTransaction -import Ledger.Commodity -import Ledger.TimeLog +import Ledger.Posting import Ledger.RawLedger import System.FilePath(takeDirectory,combine) @@ -109,6 +103,7 @@ "include" -> ledgerInclude "account" -> ledgerAccountBegin "end" -> ledgerAccountEnd + _ -> mzero ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) ledgerInclude = do many1 spacenonewline @@ -289,9 +284,9 @@ many spacenonewline symbol1 <- commoditysymbol many spacenonewline - (Mixed [Amount c price pri]) <- someamount + (Mixed [Amount c q _]) <- someamount restofline - return $ HistoricalPrice date symbol1 (symbol c) price + return $ HistoricalPrice date symbol1 (symbol c) q -- like ledgerAccountBegin, updates the LedgerFileCtx ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) @@ -318,7 +313,7 @@ let t = LedgerTransaction date status code description comment postings "" case balanceLedgerTransaction t of Right t' -> return t' - Left err -> error err + Left err -> fail err ledgerdate :: GenParser Char LedgerFileCtx Day ledgerdate = try ledgerfulldate <|> ledgerpartialdate @@ -336,7 +331,7 @@ (_,m,d) <- md many spacenonewline y <- getYear - when (y==Nothing) $ error "partial date found, but no default year specified" + when (y==Nothing) $ fail "partial date found, but no default year specified" return $ fromGregorian (fromJust y) (read m) (read d) ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime @@ -362,60 +357,39 @@ ledgerpostings = many1 $ try ledgerposting ledgerposting :: GenParser Char LedgerFileCtx Posting -ledgerposting = many1 spacenonewline >> choice [ normalposting, virtualposting, balancedvirtualposting ] - -normalposting :: GenParser Char LedgerFileCtx Posting -normalposting = do +ledgerposting = do + many1 spacenonewline status <- ledgerstatus account <- transactionaccountname - amount <- postingamount - many spacenonewline - comment <- ledgercomment - restofline - parent <- getParentAccount - return (Posting status account amount comment RegularPosting) - -virtualposting :: GenParser Char LedgerFileCtx Posting -virtualposting = do - status <- ledgerstatus - char '(' - account <- transactionaccountname - char ')' - amount <- postingamount - many spacenonewline - comment <- ledgercomment - restofline - parent <- getParentAccount - return (Posting status account amount comment VirtualPosting) - -balancedvirtualposting :: GenParser Char LedgerFileCtx Posting -balancedvirtualposting = do - status <- ledgerstatus - char '[' - account <- transactionaccountname - char ']' + let (ptype, account') = (postingTypeFromAccountName account, unbracket account) amount <- postingamount many spacenonewline comment <- ledgercomment restofline - return (Posting status account amount comment BalancedVirtualPosting) + return (Posting status account' amount comment ptype) -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname --- | account names may have single spaces inside them, and are terminated by two or more spaces +-- | Account names may have single spaces inside them, and are terminated +-- by two or more spaces. They should have one or more components of at +-- least one character, separated by the account separator char. + ledgeraccountname :: GenParser Char st String ledgeraccountname = do - accountname <- many1 (accountnamechar <|> singlespace) - return $ striptrailingspace accountname + a <- many1 (nonspace <|> singlespace) + let a' = striptrailingspace a + when (accountNameFromComponents (accountNameComponents a') /= a') + (fail $ "accountname seems ill-formed: "++a') + return a' where singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) -- couldn't avoid consuming a final space sometimes, harmless striptrailingspace s = if last s == ' ' then init s else s -accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace - "account name character (non-bracket, non-parenthesis, non-whitespace)" +-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace +-- "account name character (non-bracket, non-parenthesis, non-whitespace)" postingamount :: GenParser Char st MixedAmount postingamount = @@ -566,16 +540,16 @@ char '[' (y,m,d) <- smartdate char ']' - let ltdate = parsedate $ printf "%04s/%02s/%02s" y m d - let matcher = \(Transaction{tdate=d}) -> - case op of - "<" -> d < ltdate - "<=" -> d <= ltdate - "=" -> d == ltdate - "==" -> d == ltdate -- just in case - ">=" -> d >= ltdate - ">" -> d > ltdate - return matcher + let date = parsedate $ printf "%04s/%02s/%02s" y m d + test op = return $ (`op` date) . tdate + case op of + "<" -> test (<) + "<=" -> test (<=) + "=" -> test (==) + "==" -> test (==) + ">=" -> test (>=) + ">" -> test (>) + _ -> mzero compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs --- a/Ledger/Posting.hs +++ b/Ledger/Posting.hs @@ -22,14 +22,14 @@ nullrawposting = Posting False "" nullmixedamt "" RegularPosting showPosting :: Posting -> String -showPosting (Posting s a amt _ ttype) = +showPosting (Posting _ a amt _ ttype) = concatTopPadded [showaccountname a ++ " ", showamount amt] where showaccountname = printf "%-22s" . bracket . elideAccountName width (bracket,width) = case ttype of - BalancedVirtualPosting -> (\s -> "["++s++"]", 20) - VirtualPosting -> (\s -> "("++s++")", 20) - otherwise -> (id,22) + BalancedVirtualPosting -> (\s -> "["++s++"]", 20) + VirtualPosting -> (\s -> "("++s++")", 20) + _ -> (id,22) showamount = padleft 12 . showMixedAmountOrZero isReal :: Posting -> Bool @@ -43,3 +43,9 @@ hasAmount :: Posting -> Bool hasAmount = (/= missingamt) . pamount + +postingTypeFromAccountName a + | head a == '[' && last a == ']' = BalancedVirtualPosting + | head a == '(' && last a == ')' = VirtualPosting + | otherwise = RegularPosting + diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -13,7 +13,6 @@ import Ledger.Types import Ledger.AccountName import Ledger.Amount -import Ledger.LedgerTransaction import Ledger.Transaction import Ledger.Posting import Ledger.TimeLog @@ -164,7 +163,7 @@ where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 --- | The date span containing all the raw ledger's transactions, +-- | The (fully specified) date span containing all the raw ledger's transactions, -- or DateSpan Nothing Nothing if there are none. rawLedgerDateSpan :: RawLedger -> DateSpan rawLedgerDateSpan rl @@ -172,3 +171,17 @@ | otherwise = DateSpan (Just $ ltdate $ head ts) (Just $ addDays 1 $ ltdate $ last ts) where ts = sortBy (comparing ltdate) $ ledger_txns rl + +-- | Check if a set of ledger account/description patterns matches the +-- given account name or entry description. Patterns are case-insensitive +-- regular expression strings; those beginning with - are anti-patterns. +matchpats :: [String] -> String -> Bool +matchpats pats str = + (null positives || any match positives) && (null negatives || not (any match negatives)) + where + (negatives,positives) = partition isnegativepat pats + match "" = True + match pat = containsRegex (abspat pat) str + negateprefix = "not:" + isnegativepat pat = negateprefix `isPrefixOf` pat + abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -12,7 +12,6 @@ import Ledger.Types import Ledger.Dates import Ledger.Commodity -import Ledger.Amount import Ledger.LedgerTransaction instance Show TimeLogEntry where @@ -82,7 +81,6 @@ itod = localTimeOfDay itime otod = localTimeOfDay otime idate = localDay itime - odate = localDay otime hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] ps = [Posting False acctname amount "" RegularPosting diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -14,17 +14,17 @@ import Ledger.Utils import Ledger.Types import Ledger.Dates -import Ledger.LedgerTransaction -import Ledger.Posting +import Ledger.LedgerTransaction (showAccountName) import Ledger.Amount instance Show Transaction where show=showTransaction showTransaction :: Transaction -> String -showTransaction (Transaction eno stat d desc a amt ttype) = - s ++ unwords [showDate d,desc,a,show amt,show ttype] +showTransaction (Transaction _ stat d desc a amt ttype) = + s ++ unwords [showDate d,desc,a',show amt,show ttype] where s = if stat then " *" else "" + a' = showAccountName Nothing ttype a -- | Convert a 'LedgerTransaction' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -19,7 +19,7 @@ module Debug.Trace, module Ledger.Utils, module Text.Printf, -module Text.Regex, +module Text.RegexPR, module Test.HUnit, ) where @@ -39,7 +39,7 @@ import System.IO.UTF8 import Test.HUnit import Text.Printf -import Text.Regex +import Text.RegexPR import Text.ParserCombinators.Parsec @@ -63,6 +63,17 @@ True -> take (width - 2) s ++ ".." False -> s +underline :: String -> String +underline s = s' ++ replicate (length s) '-' ++ "\n" + where s' + | last s == '\n' = s + | otherwise = s ++ "\n" + +unbracket :: String -> String +unbracket s + | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s + | otherwise = s + -- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. concatTopPadded :: [String] -> String concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded @@ -136,12 +147,10 @@ -- regexps -instance Show Regex where show r = "a Regex" - -containsRegex :: Regex -> String -> Bool -containsRegex r s = case matchRegex r s of +containsRegex :: String -> String -> Bool +containsRegex r s = case matchRegexPR ("(?i)"++r) s of Just _ -> True - otherwise -> False + _ -> False -- lists @@ -175,7 +184,7 @@ -- | get the sub-tree for the specified node value in the first tree in -- forest in which it occurs. subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) -subtreeinforest v [] = Nothing +subtreeinforest _ [] = Nothing subtreeinforest v (t:ts) = case (subtreeat v t) of Just t' -> Just t' Nothing -> subtreeinforest v ts @@ -204,7 +213,7 @@ -- | show a compact ascii representation of a tree showtree :: Show a => Tree a -> String -showtree = unlines . filter (containsRegex (mkRegex "[^ |]")) . lines . drawTree . treemap show +showtree = unlines . filter (containsRegex "[^ |]") . lines . drawTree . treemap show -- | show a compact ascii representation of a forest showforest :: Show a => Forest a -> String @@ -220,6 +229,9 @@ -- | labelled trace - like strace, with a newline and a label prepended ltrace :: Show a => String -> a -> a ltrace l a = trace (l ++ ": " ++ show a) a + +-- | trace an expression using a custom show function +tracewith f e = trace (f e) e -- parsing diff --git a/Options.hs b/Options.hs --- a/Options.hs +++ b/Options.hs @@ -5,16 +5,9 @@ module Options where -import System import System.Console.GetOpt import System.Environment -import Text.Printf -import Text.RegexPR (gsubRegexPRBy) -import Data.Char (toLower) -import Ledger.IO (IOArgs, - ledgerenvvar,ledgerdefaultpath,myLedgerPath, - timelogenvvar,timelogdefaultpath,myTimelogPath) -import Ledger.Parse +import Ledger.IO (IOArgs,myLedgerPath,myTimelogPath) import Ledger.Utils import Ledger.Types import Ledger.Dates @@ -39,6 +32,7 @@ " histogram - show transaction counts per day or other interval\n" ++ " print - show transactions in ledger format\n" ++ " register - show transactions as a register with running balance\n" ++ + " stats - show various statistics for a ledger\n" ++ #ifdef VTY " ui - run a simple curses-based text ui\n" ++ #endif @@ -83,6 +77,7 @@ ,Option ['h'] ["help"] (NoArg Help) "show this help" ,Option ['V'] ["version"] (NoArg Version) "show version information" ,Option ['v'] ["verbose"] (NoArg Verbose) "show verbose test output" + ,Option [] ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build" ,Option [] ["debug"] (NoArg Debug) "show some debug output" ,Option [] ["debug-no-ui"] (NoArg DebugNoUI) "run ui commands with no output" ] @@ -109,6 +104,7 @@ Help | Verbose | Version + | BinaryFilename | Debug | DebugNoUI deriving (Show,Eq) @@ -174,19 +170,17 @@ -- | Figure out the reporting interval, if any, specified by the options. -- If there is a period option, the others are ignored. intervalFromOpts :: [Opt] -> Interval -intervalFromOpts opts - | not $ null popts = fst $ parsePeriodExpr refdate $ last popts - | null otheropts = NoInterval - | otherwise = case last otheropts of - WeeklyOpt -> Weekly - MonthlyOpt -> Monthly - QuarterlyOpt -> Quarterly - YearlyOpt -> Yearly +intervalFromOpts opts = + case (periodopts, intervalopts) of + ((p:_), _) -> fst $ parsePeriodExpr d p where d = parsedate "0001/01/01" -- unused + (_, (WeeklyOpt:_)) -> Weekly + (_, (MonthlyOpt:_)) -> Monthly + (_, (QuarterlyOpt:_)) -> Quarterly + (_, (YearlyOpt:_)) -> Yearly + (_, _) -> NoInterval where - popts = optValuesForConstructor Period opts - otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts - -- doesn't affect the interval, but parsePeriodExpr needs something - refdate = parsedate "0001/01/01" + periodopts = reverse $ optValuesForConstructor Period opts + intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- | Get the value of the (last) depth option, if any, otherwise a large number. depthFromOpts :: [Opt] -> Int diff --git a/PrintCommand.hs b/PrintCommand.hs deleted file mode 100644 --- a/PrintCommand.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-| - -A ledger-compatible @print@ command. - --} - -module PrintCommand -where -import Prelude hiding (putStr) -import Ledger -import Options -import System.IO.UTF8 - - --- | Print ledger transactions in standard format. -print' :: [Opt] -> [String] -> Ledger -> IO () -print' opts args l = putStr $ showLedgerTransactions opts args l - -showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String -showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns - where - filteredtxns = ledger_txns $ - filterRawLedgerPostingsByDepth depth $ - filterRawLedgerTransactionsByAccount apats $ - rawledger l - depth = depthFromOpts opts - (apats,_) = parsePatternArgs args diff --git a/README b/README --- a/README +++ b/README @@ -1,17 +1,17 @@ +hledger User's Guide +==================== Welcome to hledger! -hledger is a partial haskell clone of John Wiegley's text-based accounting -tool, ledger (http://wiki.github.com/jwiegley/ledger). hledger generates -ledger-compatible register & balance reports from a plain text journal, -allows precise batch-mode or interactive querying, and demonstrates a pure -functional implementation of ledger. For more information, see -http://hledger.org . +hledger is a partial haskell clone of John Wiegley's "ledger" command-line +accounting tool. hledger generates ledger-compatible register & balance +reports from a plain text ledger file, allows precise batch-mode or +interactive querying, and demonstrates a pure functional implementation of +ledger. For more information, see http://hledger.org . -Copyright (c) 2007-2009 Simon Michael +Copyright (c) 2007-2009 Simon Michael and contributors. Released under GPL version 3 or later. - Installation ------------ @@ -40,8 +40,8 @@ hledger [OPTIONS] [COMMAND [PATTERNS]] COMMAND is one of balance, print, register, ui, web, test (defaulting to -balance). PATTERNS are zero or more regular expressions used to narrow the -results. Here are some commands to try:: +balance). PATTERNS are zero or more regular expressions used to filter by +account name or transaction description. Here are some commands to try:: export LEDGER=sample.ledger hledger --help # show usage & options @@ -52,17 +52,16 @@ hledger reg checking # checking transactions hledger reg desc:shop # transactions with shop in the description hledger histogram # transactions per day, or other interval - hledger ui # interactive ui, if installed with -fvty - hledger web # web ui, installed with -fhapps - echo >new; hledger -f new add # input transactions from the command line - + hledger ui # curses ui, if installed with -fvty + hledger web # web ui, if installed with -fhapps + hledger -f new.ledger add # record transactions from the command line Time reporting -------------- -hledger will also read timeclock.el-format timelog entries. As a -convenience, if you invoke hledger via a link or copy named "hours", it -uses your timelog file (~/.timelog or $TIMELOG) by default.:: +hledger will also read timelog files in timeclock.el format. If you +invoke hledger via a symlink or copy named "hours", it looks for your +timelog file (~/.timelog or $TIMELOG) by default.:: hours [OPTIONS] [COMMAND [PATTERNS]] @@ -74,13 +73,13 @@ The clockin description is treated as an account name. Here are some queries to try:: - ln -s `which hledger` ~/bin/hours # add the "hours" symlink in your path + ln -s `which hledger` ~/bin/hours # set up "hours" in your path export TIMELOG=sample.timelog - hours # time logged today, if any - hours -p 'last month' # last month - hours -p thisyear # the space is optional - hours -p 'from 1/15' register proj # project sessions since last jan 15 - hours -p 'weekly this year' reg --depth 1 # weekly time summary + hours # show all time balances + hours -p 'last week' # last week + hours -p thismonth # the space is optional + hours -p 'from 1/15' register project # project sessions since jan 15 + hours -p 'weekly' reg --depth 1 -E # weekly time summary Features -------- @@ -88,8 +87,7 @@ This version of hledger mimics a subset of ledger 3.x, and adds some features of its own. We currently support regular ledger entries, timelog entries, multiple commodities, virtual transactions, account and -description patterns, the LEDGER environment variable, and these commands -and options:: +description filtering, and these commands and options:: Commands: balance [REGEXP]... show balance totals for matching accounts @@ -127,11 +125,12 @@ display expressions consisting of a simple date predicate. Also the following new commands are supported:: - histogram show a (textual) barchart of transaction counts - add input transactions from the command line + histogram show a barchart of transaction counts per interval + add record transactions from the command line convert convert CSV bank data to ledger journal format - ui a simple interactive text ui (only on unix platforms) + ui a simple curses ui (only on unix platforms) web a simple web ui + stats report some ledger statistics test run self-tests ledger features not supported @@ -213,4 +212,4 @@ * hledger register report always sorts transactions by date * hledger doesn't show description comments as part of the description * hledger print puts a blank line after the entry, not before it -* hledger doesn't print the trailing spaces after amount-elided postings +* hledger doesn't print trailing spaces after amount-elided postings diff --git a/RegisterCommand.hs b/RegisterCommand.hs deleted file mode 100644 --- a/RegisterCommand.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-| - -A ledger-compatible @register@ command. - --} - -module RegisterCommand -where -import Prelude hiding (putStr) -import qualified Data.Map as Map -import Data.Map ((!)) -import Ledger -import Options -import System.IO.UTF8 - - --- | Print a register report. -register :: [Opt] -> [String] -> Ledger -> IO () -register opts args l = putStr $ showRegisterReport opts args l - -{- | -Generate the register report. Each ledger entry is displayed as two or -more lines like this: - -@ -date (10) description (20) account (22) amount (11) balance (12) -DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - ... ... ... -@ --} -showRegisterReport :: [Opt] -> [String] -> Ledger -> String -showRegisterReport opts args l - | interval == NoInterval = showtxns displayedts nulltxn startbal - | otherwise = showtxns summaryts nulltxn startbal - where - interval = intervalFromOpts opts - ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l - filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth) - | otherwise = id - filterempties - | Empty `elem` opts = id - | otherwise = filter (not . isZeroMixedAmount . tamount) - (precedingts, ts') = break (matchdisplayopt dopt) ts - (displayedts, _) = span (matchdisplayopt dopt) ts' - startbal = sumTransactions precedingts - matchapats t = matchpats apats $ taccount t - (apats,_) = parsePatternArgs args - matchdisplayopt Nothing t = True - matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t - dopt = displayFromOpts opts - empty = Empty `elem` opts - depth = depthFromOpts opts - summaryts = concatMap summarisespan (zip spans [1..]) - summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s) - transactionsinspan s = filter (isTransactionInDateSpan s) displayedts - spans = splitSpan interval (ledgerDateSpan l) - --- | Convert a date span (representing a reporting interval) and a list of --- transactions within it to a new list of transactions aggregated by --- account, which showtxns will render as a summary for this interval. --- --- As usual with date spans the end date is exclusive, but for display --- purposes we show the previous day as end date, like ledger. --- --- A unique tnum value is provided so that the new transactions will be --- grouped as one entry. --- --- When a depth argument is present, transactions to accounts of greater --- depth are aggregated where possible. --- --- The showempty flag forces the display of a zero-transaction span --- and also zero-transaction accounts within the span. -summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction] -summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts - | null ts && showempty = [txn] - | null ts = [] - | otherwise = summaryts' - where - txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')} - b' = fromMaybe (tdate $ head ts) b - e' = fromMaybe (tdate $ last ts) e - summaryts' - | showempty = summaryts - | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts - txnanames = sort $ nub $ map taccount ts - -- aggregate balances by account, like cacheLedger, then do depth-clipping - (_,_,exclbalof,inclbalof) = groupTransactions ts - clippedanames = clipAccountNames depth txnanames - isclipped a = accountNameLevel a >= depth - balancetoshowfor a = - (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) - summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames] - -clipAccountNames :: Int -> [AccountName] -> [AccountName] -clipAccountNames d as = nub $ map (clip d) as - where clip d = accountNameFromComponents . take d . accountNameComponents - --- | Show transactions one per line, with each date/description appearing --- only once, and a running balance. -showtxns [] _ _ = "" -showtxns (t@Transaction{tamount=a}:ts) tprev bal = this ++ showtxns ts t bal' - where - this = showtxn (t `issame` tprev) t bal' - issame t1 t2 = tnum t1 == tnum t2 - bal' = bal + tamount t - --- | Show one transaction line and balance with or without the entry details. -showtxn :: Bool -> Transaction -> MixedAmount -> String -showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n" - where - entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc - date = showDate $ da - desc = printf "%-20s" $ elideRight 20 de :: String - p = showPosting $ Posting s a amt "" tt - bal = padleft 12 (showMixedAmountOrZero b) - Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t - diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -84,7 +84,9 @@ {- @ $ printf "2009/1/1 a\n b 1.1\n c -1\n" | runhaskell hledger.hs -f- reg 2>&1 ; true -hledger.hs: could not balance this transaction, amounts do not add up to zero: +"-" (line 4, column 1): +unexpected end of input +could not balance this transaction, amounts do not add up to zero: 2009/01/01 a b 1.1 c -1 @@ -92,6 +94,15 @@ @ +@ +$ printf "2009/1/1 x\n (virtual) 100\n a 1\n b\n" | runhaskell hledger.hs -f- print 2>&1 ; true +2009/01/01 x + (virtual) 100 + a 1 + b + +@ + Unicode input/output tests -- layout of the balance command with unicode names @@ -141,6 +152,44 @@ --@ + +@ +$ printf "2009-01-01 x\n a 2\n b (b) b -1\n c\n" | hledger -f - print 2>&1; true +2009/01/01 x + a 2 + b (b) b -1 + c + +@ + +Nafai's bug +@ +$ printf "2009/1/1 x\n a: 13\n b\n" | hledger -f - bal -E 2>&1 +"-" (line 2, column 1): +unexpected " " +accountname seems ill-formed: a: +@ + +Eliding, general layout +@ +$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - bal 2>&1 + €1 aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa + €-1 b +@ + +--@ +$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - reg 2>&1 +2009/01/01 x aa:aa:aaaaaaaaaaaaaaaa €1 €1 + b €-1 0 +@ + +--@ +$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - print 2>&1 +2009/01/01 x + aa:aaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa + b +@ + -} -- other test tools: -- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework @@ -150,24 +199,27 @@ where import qualified Data.Map as Map import Data.Time.Format -import System.Locale (defaultTimeLocale) +import Locale (defaultTimeLocale) import Text.ParserCombinators.Parsec -import Test.HUnit -import Test.HUnit.Tools (assertRaises, runVerboseTests) +import Test.HUnit.Tools (runVerboseTests) +import System.Exit (exitFailure,exitSuccess) + +import Commands.All import Ledger -import Utils import Options -import BalanceCommand -import PrintCommand -import RegisterCommand +import Utils -runtests opts args = runner flattests +runtests opts args = do + (counts,_) <- runner ts + if errors counts > 0 || (failures counts > 0) + then exitFailure + else exitSuccess where runner | (Verbose `elem` opts) = runVerboseTests | otherwise = \t -> runTestTT t >>= return . (flip (,) 0) - flattests = TestList $ filter matchname $ concatMap tflatten tests - deeptests = tfilter matchname $ TestList tests + ts = TestList $ filter matchname $ concatMap tflatten tests + --ts = tfilter matchname $ TestList tests -- unflattened matchname = matchpats args . tname -- | Get a Test's label, or the empty string. @@ -445,6 +497,9 @@ "use the greatest precision" ~: do (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2] + ,"commodities" ~: do + commodities ledger7 `is` [Commodity {symbol="$", side=L, spaced=False, comma=False, precision=2}] + ,"dateSpanFromOpts" ~: do let todaysdate = parsedate "2008/11/26" let opts `gives` spans = show (dateSpanFromOpts todaysdate opts) `is` spans @@ -453,6 +508,13 @@ [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" + -- don't know what this should do + -- ,"elideAccountName" ~: do + -- (elideAccountName 50 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa" + -- `is` "aa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa") + -- (elideAccountName 20 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa" + -- `is` "aa:aa:aaaaaaaaaaaaaa") + ,"entriesFromTimeLogEntries" ~: do today <- getCurrentDay now' <- getCurrentTime @@ -461,7 +523,6 @@ nowstr = showtime now yesterday = prevday today clockin t a = TimeLogEntry In t a - clockout t = TimeLogEntry Out t "" mktime d s = LocalTime d $ fromMaybe midnight $ parseTime defaultTimeLocale "%H:%M:%S" s showtime t = formatTime defaultTimeLocale "%H:%M" t assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es) @@ -561,7 +622,6 @@ return () ,"ledgerFile" ~: do - let now = getCurrentLocalTime assertBool "ledgerFile should parse an empty file" $ (isRight $ parseWithCtx ledgerFile "") r <- rawLedgerFromString "" -- don't know how to get it from ledgerFile assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ ledger_txns r @@ -578,6 +638,12 @@ let t = parseWithCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" assertBool "ledgerTransaction should not include a comment in the description" $ either (const False) ((== "a") . ltdescription) t + + ,"ledgeraccountname" ~: do + assertBool "ledgeraccountname parses a normal accountname" $ (isRight $ parsewith ledgeraccountname "a:b:c") + assertBool "ledgeraccountname rejects an empty inner component" $ (isLeft $ parsewith ledgeraccountname "a::c") + assertBool "ledgeraccountname rejects an empty leading component" $ (isLeft $ parsewith ledgeraccountname ":b:c") + assertBool "ledgeraccountname rejects an empty trailing component" $ (isLeft $ parsewith ledgeraccountname "a:b:") ,"ledgerposting" ~: do parseWithCtx ledgerposting rawposting1_str `parseis` rawposting1 diff --git a/UICommand.hs b/UICommand.hs deleted file mode 100644 --- a/UICommand.hs +++ /dev/null @@ -1,391 +0,0 @@ -{-| - -A simple text UI for hledger, based on the vty library. - --} - -module UICommand -where -import qualified Data.Map as Map -import Data.Map ((!)) -import Graphics.Vty -import qualified Data.ByteString.Char8 as B -import Ledger -import Options -import BalanceCommand -import RegisterCommand -import PrintCommand - - -helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit" - -instance Show Vty where show v = "a Vty" - --- | The application state when running the ui command. -data AppState = AppState { - av :: Vty -- ^ the vty context - ,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 transaction-postings - | PrintScreen -- ^ like hledger print, shows ledger transactions - | LedgerScreen -- ^ shows the raw ledger - deriving (Eq,Show) - --- | Run the interactive text ui. -ui :: [Opt] -> [String] -> Ledger -> IO () -ui opts args l = do - v <- mkVty - (w,h) <- getSize v - let opts' = SubTotal:opts - let a = enter BalanceScreen $ - AppState { - av=v - ,aw=w - ,ah=h - ,amsg=helpmsg - ,aopts=opts' - ,aargs=args - ,aledger=l - ,abuf=[] - ,alocs=[] - } - go a - --- | Update the screen, wait for the next event, repeat. -go :: AppState -> IO () -go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do - when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a) - k <- getEvent av - 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 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 - EvKey KEnter [] -> go $ drilldown a - EvKey KLeft [] -> go $ backout a - EvKey KUp [] -> go $ moveUpAndPushEdge a - EvKey KDown [] -> go $ moveDownAndPushEdge 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 () - _ -> 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 $ showLedgerTransactions 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 = scrollToLedgerTransaction e $ enter PrintScreen a - | screen a == PrintScreen = a - -- screen a == PrintScreen = enter LedgerScreen a - -- screen a == LedgerScreen = a - where e = currentLedgerTransaction 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. -scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState -scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a - where - entryfirstline = head $ lines $ showLedgerTransaction $ 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. -currentLedgerTransaction :: AppState -> LedgerTransaction -currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t - where - t = safehead nulltxn $ filter ismatch $ ledgerTransactions l - ismatch t = tdate 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 -> LedgerTransaction -entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !! tnum t - --- renderers - -renderScreen :: AppState -> Picture -renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) = - pic {pCursor = Cursor cx cy, - pImage = mainimg - <-> - renderStatus w msg - } - where - (cx, cy) = (0, cursorY a) - sy = scrollY a - -- trying for more speed - mainimg = (vertcat $ map (render defaultattr) above) - <-> - (render currentlineattr thisline) - <-> - (vertcat $ map (render defaultattr) below) - render attr = renderBS attr . B.pack - (thisline,below) | null rest = (blankline,[]) - | otherwise = (head rest, tail rest) - (above,rest) = splitAt cy linestorender - linestorender = 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 -> Image -renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) - - --- the all-important theming engine - -theme = 1 - -(defaultattr, - currentlineattr, - statusattr - ) = - case theme of - 1 -> ( -- restrained - attr - ,setBold attr - ,setRV attr - ) - 2 -> ( -- colorful - setRV attr - ,setFG white $ setBG red $ attr - ,setFG black $ setBG green $ attr - ) - 3 -> ( -- - setRV attr - ,setFG white $ setBG red $ attr - ,setRV attr - ) - -halfbrightattr = setHalfBright attr -reverseattr = setRV attr -redattr = setFG red attr -greenattr = setFG green attr -reverseredattr = setRV $ setFG red attr -reversegreenattr= setRV $ setFG green attr - --- pic { pCursor = Cursor x y, --- pImage = renderFill pieceA ' ' w y --- <-> --- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1) --- <-> --- renderFill pieceA ' ' w (h - y - 1) --- <-> --- renderStatus w msg --- } diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -8,13 +8,10 @@ module Utils where import Control.Monad.Error -import Data.Time.Clock import Ledger import Options (Opt,ledgerFilePathFromOpts,optsToIOArgs) import System.Directory (doesFileExist) import System.IO -import Text.ParserCombinators.Parsec -import qualified Data.Map as Map (lookup) -- | Parse the user's specified ledger file and run a hledger command on diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -1,29 +1,60 @@ {-# OPTIONS_GHC -cpp #-} +{- +Version-related utilities. + +We should follow http://haskell.org/haskellwiki/Package_versioning_policy . +But currently hledger's version is MAJOR[.MINOR[.BUGFIX]][+PATCHLEVEL]. +See also the Makefile. + +-} + module Version where +import System.Info (os, arch) import Ledger.Utils import Options (progname) --- updated by build process from VERSION -version = "0.5.1" -#ifdef PATCHES --- a "make" development build defines PATCHES from the repo state -patchlevel = "." ++ show PATCHES -- must be numeric ! +-- version and PATCHLEVEL are set by the makefile +version = "0.6.0" + +#ifdef PATCHLEVEL +patchlevel = "." ++ show PATCHLEVEL -- must be numeric ! #else patchlevel = "" #endif -buildversion = version ++ patchlevel -versionstr = prettify $ splitAtElement '.' buildversion +buildversion = version ++ patchlevel :: String + +binaryfilename = prettify $ splitAtElement '.' buildversion :: String where prettify (major:minor:bugfix:patches:[]) = + printf "hledger-%s.%s%s%s-%s-%s" major minor bugfix' patches' os' arch + where + bugfix' + | bugfix `elem` ["0"{-,"98","99"-}] = "" + | otherwise = "."++bugfix + patches' + | patches/="0" = "+"++patches + | otherwise = "" + os' + | os == "darwin" = "mac" + | otherwise = os + prettify (major:minor:bugfix:[]) = prettify (major:minor:bugfix:"0":[]) + prettify (major:minor:[]) = prettify (major:minor:"0":"0":[]) + prettify (major:[]) = prettify (major:"0":"0":"0":[]) + prettify [] = error "VERSION is empty, please fix" + prettify _ = error "VERSION has too many components, please fix" + +versionstr = prettify $ splitAtElement '.' buildversion :: String + where + prettify (major:minor:bugfix:patches:[]) = printf "%s.%s%s%s%s" major minor bugfix' patches' desc where bugfix' | bugfix `elem` ["0"{-,"98","99"-}] = "" | otherwise = "."++bugfix patches' - | patches/="0" = " + "++patches++" patches" + | patches/="0" = "+"++patches++" patches" | otherwise = "" desc -- | bugfix=="98" = " (alpha)" @@ -31,10 +62,10 @@ | otherwise = "" prettify s = intercalate "." s -versionmsg = progname ++ " " ++ versionstr ++ configmsg ++ "\n" +versionmsg = progname ++ "-" ++ versionstr ++ configmsg :: String where configmsg - | null configflags = "" - | otherwise = ", built with " ++ intercalate ", " configflags + | null configflags = " with no extras" + | otherwise = " with " ++ intercalate ", " configflags configflags = tail ["" #ifdef VTY diff --git a/WebCommand.hs b/WebCommand.hs deleted file mode 100644 --- a/WebCommand.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-| -A happs-based web UI for hledger. --} - -module WebCommand -where -import Control.Monad.Trans (liftIO) -import Data.ByteString.Lazy.UTF8 (toString) -import qualified Data.Map as M -import Data.Map ((!)) -import Data.Time.Clock -import Data.Time.Format -import System.Locale -import Control.Concurrent -import qualified Data.ByteString.Lazy.Char8 as B -import Happstack.Data (defaultValue) -import Happstack.Server -import Happstack.Server.HTTP.FileServe (fileServe) -import Happstack.State.Control (waitForTermination) -import System.Cmd (system) -import System.Info (os) -import System.Exit - -import Ledger -import Options -import BalanceCommand -import RegisterCommand -import PrintCommand -import HistogramCommand - - -tcpport = 5000 - -web :: [Opt] -> [String] -> Ledger -> IO () -web opts args l = - if Debug `elem` opts - then do - putStrLn $ printf "starting web server on port %d in debug mode" tcpport - simpleHTTP nullConf{port=tcpport} handlers - else do - putStrLn $ printf "starting web server on port %d" tcpport - tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers - putStrLn "starting web browser" - openBrowserOn $ printf "http://localhost:%d/balance" tcpport - waitForTermination - putStrLn "shutting down web server..." - killThread tid - putStrLn "shutdown complete" - - where - handlers :: ServerPartT IO Response - handlers = msum - [methodSP GET $ withDataFn (look "a") $ \a -> templatise $ balancereport [a] - ,methodSP GET $ templatise $ balancereport [] - ,dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a] - ,dir "print" $ templatise $ printreport [] - ,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a] - ,dir "register" $ templatise $ registerreport [] - ,dir "balance" $ withDataFn (look "a") $ \a -> templatise $ balancereport [a] - ,dir "balance" $ templatise $ balancereport [] - ,dir "histogram" $ withDataFn (look "a") $ \a -> templatise $ histogramreport [a] - ,dir "histogram" $ templatise $ histogramreport [] - ] - printreport apats = showLedgerTransactions opts (apats ++ args) l - registerreport apats = showRegisterReport opts (apats ++ args) l - balancereport [] = showBalanceReport opts args l - balancereport apats = showBalanceReport opts (apats ++ args) l' - where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time - histogramreport [] = showHistogram opts args l - histogramreport apats = showHistogram opts (apats ++ args) l' - where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time - -templatise :: String -> ServerPartT IO Response -templatise s = do - r <- askRq - return $ setHeader "Content-Type" "text/html" $ toResponse $ maintemplate r s - -maintemplate :: Request -> String -> String -maintemplate r = printf (unlines - ["
" - ,"
search: 
" - ,"
" - ,"
" - ," balance" - ,"|" - ," register" - ,"|" - ," print" - ,"|" - ," histogram" - ,"
" - ,"
%s
" - ]) - (dropWhile (=='/') $ rqUri r) - (fromMaybe "" $ queryValue "a" r) - -queryValues :: String -> Request -> [String] -queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r - -queryValue :: String -> Request -> Maybe String -queryValue q r = case filter ((==q).fst) $ rqInputs r of - [] -> Nothing - is -> Just $ B.unpack $ inputValue $ snd $ head is - --- | Attempt to open a web browser on the given url, all platforms. -openBrowserOn :: String -> IO ExitCode -openBrowserOn u = trybrowsers browsers u - where - trybrowsers (b:bs) u = do - e <- system $ printf "%s %s" b u - case e of - ExitSuccess -> return ExitSuccess - ExitFailure _ -> trybrowsers bs u - trybrowsers [] u = do - putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers - putStrLn $ printf "Please open your browser and visit %s" u - return $ ExitFailure 127 - browsers | os=="darwin" = ["open"] - | os=="mingw32" = ["firefox","safari","opera","iexplore"] - | otherwise = ["sensible-browser","firefox"] - -- jeffz: write a ffi binding for it using the Win32 package as a basis - -- start by adding System/Win32/Shell.hsc and follow the style of any - -- other module in that directory for types, headers, error handling and - -- what not. - -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL); - -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL); - diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -1,36 +1,45 @@ -Name: hledger --- updated by build process from VERSION -Version: 0.5.1 -Category: Finance -Synopsis: A ledger-compatible text-based accounting tool. -Description: hledger is a partial haskell clone of John Wiegley's "ledger" text-based - accounting tool. It generates ledger-compatible register & balance reports - from a plain text journal, and demonstrates a functional implementation of ledger. -License: GPL -Stability: beta -Author: Simon Michael -Maintainer: Simon Michael -Homepage: http://hledger.org -Tested-With: GHC -Build-Type: Simple -License-File: LICENSE -Extra-Source-Files: README sample.ledger -Extra-Tmp-Files: -Cabal-Version: >= 1.2 +name: hledger +-- Version is set by the makefile +version: 0.6 +category: Finance +synopsis: A command-line (or curses or web-based) double-entry accounting tool. +description: + hledger reads a plain text ledger file or timelog + describing your transactions and displays precise + balance and register reports via command-line, curses + or web interface. It is a remix, in haskell, of John + Wiegley's excellent c++ ledger. hledger aims to be a + practical, accessible tool for end users and a useful + library for finance-minded haskell programmers. -Flag vty +license: GPL +license-file: LICENSE +author: Simon Michael +maintainer: Simon Michael +homepage: http://hledger.org +bug-reports: http://code.google.com/p/hledger/issues +stability: experimental +tested-with: GHC==6.8, GHC==6.10 +cabal-version: >= 1.2 +build-type: Simple + +extra-tmp-files: +extra-source-files: + README + sample.ledger + sample.timelog + +flag vty description: enable the curses ui default: False -Flag happs +flag happs description: enable the web ui default: False -Library - Build-Depends: base, containers, haskell98, directory, parsec, regex-compat, - old-locale, time, HUnit, filepath, utf8-string - - Exposed-modules:Ledger +library + exposed-modules: + Ledger Ledger.Account Ledger.AccountName Ledger.Amount @@ -46,27 +55,28 @@ Ledger.Transaction Ledger.Types Ledger.Utils - -Executable hledger - Main-Is: hledger.hs - - Build-Depends: base, containers, haskell98, directory, parsec, - regex-compat, regexpr>=0.5.1, old-locale, time, - HUnit, mtl, bytestring, filepath, process, testpack, - regex-pcre, csv, split, utf8-string + Build-Depends: + base >= 3 && < 5 + ,containers + ,directory + ,filepath + ,haskell98 + ,parsec + ,time + ,utf8-string >= 0.3 && < 0.4 + ,HUnit - Other-Modules: - AddCommand - BalanceCommand - ConvertCommand - HistogramCommand - Options - PrintCommand - RegisterCommand - Setup - Tests - Utils - Version +executable hledger + main-is: hledger.hs + other-modules: + Commands.Add + Commands.All + Commands.Balance + Commands.Convert + Commands.Histogram + Commands.Print + Commands.Register + Commands.Stats Ledger Ledger.Account Ledger.AccountName @@ -83,21 +93,54 @@ Ledger.Transaction Ledger.Types Ledger.Utils + Options + Tests + Utils + Version + build-depends: + base >= 3 && < 5 + ,bytestring + ,containers + ,csv + ,directory + ,filepath + ,haskell98 + ,mtl + ,parsec + ,process + ,regexpr >= 0.5.1 + ,split + ,testpack + ,time + ,utf8-string >= 0.3 && < 0.4 + ,HUnit - -- need to set patchlevel here (darcs changes --from-tag=. --count) - cpp-options: -DPATCHES=0 + -- should set patchlevel here as in Makefile + cpp-options: -DPATCHLEVEL=0 if flag(vty) cpp-options: -DVTY - Build-Depends:vty >= 3.1.8.2 && < 3.2 - Other-Modules:UICommand + other-modules:Commands.UI + build-depends: + vty >= 3.1.8.2 && < 3.2 if flag(happs) cpp-options: -DHAPPS - Build-Depends:happstack >= 0.2 && < 0.3 - ,happstack-data >= 0.2 && < 0.3 - ,happstack-server >= 0.2 && < 0.3 - ,happstack-state >= 0.2 && < 0.3 - ,utf8-string >= 0.3 && < 0.4 - Other-Modules:WebCommand + other-modules:Commands.Web + build-depends: + happstack >= 0.2 && < 0.3 + ,happstack-data >= 0.2 && < 0.3 + ,happstack-server >= 0.2 && < 0.3 + ,happstack-state >= 0.2 && < 0.3 + ,xhtml >= 3000.2 && < 3000.3 + ,HTTP >= 4000.0 && < 4000.1 +-- source-repository head +-- type: darcs +-- location: http://joyful.com/repos/hledger +-- disabled for now due to: +-- The 'source-repository' section is new in Cabal-1.6. Unfortunately it messes +-- up the parser in earlier Cabal versions so you need to specify 'cabal-version: +-- >= 1.6'. + +-- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html diff --git a/hledger.hs b/hledger.hs --- a/hledger.hs +++ b/hledger.hs @@ -1,4 +1,4 @@ --- sp doesn't like.. #!/usr/bin/env runhaskell +-- #!/usr/bin/env runhaskell <- sp doesn't like {-# OPTIONS_GHC -cpp #-} {-| hledger - a ledger-compatible text-based accounting tool. @@ -35,49 +35,16 @@ See "Ledger.Ledger" for more examples. -} -module Main ( - -- for easy ghci access - module Main, - module Utils, - module Options, - module BalanceCommand, - module ConvertCommand, - module PrintCommand, - module RegisterCommand, - module HistogramCommand, - module AddCommand, -#ifdef VTY - module UICommand, -#endif -#ifdef HAPPS - module WebCommand, -#endif -) -where -import Prelude hiding (putStr) -import Control.Monad.Error -import qualified Data.Map as Map (lookup) +module Main where +import Prelude hiding (putStr, putStrLn) import System.IO.UTF8 -import System.IO (stderr) -import Version (versionmsg) +import Commands.All import Ledger -import Utils (withLedgerDo) import Options import Tests -import BalanceCommand -import ConvertCommand -import PrintCommand -import RegisterCommand -import HistogramCommand -import AddCommand -#ifdef VTY -import UICommand -#endif -#ifdef HAPPS -import WebCommand -#endif - +import Utils (withLedgerDo) +import Version (versionmsg, binaryfilename) main :: IO () main = do @@ -86,13 +53,15 @@ where run cmd opts args | Help `elem` opts = putStr $ usage - | Version `elem` opts = putStr versionmsg + | Version `elem` opts = putStrLn versionmsg + | BinaryFilename `elem` opts = putStrLn binaryfilename | cmd `isPrefixOf` "balance" = withLedgerDo opts args cmd balance | cmd `isPrefixOf` "convert" = withLedgerDo opts args cmd convert | cmd `isPrefixOf` "print" = withLedgerDo opts args cmd print' | cmd `isPrefixOf` "register" = withLedgerDo opts args cmd register | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram | cmd `isPrefixOf` "add" = withLedgerDo opts args cmd add + | cmd `isPrefixOf` "stats" = withLedgerDo opts args cmd stats #ifdef VTY | cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui #endif @@ -101,4 +70,3 @@ #endif | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr $ usage - diff --git a/sample.timelog b/sample.timelog new file mode 100644 --- /dev/null +++ b/sample.timelog @@ -0,0 +1,6 @@ +i 2009/03/27 09:00:00 projects:a +o 2009/03/27 17:00:34 +i 2009/03/31 22:21:45 personal:reading:online +o 2009/04/01 02:00:34 +i 2009/04/02 09:00:00 projects:b +o 2009/04/02 17:00:34