diff --git a/AddCommand.hs b/AddCommand.hs new file mode 100644 --- /dev/null +++ b/AddCommand.hs @@ -0,0 +1,228 @@ +{-| + +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 --- a/BalanceCommand.hs +++ b/BalanceCommand.hs @@ -96,6 +96,7 @@ module BalanceCommand where +import Prelude hiding (putStr) import Ledger.Utils import Ledger.Types import Ledger.Amount @@ -105,6 +106,7 @@ import Ledger.Parse import Options import Utils +import System.IO.UTF8 -- | Print a balance report. @@ -125,7 +127,7 @@ | not (Empty `elem` opts) && isZeroMixedAmount total = "" | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total where - total = sum $ map abalance $ topAccounts l + total = sum $ map abalance $ ledgerTopAccounts l -- | Display one line of the balance report with appropriate indenting and eliding. showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String @@ -155,5 +157,5 @@ numinterestingsubs = length $ filter isInterestingTree subtrees where isInterestingTree t = treeany (isInteresting opts l . aname) t - subtrees = map (fromJust . ledgerAccountTreeAt l) $ subAccounts l $ ledgerAccount l a + subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a diff --git a/HistogramCommand.hs b/HistogramCommand.hs new file mode 100644 --- /dev/null +++ b/HistogramCommand.hs @@ -0,0 +1,50 @@ +{-| + +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 @@ -11,11 +11,12 @@ module Ledger.Amount, module Ledger.Commodity, module Ledger.Dates, - module Ledger.Entry, + module Ledger.IO, + module Ledger.LedgerTransaction, module Ledger.Ledger, module Ledger.Parse, module Ledger.RawLedger, - module Ledger.RawTransaction, + module Ledger.Posting, module Ledger.TimeLog, module Ledger.Transaction, module Ledger.Types, @@ -27,11 +28,12 @@ import Ledger.Amount import Ledger.Commodity import Ledger.Dates -import Ledger.Entry +import Ledger.IO +import Ledger.LedgerTransaction import Ledger.Ledger import Ledger.Parse import Ledger.RawLedger -import Ledger.RawTransaction +import Ledger.Posting import Ledger.TimeLog import Ledger.Transaction import Ledger.Types diff --git a/Ledger/Account.hs b/Ledger/Account.hs --- a/Ledger/Account.hs +++ b/Ledger/Account.hs @@ -1,8 +1,13 @@ {-| -An 'Account' stores, for efficiency: an 'AccountName', all transactions in -the account (excluding subaccounts), and the account balance (including -subaccounts). +A compound data type for efficiency. An 'Account' stores + +- an 'AccountName', + +- all 'Transaction's (postings plus ledger transaction info) in the + account, excluding subaccounts + +- a 'MixedAmount' representing the account balance, including subaccounts. -} diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs --- a/Ledger/AccountName.hs +++ b/Ledger/AccountName.hs @@ -145,4 +145,4 @@ abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat positivepats = filter (not . isnegativepat) negativepats = filter isnegativepat -matchregex pat str = containsRegex (mkRegexWithOpts pat True False) str +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 @@ -126,9 +126,13 @@ -- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool -isZeroAmount a = nonzerodigits == "" - where nonzerodigits = filter (`elem` "123456789") $ showAmount a +isZeroAmount a = null $ filter (`elem` "123456789") $ showAmount a +-- | Is this amount "really" zero, regardless of the display precision ? +-- Since we are using floating point, for now just test to some high precision. +isReallyZeroAmount :: Amount -> Bool +isReallyZeroAmount a = null $ filter (`elem` "123456789") $ printf "%.10f" $ quantity a + -- | Access a mixed amount's components. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as @@ -137,6 +141,10 @@ -- containing only simple amounts which appear to be zero ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount + +-- | Is this mixed amount "really" zero ? See isReallyZeroAmount. +isReallyZeroMixedAmount :: MixedAmount -> Bool +isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount -- | MixedAmount derives Eq in Types.hs, but that doesn't know that we -- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there. diff --git a/Ledger/Entry.hs b/Ledger/Entry.hs deleted file mode 100644 --- a/Ledger/Entry.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-| - -An 'Entry' represents a regular entry in the ledger file. It normally -contains two or more balanced 'RawTransaction's. - --} - -module Ledger.Entry -where -import Ledger.Utils -import Ledger.Types -import Ledger.Dates -import Ledger.RawTransaction -import Ledger.Amount - - -instance Show Entry where show = showEntry - -instance Show ModifierEntry where - show e = "= " ++ (valueexpr e) ++ "\n" ++ unlines (map show (m_transactions e)) - -instance Show PeriodicEntry where - show e = "~ " ++ (periodicexpr e) ++ "\n" ++ unlines (map show (p_transactions e)) - -nullentry = Entry { - edate=parsedate "1900/1/1", - estatus=False, - ecode="", - edescription="", - ecomment="", - etransactions=[], - epreceding_comment_lines="" - } - -{-| -Show a ledger entry, formatted for the print command. ledger 2.x's -standard format looks like this: - -@ -yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] - account name 1..................... ...$amount1[ ; comment...............] - account name 2..................... ..$-amount1[ ; comment...............] - -pcodewidth = no limit -- 10 -- mimicking ledger layout. -pdescwidth = no limit -- 20 -- I don't remember what these mean, -pacctwidth = 35 minimum, no maximum -- they were important at the time. -pamtwidth = 11 -pcommentwidth = no limit -- 22 -@ --} -showEntry :: Entry -> String -showEntry = showEntry' True - -showEntryUnelided :: Entry -> String -showEntryUnelided = showEntry' False - -showEntry' :: Bool -> Entry -> String -showEntry' elide e = - unlines $ [{-precedingcomment ++ -}description] ++ (showtxns $ etransactions e) ++ [""] - where - precedingcomment = epreceding_comment_lines e - description = concat [date, status, code, desc] -- , comment] - date = showdate $ edate e - status = if estatus e then " *" else "" - code = if (length $ ecode e) > 0 then (printf " (%s)" $ ecode e) else "" - desc = " " ++ edescription e - comment = if (length $ ecomment e) > 0 then " ; "++(ecomment e) else "" - showtxns ts - | elide && length ts == 2 = [showtxn (ts !! 0), showtxnnoamt (ts !! 1)] - | otherwise = map showtxn ts - showtxn t = showacct t ++ " " ++ (showamount $ tamount t) ++ (showcomment $ tcomment t) - showtxnnoamt t = showacct t ++ " " ++ (showcomment $ tcomment t) - showacct t = " " ++ showstatus t ++ (showaccountname $ taccount t) - showamount = printf "%12s" . showMixedAmount - showaccountname s = printf "%-34s" s - showcomment s = if (length s) > 0 then " ; "++s else "" - showdate d = printf "%-10s" (showDate d) - showstatus t = case tstatus t of - True -> "* " - False -> "" - -isEntryBalanced :: Entry -> Bool -isEntryBalanced (Entry {etransactions=ts}) = - isZeroMixedAmount $ costOfMixedAmount $ sum $ map tamount $ filter isReal ts - --- | Ensure that this entry is balanced, possibly auto-filling a missing --- amount first. We can auto-fill if there is just one non-virtual --- transaction without an amount. The auto-filled balance will be --- converted to cost basis if possible. If the entry can not be balanced, --- return an error message instead. -balanceEntry :: Entry -> Either String Entry -balanceEntry e@Entry{etransactions=ts} - | length missingamounts > 1 = Left $ showerr "could not balance this entry, too many missing amounts" - | not $ isEntryBalanced e' = Left $ showerr "could not balance this entry, amounts do not balance" - | otherwise = Right e' - where - (withamounts, missingamounts) = partition hasAmount $ filter isReal ts - e' = e{etransactions=ts'} - ts' | length missingamounts == 1 = map balance ts - | otherwise = ts - where - balance t | isReal t && not (hasAmount t) = t{tamount = costOfMixedAmount (-otherstotal)} - | otherwise = t - where otherstotal = sum $ map tamount withamounts - showerr s = printf "%s:\n%s" s (showEntryUnelided e) diff --git a/Ledger/IO.hs b/Ledger/IO.hs new file mode 100644 --- /dev/null +++ b/Ledger/IO.hs @@ -0,0 +1,107 @@ +{-| +Utilities for doing I/O with ledger files. +-} + +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) +import Ledger.Types (DateSpan(..),RawLedger,Ledger(..)) +import Ledger.Utils (getCurrentLocalTime) +import System.Directory (getHomeDirectory) +import System.Environment (getEnv) +import System.IO +import Text.ParserCombinators.Parsec +import qualified Data.Map as Map (lookup) + + +ledgerdefaultpath = "~/.ledger" +timelogdefaultpath = "~/.timelog" +ledgerenvvar = "LEDGER" +timelogenvvar = "TIMELOG" + +-- | A tuple of arguments specifying how to filter a raw ledger file: +-- +-- - only include transactions in this date span +-- +-- - only include if cleared\/uncleared\/don't care +-- +-- - only include if real\/don't care +-- +-- - convert all amounts to cost basis +-- +-- - only include if matching these account patterns +-- +-- - only include if matching these description patterns + +type IOArgs = (DateSpan + ,Maybe Bool + ,Bool + ,Bool + ,[String] + ,[String] + ) + +noioargs = (DateSpan Nothing Nothing, Nothing, False, False, [], []) + +-- | Get the user's default ledger file path. +myLedgerPath :: IO String +myLedgerPath = + getEnv ledgerenvvar `catch` \_ -> return ledgerdefaultpath + +-- | Get the user's default timelog file path. +myTimelogPath :: IO String +myTimelogPath = + getEnv timelogenvvar `catch` \_ -> return timelogdefaultpath + +-- | Read the user's default ledger file, or give an error. +myLedger :: IO Ledger +myLedger = myLedgerPath >>= readLedger + +-- | Read the user's default timelog file, or give an error. +myTimelog :: IO Ledger +myTimelog = myTimelogPath >>= readLedger + +-- | Read a ledger from this file, with no filtering, or give an error. +readLedger :: FilePath -> IO Ledger +readLedger f = tildeExpand f >>= 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 + +-- | Read a RawLedger from the given string, using the current time as +-- reference time, or give a parse error. +rawLedgerFromString :: String -> IO RawLedger +rawLedgerFromString s = do + t <- getCurrentLocalTime + liftM (either error id) $ runErrorT $ parseLedger t "(string)" s + +-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger. +filterAndCacheLedger :: IOArgs -> String -> RawLedger -> Ledger +filterAndCacheLedger (span,cleared,real,costbasis,apats,dpats) rawtext rl = + (cacheLedger apats + $ filterRawLedger span dpats cleared real + $ 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 + diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -1,10 +1,54 @@ {-| -A 'Ledger' stores, for efficiency, a 'RawLedger' plus its tree of account -names, and a map from account names to 'Account's. It may also have had -uninteresting 'Entry's and 'Transaction's filtered out. It also stores -the complete ledger file text for the ui command. +A compound data type for efficiency. A 'Ledger' caches information derived +from a 'RawLedger' for easier querying. Also it typically has had +uninteresting 'LedgerTransaction's and 'Posting's filtered out. It +contains: +- the original unfiltered 'RawLedger' + +- a tree of 'AccountName's + +- a map from account names to 'Account's + +- the full text of the journal file, when available + +This is the main object you'll deal with as a user of the Ledger +library. The most useful functions also have shorter, lower-case +aliases for easier interaction. Here's an example: + +> > import Ledger +> > l <- readLedger "sample.ledger" +> > accountnames l +> ["assets","assets:bank","assets:bank:checking","assets:bank:saving",... +> > accounts l +> [Account assets with 0 txns and $-1 balance,Account assets:bank with... +> > topaccounts l +> [Account assets with 0 txns and $-1 balance,Account expenses with... +> > account l "assets" +> Account assets with 0 txns and $-1 balance +> > accountsmatching ["ch"] l +> accountsmatching ["ch"] l +> [Account assets:bank:checking with 4 txns and $0 balance] +> > subaccounts l (account l "assets") +> subaccounts l (account l "assets") +> [Account assets:bank with 0 txns and $1 balance,Account assets:cash... +> > head $ transactions l +> 2008/01/01 income assets:bank:checking $1 RegularPosting +> > accounttree 2 l +> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [... +> > accounttreeat l (account l "assets") +> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ... +> > datespan l +> DateSpan (Just 2008-01-01) (Just 2009-01-01) +> > rawdatespan l +> DateSpan (Just 2008-01-01) (Just 2009-01-01) +> > ledgeramounts l +> [$1,$-1,$1,$-1,$1,$-1,$1,$1,$-2,$1,$-1] +> > commodities l +> [Commodity {symbol = "$", side = L, spaced = False, comma = False, ... + + -} module Ledger.Ledger @@ -18,14 +62,14 @@ import Ledger.Account import Ledger.Transaction import Ledger.RawLedger -import Ledger.Entry +import Ledger.LedgerTransaction instance Show Ledger where - show l = printf "Ledger with %d entries, %d accounts\n%s" - ((length $ entries $ rawledger l) + - (length $ modifier_entries $ rawledger l) + - (length $ periodic_entries $ rawledger l)) + show l = printf "Ledger with %d transactions, %d accounts\n%s" + ((length $ ledger_txns $ rawledger l) + + (length $ modifier_txns $ rawledger l) + + (length $ periodic_txns $ rawledger l)) (length $ accountnames l) (showtree $ accountnametree l) @@ -48,7 +92,7 @@ (AccountName -> MixedAmount)) groupTransactions ts = (ant,txnsof,exclbalof,inclbalof) where - txnanames = sort $ nub $ map account ts + txnanames = sort $ nub $ map taccount ts ant = accountNameTreeFrom $ expandAccountNames $ txnanames allanames = flatten ant txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allanames]) @@ -78,38 +122,38 @@ transactionsByAccount :: [Transaction] -> Map.Map AccountName [Transaction] transactionsByAccount ts = m' where - sortedts = sortBy (comparing account) ts - groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts - m' = Map.fromList [(account $ head g, g) | g <- groupedts] + sortedts = sortBy (comparing taccount) ts + groupedts = groupBy (\t1 t2 -> taccount t1 == taccount t2) sortedts + m' = Map.fromList [(taccount $ head g, g) | g <- groupedts] -- The special account name "top" can be used to look up all transactions. ? -- m' = Map.insert "top" sortedts m filtertxns :: [String] -> [Transaction] -> [Transaction] -filtertxns apats ts = filter (matchpats apats . account) ts +filtertxns apats ts = filter (matchpats apats . taccount) ts -- | List a ledger's account names. -accountnames :: Ledger -> [AccountName] -accountnames l = drop 1 $ flatten $ accountnametree l +ledgerAccountNames :: Ledger -> [AccountName] +ledgerAccountNames l = drop 1 $ flatten $ accountnametree l -- | Get the named account from a ledger. ledgerAccount :: Ledger -> AccountName -> Account ledgerAccount l a = (accountmap l) ! a -- | List a ledger's accounts, in tree order -accounts :: Ledger -> [Account] -accounts l = drop 1 $ flatten $ ledgerAccountTree 9999 l +ledgerAccounts :: Ledger -> [Account] +ledgerAccounts l = drop 1 $ flatten $ ledgerAccountTree 9999 l -- | List a ledger's top-level accounts, in tree order -topAccounts :: Ledger -> [Account] -topAccounts l = map root $ branches $ ledgerAccountTree 9999 l +ledgerTopAccounts :: Ledger -> [Account] +ledgerTopAccounts l = map root $ branches $ ledgerAccountTree 9999 l -- | Accounts in ledger whose name matches the pattern, in tree order. -accountsMatching :: [String] -> Ledger -> [Account] -accountsMatching pats l = filter (matchpats pats . aname) $ accounts l +ledgerAccountsMatching :: [String] -> Ledger -> [Account] +ledgerAccountsMatching pats l = filter (matchpats pats . aname) $ accounts l -- | List a ledger account's immediate subaccounts -subAccounts :: Ledger -> Account -> [Account] -subAccounts l Account{aname=a} = +ledgerSubAccounts :: Ledger -> Account -> [Account] +ledgerSubAccounts l Account{aname=a} = map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l -- | List a ledger's transactions. @@ -124,10 +168,48 @@ ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l --- | The (explicit) date span containing all the ledger's transactions, --- or DateSpan Nothing Nothing if there are no transactions. +-- | The date span containing all the ledger's (filtered) transactions, +-- or DateSpan Nothing Nothing if there are none. +ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan l | null ts = DateSpan Nothing Nothing - | otherwise = DateSpan (Just $ date $ head ts) (Just $ addDays 1 $ date $ last ts) + | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) where - ts = sortBy (comparing date) $ ledgerTransactions l + ts = sortBy (comparing tdate) $ ledgerTransactions l + +-- | Convenience aliases. +accountnames :: Ledger -> [AccountName] +accountnames = ledgerAccountNames + +account :: Ledger -> AccountName -> Account +account = ledgerAccount + +accounts :: Ledger -> [Account] +accounts = ledgerAccounts + +topaccounts :: Ledger -> [Account] +topaccounts = ledgerTopAccounts + +accountsmatching :: [String] -> Ledger -> [Account] +accountsmatching = ledgerAccountsMatching + +subaccounts :: Ledger -> Account -> [Account] +subaccounts = ledgerSubAccounts + +transactions :: Ledger -> [Transaction] +transactions = ledgerTransactions + +accounttree :: Int -> Ledger -> Tree Account +accounttree = ledgerAccountTree + +accounttreeat :: Ledger -> Account -> Maybe (Tree Account) +accounttreeat = ledgerAccountTreeAt + +datespan :: Ledger -> DateSpan +datespan = ledgerDateSpan + +rawdatespan :: Ledger -> DateSpan +rawdatespan = rawLedgerDateSpan . rawledger + +ledgeramounts :: Ledger -> [MixedAmount] +ledgeramounts = rawLedgerAmounts . rawledger diff --git a/Ledger/LedgerTransaction.hs b/Ledger/LedgerTransaction.hs new file mode 100644 --- /dev/null +++ b/Ledger/LedgerTransaction.hs @@ -0,0 +1,109 @@ +{-| + +A 'LedgerTransaction' represents a regular transaction in the ledger +file. It normally contains two or more balanced 'Posting's. + +-} + +module Ledger.LedgerTransaction +where +import Ledger.Utils +import Ledger.Types +import Ledger.Dates +import Ledger.Posting +import Ledger.Amount + + +instance Show LedgerTransaction where show = showLedgerTransaction + +instance Show ModifierTransaction where + show t = "= " ++ (mtvalueexpr t) ++ "\n" ++ unlines (map show (mtpostings t)) + +instance Show PeriodicTransaction where + show t = "~ " ++ (ptperiodicexpr t) ++ "\n" ++ unlines (map show (ptpostings t)) + +nullledgertxn :: LedgerTransaction +nullledgertxn = LedgerTransaction { + ltdate=parsedate "1900/1/1", + ltstatus=False, + ltcode="", + ltdescription="", + ltcomment="", + ltpostings=[], + ltpreceding_comment_lines="" + } + +{-| +Show a ledger entry, formatted for the print command. ledger 2.x's +standard format looks like this: + +@ +yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] + account name 1..................... ...$amount1[ ; comment...............] + account name 2..................... ..$-amount1[ ; comment...............] + +pcodewidth = no limit -- 10 -- mimicking ledger layout. +pdescwidth = no limit -- 20 -- I don't remember what these mean, +pacctwidth = 35 minimum, no maximum -- they were important at the time. +pamtwidth = 11 +pcommentwidth = no limit -- 22 +@ +-} +showLedgerTransaction :: LedgerTransaction -> String +showLedgerTransaction = showLedgerTransaction' True + +showLedgerTransactionUnelided :: LedgerTransaction -> String +showLedgerTransactionUnelided = showLedgerTransaction' False + +showLedgerTransaction' :: Bool -> LedgerTransaction -> String +showLedgerTransaction' elide t = + unlines $ [{-precedingcomment ++ -}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 + = map showposting (init ps) ++ [showpostingnoamt (last ps)] + | otherwise = map showposting ps + 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) + 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 "" + +isLedgerTransactionBalanced :: LedgerTransaction -> Bool +isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) = + all (isReallyZeroMixedAmount . costOfMixedAmount . sum . map pamount) + [filter isReal ps, filter isBalancedVirtual ps] + +-- | Ensure that this entry is balanced, possibly auto-filling a missing +-- amount first. We can auto-fill if there is just one non-virtual +-- transaction without an amount. The auto-filled balance will be +-- converted to cost basis if possible. If the entry can not be balanced, +-- return an error message instead. +balanceLedgerTransaction :: LedgerTransaction -> Either String LedgerTransaction +balanceLedgerTransaction t@LedgerTransaction{ltpostings=ps} + | length missingamounts > 1 = Left $ printerr "could not balance this transaction, too many missing amounts" + | not $ isLedgerTransactionBalanced t' = Left $ printerr nonzerobalanceerror + | otherwise = Right t' + where + (withamounts, missingamounts) = partition hasAmount $ filter isReal ps + t' = t{ltpostings=ps'} + ps' | length missingamounts == 1 = map balance ps + | otherwise = ps + where + balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)} + | otherwise = p + where otherstotal = sum $ map pamount withamounts + printerr s = printf "%s:\n%s" s (showLedgerTransactionUnelided t) + +nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero" diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -6,6 +6,7 @@ module Ledger.Parse where +import Prelude hiding (readFile, putStr, print) import Control.Monad import Control.Monad.Error import Text.ParserCombinators.Parsec @@ -14,7 +15,8 @@ import Text.ParserCombinators.Parsec.Combinator import qualified Text.ParserCombinators.Parsec.Token as P import System.Directory -import System.IO +import System.IO.UTF8 +import System.IO (stdin) import qualified Data.Map as Map import Data.Time.LocalTime import Data.Time.Calendar @@ -22,7 +24,7 @@ import Ledger.Types import Ledger.Dates import Ledger.Amount -import Ledger.Entry +import Ledger.LedgerTransaction import Ledger.Commodity import Ledger.TimeLog import Ledger.RawLedger @@ -70,7 +72,7 @@ parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger parseLedgerFile t "-" = liftIO (hGetContents stdin) >>= parseLedger t "-" -parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f +parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f -- | Parses the contents of a ledger file, or gives an error. Requires -- the current (local) time to calculate any unfinished timelog sessions, @@ -81,26 +83,27 @@ Right m -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` (return rawLedgerEmpty) Left err -> throwError $ show err --- As all ledger line types can be distinguished by the first --- character, excepting transactions versus empty (blank or --- comment-only) lines, can use choice w/o try ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) -ledgerFile = do entries <- many1 ledgerAnyEntry +ledgerFile = do items <- many ledgerItem eof - return $ liftM (foldr1 (.)) $ sequence entries - where ledgerAnyEntry = choice [ ledgerDirective - , liftM (return . addEntry) ledgerEntry - , liftM (return . addModifierEntry) ledgerModifierEntry - , liftM (return . addPeriodicEntry) ledgerPeriodicEntry - , liftM (return . addHistoricalPrice) ledgerHistoricalPrice - , ledgerDefaultYear - , emptyLine >> return (return id) - , liftM (return . addTimeLogEntry) timelogentry - ] + return $ liftM (foldr (.) id) $ sequence items + where + -- As all ledger line types can be distinguished by the first + -- character, excepting transactions versus empty (blank or + -- comment-only) lines, can use choice w/o try + ledgerItem = choice [ ledgerDirective + , liftM (return . addLedgerTransaction) ledgerTransaction + , liftM (return . addModifierTransaction) ledgerModifierTransaction + , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , ledgerDefaultYear + , emptyLine >> return (return id) + , liftM (return . addTimeLogEntry) timelogentry + ] ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) -ledgerDirective = do char '!' +ledgerDirective = do char '!' "directive" directive <- many nonspace case directive of "include" -> ledgerInclude @@ -249,7 +252,7 @@ emptyLine :: GenParser Char st () emptyLine = do many spacenonewline - optional $ char ';' >> many (noneOf "\n") + optional $ (char ';' "comment") >> many (noneOf "\n") newline return () @@ -262,25 +265,25 @@ ) <|> return "" "comment" -ledgerModifierEntry :: GenParser Char LedgerFileCtx ModifierEntry -ledgerModifierEntry = do - char '=' "modifier entry" +ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction +ledgerModifierTransaction = do + char '=' "modifier transaction" many spacenonewline valueexpr <- restofline - transactions <- ledgertransactions - return $ ModifierEntry valueexpr transactions + postings <- ledgerpostings + return $ ModifierTransaction valueexpr postings -ledgerPeriodicEntry :: GenParser Char LedgerFileCtx PeriodicEntry -ledgerPeriodicEntry = do - char '~' "entry" +ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction +ledgerPeriodicTransaction = do + char '~' "periodic transaction" many spacenonewline periodexpr <- restofline - transactions <- ledgertransactions - return $ PeriodicEntry periodexpr transactions + postings <- ledgerpostings + return $ PeriodicTransaction periodexpr postings ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice ledgerHistoricalPrice = do - char 'P' "hprice" + char 'P' "historical price" many spacenonewline date <- ledgerdate many spacenonewline @@ -303,21 +306,18 @@ -- | Try to parse a ledger entry. If we successfully parse an entry, ensure it is balanced, -- and if we cannot, raise an error. -ledgerEntry :: GenParser Char LedgerFileCtx Entry -ledgerEntry = do - date <- ledgerdate "entry" +ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction +ledgerTransaction = do + date <- ledgerdate "transaction" status <- ledgerstatus code <- ledgercode --- ledger treats entry comments as part of the description, we will too --- desc <- many (noneOf ";\n") "description" --- let description = reverse $ dropWhile (==' ') $ reverse desc - description <- many (noneOf "\n") "description" + description <- liftM rstrip (many1 (noneOf ";\n") "description") comment <- ledgercomment restofline - transactions <- ledgertransactions - let e = Entry date status code description comment transactions "" - case balanceEntry e of - Right e' -> return e' + postings <- ledgerpostings + let t = LedgerTransaction date status code description comment postings "" + case balanceLedgerTransaction t of + Right t' -> return t' Left err -> error err ledgerdate :: GenParser Char LedgerFileCtx Day @@ -353,52 +353,52 @@ return $ LocalTime day tod ledgerstatus :: GenParser Char st Bool -ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False +ledgerstatus = try (do { char '*' "status"; many1 spacenonewline; return True } ) <|> return False ledgercode :: GenParser Char st String -ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" +ledgercode = try (do { char '(' "code"; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" -ledgertransactions :: GenParser Char LedgerFileCtx [RawTransaction] -ledgertransactions = many $ try ledgertransaction +ledgerpostings :: GenParser Char LedgerFileCtx [Posting] +ledgerpostings = many1 $ try ledgerposting -ledgertransaction :: GenParser Char LedgerFileCtx RawTransaction -ledgertransaction = many1 spacenonewline >> choice [ normaltransaction, virtualtransaction, balancedvirtualtransaction ] +ledgerposting :: GenParser Char LedgerFileCtx Posting +ledgerposting = many1 spacenonewline >> choice [ normalposting, virtualposting, balancedvirtualposting ] -normaltransaction :: GenParser Char LedgerFileCtx RawTransaction -normaltransaction = do +normalposting :: GenParser Char LedgerFileCtx Posting +normalposting = do status <- ledgerstatus account <- transactionaccountname - amount <- transactionamount + amount <- postingamount many spacenonewline comment <- ledgercomment restofline parent <- getParentAccount - return (RawTransaction status account amount comment RegularTransaction) + return (Posting status account amount comment RegularPosting) -virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction -virtualtransaction = do +virtualposting :: GenParser Char LedgerFileCtx Posting +virtualposting = do status <- ledgerstatus char '(' account <- transactionaccountname char ')' - amount <- transactionamount + amount <- postingamount many spacenonewline comment <- ledgercomment restofline parent <- getParentAccount - return (RawTransaction status account amount comment VirtualTransaction) + return (Posting status account amount comment VirtualPosting) -balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction -balancedvirtualtransaction = do +balancedvirtualposting :: GenParser Char LedgerFileCtx Posting +balancedvirtualposting = do status <- ledgerstatus char '[' account <- transactionaccountname char ']' - amount <- transactionamount + amount <- postingamount many spacenonewline comment <- ledgercomment restofline - return (RawTransaction status account amount comment BalancedVirtualTransaction) + return (Posting status account amount comment BalancedVirtualPosting) -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName @@ -417,14 +417,15 @@ accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace "account name character (non-bracket, non-parenthesis, non-whitespace)" -transactionamount :: GenParser Char st MixedAmount -transactionamount = +postingamount :: GenParser Char st MixedAmount +postingamount = try (do many1 spacenonewline a <- someamount <|> return missingamt return a ) <|> return missingamt +someamount :: GenParser Char st MixedAmount someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount leftsymbolamount :: GenParser Char st MixedAmount @@ -509,7 +510,7 @@ return ("",frac) -{-| Parse a timelog file. Here is the timelog grammar, from timeclock.el 2.6: +{-| Parse a timelog entry. Here is the timelog grammar from timeclock.el 2.6: @ A timelog contains data in the form of a single entry per line. @@ -545,19 +546,13 @@ o 2007/03/10 17:26:02 -} -timelog :: GenParser Char LedgerFileCtx TimeLog -timelog = do - entries <- many timelogentry "timelog entry" - eof - return $ TimeLog entries - timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry timelogentry = do code <- oneOf "bhioO" many1 spacenonewline datetime <- ledgerdatetime comment <- liftM2 (++) getParentAccount restofline - return $ TimeLogEntry code datetime comment + return $ TimeLogEntry (read [code]) datetime comment -- misc parsing @@ -571,15 +566,15 @@ char '[' (y,m,d) <- smartdate char ']' - let edate = parsedate $ printf "%04s/%02s/%02s" y m d - let matcher = \(Transaction{date=tdate}) -> + let ltdate = parsedate $ printf "%04s/%02s/%02s" y m d + let matcher = \(Transaction{tdate=d}) -> case op of - "<" -> tdate < edate - "<=" -> tdate <= edate - "=" -> tdate == edate - "==" -> tdate == edate -- just in case - ">=" -> tdate >= edate - ">" -> tdate > edate + "<" -> d < ltdate + "<=" -> d <= ltdate + "=" -> d == ltdate + "==" -> d == ltdate -- just in case + ">=" -> d >= ltdate + ">" -> d > ltdate return matcher compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs new file mode 100644 --- /dev/null +++ b/Ledger/Posting.hs @@ -0,0 +1,45 @@ +{-| + +A 'Posting' represents a 'MixedAmount' being added to or subtracted from a +single 'Account'. Each 'LedgerTransaction' contains two or more postings +which should add up to 0. + +Generally, we use these with the ledger transaction's date and description +added, which we call a 'Transaction'. + +-} + +module Ledger.Posting +where +import Ledger.Utils +import Ledger.Types +import Ledger.Amount +import Ledger.AccountName + + +instance Show Posting where show = showPosting + +nullrawposting = Posting False "" nullmixedamt "" RegularPosting + +showPosting :: Posting -> String +showPosting (Posting s 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) + showamount = padleft 12 . showMixedAmountOrZero + +isReal :: Posting -> Bool +isReal p = ptype p == RegularPosting + +isVirtual :: Posting -> Bool +isVirtual p = ptype p == VirtualPosting + +isBalancedVirtual :: Posting -> Bool +isBalancedVirtual p = ptype p == BalancedVirtualPosting + +hasAmount :: Posting -> Bool +hasAmount = (/= missingamt) . pamount diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -13,39 +13,40 @@ import Ledger.Types import Ledger.AccountName import Ledger.Amount -import Ledger.Entry +import Ledger.LedgerTransaction import Ledger.Transaction -import Ledger.RawTransaction +import Ledger.Posting import Ledger.TimeLog instance Show RawLedger where - show l = printf "RawLedger with %d entries, %d accounts: %s" - ((length $ entries l) + - (length $ modifier_entries l) + - (length $ periodic_entries l)) + show l = printf "RawLedger with %d transactions, %d accounts: %s" + ((length $ ledger_txns l) + + (length $ modifier_txns l) + + (length $ periodic_txns l)) (length accounts) (show accounts) -- ++ (show $ rawLedgerTransactions l) where accounts = flatten $ rawLedgerAccountNameTree l rawLedgerEmpty :: RawLedger -rawLedgerEmpty = RawLedger { modifier_entries = [] - , periodic_entries = [] - , entries = [] +rawLedgerEmpty = RawLedger { modifier_txns = [] + , periodic_txns = [] + , ledger_txns = [] , open_timelog_entries = [] , historical_prices = [] , final_comment_lines = [] + , filepath = "" } -addEntry :: Entry -> RawLedger -> RawLedger -addEntry e l0 = l0 { entries = e : (entries l0) } +addLedgerTransaction :: LedgerTransaction -> RawLedger -> RawLedger +addLedgerTransaction t l0 = l0 { ledger_txns = t : (ledger_txns l0) } -addModifierEntry :: ModifierEntry -> RawLedger -> RawLedger -addModifierEntry me l0 = l0 { modifier_entries = me : (modifier_entries l0) } +addModifierTransaction :: ModifierTransaction -> RawLedger -> RawLedger +addModifierTransaction mt l0 = l0 { modifier_txns = mt : (modifier_txns l0) } -addPeriodicEntry :: PeriodicEntry -> RawLedger -> RawLedger -addPeriodicEntry pe l0 = l0 { periodic_entries = pe : (periodic_entries l0) } +addPeriodicTransaction :: PeriodicTransaction -> RawLedger -> RawLedger +addPeriodicTransaction pt l0 = l0 { periodic_txns = pt : (periodic_txns l0) } addHistoricalPrice :: HistoricalPrice -> RawLedger -> RawLedger addHistoricalPrice h l0 = l0 { historical_prices = h : (historical_prices l0) } @@ -54,8 +55,8 @@ addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : (open_timelog_entries l0) } rawLedgerTransactions :: RawLedger -> [Transaction] -rawLedgerTransactions = txnsof . entries - where txnsof es = concat $ map flattenEntry $ zip es [1..] +rawLedgerTransactions = txnsof . ledger_txns + where txnsof ts = concat $ map flattenLedgerTransaction $ zip ts [1..] rawLedgerAccountNamesUsed :: RawLedger -> [AccountName] rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions @@ -66,58 +67,58 @@ rawLedgerAccountNameTree :: RawLedger -> Tree AccountName rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l --- | Remove ledger entries we are not interested in. +-- | Remove ledger transactions we are not interested in. -- Keep only those which fall between the begin and end dates, and match -- the description pattern, and are cleared or real if those options are active. -filterRawLedger :: DateSpan -> [String] -> Bool -> Bool -> RawLedger -> RawLedger +filterRawLedger :: DateSpan -> [String] -> Maybe Bool -> Bool -> RawLedger -> RawLedger filterRawLedger span pats clearedonly realonly = - filterRawLedgerTransactionsByRealness realonly . - filterRawLedgerEntriesByClearedStatus clearedonly . - filterRawLedgerEntriesByDate span . - filterRawLedgerEntriesByDescription pats + filterRawLedgerPostingsByRealness realonly . + filterRawLedgerTransactionsByClearedStatus clearedonly . + filterRawLedgerTransactionsByDate span . + filterRawLedgerTransactionsByDescription pats --- | Keep only entries whose description matches the description patterns. -filterRawLedgerEntriesByDescription :: [String] -> RawLedger -> RawLedger -filterRawLedgerEntriesByDescription pats (RawLedger ms ps es tls hs f) = - RawLedger ms ps (filter matchdesc es) tls hs f - where matchdesc = matchpats pats . edescription +-- | Keep only ledger transactions whose description matches the description patterns. +filterRawLedgerTransactionsByDescription :: [String] -> RawLedger -> RawLedger +filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp) = + RawLedger ms ps (filter matchdesc ts) tls hs f fp + where matchdesc = matchpats pats . ltdescription --- | Keep only entries which fall between begin and end dates. --- We include entries on the begin date and exclude entries on the end +-- | Keep only ledger transactions which fall between begin and end dates. +-- We include transactions on the begin date and exclude transactions on the end -- date, like ledger. An empty date string means no restriction. -filterRawLedgerEntriesByDate :: DateSpan -> RawLedger -> RawLedger -filterRawLedgerEntriesByDate (DateSpan begin end) (RawLedger ms ps es tls hs f) = - RawLedger ms ps (filter matchdate es) tls hs f +filterRawLedgerTransactionsByDate :: DateSpan -> RawLedger -> RawLedger +filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp) = + RawLedger ms ps (filter matchdate ts) tls hs f fp where - matchdate e = (maybe True (edate e>=) begin) && (maybe True (edate e<) end) + matchdate t = (maybe True (ltdate t>=) begin) && (maybe True (ltdate t<) end) --- | Keep only entries with cleared status, if the flag is true, otherwise --- do no filtering. -filterRawLedgerEntriesByClearedStatus :: Bool -> RawLedger -> RawLedger -filterRawLedgerEntriesByClearedStatus False l = l -filterRawLedgerEntriesByClearedStatus True (RawLedger ms ps es tls hs f) = - RawLedger ms ps (filter estatus es) tls hs f +-- | Keep only ledger transactions which have the requested +-- cleared/uncleared status, if there is one. +filterRawLedgerTransactionsByClearedStatus :: Maybe Bool -> RawLedger -> RawLedger +filterRawLedgerTransactionsByClearedStatus Nothing rl = rl +filterRawLedgerTransactionsByClearedStatus (Just val) (RawLedger ms ps ts tls hs f fp) = + RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp --- | Strip out any virtual transactions, if the flag is true, otherwise do +-- | Strip out any virtual postings, if the flag is true, otherwise do -- no filtering. -filterRawLedgerTransactionsByRealness :: Bool -> RawLedger -> RawLedger -filterRawLedgerTransactionsByRealness False l = l -filterRawLedgerTransactionsByRealness True (RawLedger ms ps es tls hs f) = - RawLedger ms ps (map filtertxns es) tls hs f - where filtertxns e@Entry{etransactions=ts} = e{etransactions=filter isReal ts} +filterRawLedgerPostingsByRealness :: Bool -> RawLedger -> RawLedger +filterRawLedgerPostingsByRealness False l = l +filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp) = + RawLedger mts pts (map filtertxns ts) tls hs f fp + where filtertxns t@LedgerTransaction{ltpostings=ps} = t{ltpostings=filter isReal ps} --- | Strip out any transactions to accounts deeper than the specified depth --- (and any entries which have no transactions as a result). -filterRawLedgerTransactionsByDepth :: Int -> RawLedger -> RawLedger -filterRawLedgerTransactionsByDepth depth (RawLedger ms ps es tls hs f) = - RawLedger ms ps (filter (not . null . etransactions) $ map filtertxns es) tls hs f - where filtertxns e@Entry{etransactions=ts} = - e{etransactions=filter ((<= depth) . accountNameLevel . taccount) ts} +-- | Strip out any postings to accounts deeper than the specified depth +-- (and any ledger transactions which have no postings as a result). +filterRawLedgerPostingsByDepth :: Int -> RawLedger -> RawLedger +filterRawLedgerPostingsByDepth depth (RawLedger mts pts ts tls hs f fp) = + RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp + where filtertxns t@LedgerTransaction{ltpostings=ps} = + t{ltpostings=filter ((<= depth) . accountNameLevel . paccount) ps} --- | Keep only entries which affect accounts matched by the account patterns. -filterRawLedgerEntriesByAccount :: [String] -> RawLedger -> RawLedger -filterRawLedgerEntriesByAccount apats (RawLedger ms ps es tls hs f) = - RawLedger ms ps (filter (any (matchpats apats . taccount) . etransactions) es) tls hs f +-- | Keep only ledger transactions which affect accounts matched by the account patterns. +filterRawLedgerTransactionsByAccount :: [String] -> RawLedger -> RawLedger +filterRawLedgerTransactionsByAccount apats (RawLedger ms ps ts tls hs f fp) = + RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp -- | Give all a ledger's amounts their canonical display settings. That -- is, in each commodity, amounts will use the display settings of the @@ -125,10 +126,10 @@ -- detected. Also, amounts are converted to cost basis if that flag is -- active. canonicaliseAmounts :: Bool -> RawLedger -> RawLedger -canonicaliseAmounts costbasis l@(RawLedger ms ps es tls hs f) = RawLedger ms ps (map fixentry es) tls hs f +canonicaliseAmounts costbasis l@(RawLedger ms ps ts tls hs f fp) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp where - fixentry (Entry d s c de co ts pr) = Entry d s c de co (map fixrawtransaction ts) pr - fixrawtransaction (RawTransaction s ac a c t) = RawTransaction s ac (fixmixedamount a) c t + fixledgertransaction (LedgerTransaction d s c de co ts pr) = LedgerTransaction d s c de co (map fixrawposting ts) pr + fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t fixmixedamount (Mixed as) = Mixed $ map fixamount as fixamount = fixcommodity . (if costbasis then costOfAmount else id) fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! (symbol $ commodity a) @@ -141,11 +142,11 @@ commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] commoditieswithsymbol s = filter ((s==) . symbol) commodities commoditysymbols = nub $ map symbol commodities - commodities = map commodity $ concatMap (amounts . amount) $ rawLedgerTransactions l + commodities = map commodity $ concatMap (amounts . tamount) $ rawLedgerTransactions l -- | Get just the amounts from a ledger, in the order parsed. rawLedgerAmounts :: RawLedger -> [MixedAmount] -rawLedgerAmounts = map amount . rawLedgerTransactions +rawLedgerAmounts = map tamount . rawLedgerTransactions -- | Get just the ammount commodities from a ledger, in the order parsed. rawLedgerCommodities :: RawLedger -> [Commodity] @@ -157,8 +158,17 @@ -- | Close any open timelog sessions using the provided current time. rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger -rawLedgerConvertTimeLog t l0 = l0 { entries = convertedTimeLog ++ entries l0 +rawLedgerConvertTimeLog t l0 = l0 { ledger_txns = convertedTimeLog ++ ledger_txns l0 , open_timelog_entries = [] } where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 + +-- | The date span containing all the raw ledger's transactions, +-- or DateSpan Nothing Nothing if there are none. +rawLedgerDateSpan :: RawLedger -> DateSpan +rawLedgerDateSpan rl + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just $ ltdate $ head ts) (Just $ addDays 1 $ ltdate $ last ts) + where + ts = sortBy (comparing ltdate) $ ledger_txns rl diff --git a/Ledger/RawTransaction.hs b/Ledger/RawTransaction.hs deleted file mode 100644 --- a/Ledger/RawTransaction.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| - -A 'RawTransaction' represents a single transaction line within a ledger -entry. We call it raw to distinguish from the cached 'Transaction'. - --} - -module Ledger.RawTransaction -where -import Ledger.Utils -import Ledger.Types -import Ledger.Amount -import Ledger.AccountName - - -instance Show RawTransaction where show = showRawTransaction - -nullrawtxn = RawTransaction False "" nullmixedamt "" RegularTransaction - -showRawTransaction :: RawTransaction -> String -showRawTransaction (RawTransaction s a amt _ ttype) = - concatTopPadded [showaccountname a ++ " ", showamount amt] - where - showaccountname = printf "%-22s" . bracket . elideAccountName width - (bracket,width) = case ttype of - BalancedVirtualTransaction -> (\s -> "["++s++"]", 20) - VirtualTransaction -> (\s -> "("++s++")", 20) - otherwise -> (id,22) - showamount = padleft 12 . showMixedAmountOrZero - -isReal :: RawTransaction -> Bool -isReal t = rttype t == RegularTransaction - -hasAmount :: RawTransaction -> Bool -hasAmount = (/= missingamt) . tamount diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -1,8 +1,8 @@ {-| -A 'TimeLog' is a parsed timelog file (see timeclock.el or the command-line -version) containing zero or more 'TimeLogEntry's. It can be converted to a -'RawLedger' for querying. +A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog +file (see timeclock.el or the command-line version). These can be +converted to 'LedgerTransactions' and queried like a ledger. -} @@ -13,24 +13,36 @@ import Ledger.Dates import Ledger.Commodity import Ledger.Amount -import Ledger.Entry +import Ledger.LedgerTransaction instance Show TimeLogEntry where show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) -instance Show TimeLog where - show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl +instance Show TimeLogCode where + show SetBalance = "b" + show SetRequiredHours = "h" + show In = "i" + show Out = "o" + show FinalOut = "O" --- | Convert time log entries to ledger entries. When there is no +instance Read TimeLogCode where + readsPrec _ ('b' : xs) = [(SetBalance, xs)] + readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)] + readsPrec _ ('i' : xs) = [(In, xs)] + readsPrec _ ('o' : xs) = [(Out, xs)] + readsPrec _ ('O' : xs) = [(FinalOut, xs)] + readsPrec _ _ = [] + +-- | Convert time log entries to ledger transactions. When there is no -- clockout, add one with the provided current time. Sessions crossing -- midnight are split into days to give accurate per-day totals. -entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Entry] +entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [LedgerTransaction] entriesFromTimeLogEntries _ [] = [] entriesFromTimeLogEntries now [i] | odate > idate = [entryFromTimeLogInOut i o'] ++ entriesFromTimeLogEntries now [i',o] | otherwise = [entryFromTimeLogInOut i o] where - o = TimeLogEntry 'o' end "" + o = TimeLogEntry Out end "" end = if itime > now then itime else now (itime,otime) = (tldatetime i,tldatetime o) (idate,odate) = (localDay itime,localDay otime) @@ -48,20 +60,20 @@ -- | Convert a timelog clockin and clockout entry to an equivalent ledger -- entry, representing the time expenditure. Note this entry is not balanced, -- since we omit the \"assets:time\" transaction for simpler output. -entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Entry +entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> LedgerTransaction entryFromTimeLogInOut i o - | otime >= itime = e + | otime >= itime = t | otherwise = - error $ "clock-out time less than clock-in time in:\n" ++ showEntry e + error $ "clock-out time less than clock-in time in:\n" ++ showLedgerTransaction t where - e = Entry { - edate = idate, - estatus = True, - ecode = "", - edescription = showtime itod ++ "-" ++ showtime otod, - ecomment = "", - etransactions = txns, - epreceding_comment_lines="" + t = LedgerTransaction { + ltdate = idate, + ltstatus = True, + ltcode = "", + ltdescription = showtime itod ++ "-" ++ showtime otod, + ltcomment = "", + ltpostings = ps, + ltpreceding_comment_lines="" } showtime = take 5 . show acctname = tlcomment i @@ -73,6 +85,6 @@ odate = localDay otime hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] - txns = [RawTransaction False acctname amount "" RegularTransaction - --,RawTransaction "assets:time" (-amount) "" RegularTransaction + ps = [Posting False acctname amount "" RegularPosting + --,Posting "assets:time" (-amount) "" RegularPosting ] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -1,17 +1,21 @@ {-| -A 'Transaction' is a 'RawTransaction' with its parent 'Entry' \'s date and -description attached. These are what we actually query when doing reports. +A compound data type for efficiency. A 'Transaction' is a 'Posting' with +its parent 'LedgerTransaction' \'s date and description attached. The +\"transaction\" term is pretty ingrained in the code, docs and with users, +so we've kept it. These are what we work with most of the time when doing +reports. -} module Ledger.Transaction where +import Ledger.Dates import Ledger.Utils import Ledger.Types import Ledger.Dates -import Ledger.Entry -import Ledger.RawTransaction +import Ledger.LedgerTransaction +import Ledger.Posting import Ledger.Amount @@ -22,17 +26,26 @@ s ++ unwords [showDate d,desc,a,show amt,show ttype] where s = if stat then " *" else "" --- | Convert a 'Entry' to two or more 'Transaction's. An id number +-- | Convert a 'LedgerTransaction' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should -- be unique per entry. -flattenEntry :: (Entry, Int) -> [Transaction] -flattenEntry (Entry d s _ desc _ ts _, e) = - [Transaction e s d desc (taccount t) (tamount t) (rttype t) | t <- ts] +flattenLedgerTransaction :: (LedgerTransaction, Int) -> [Transaction] +flattenLedgerTransaction (LedgerTransaction d s _ desc _ ps _, n) = + [Transaction n s d desc (paccount p) (pamount p) (ptype p) | p <- ps] accountNamesFromTransactions :: [Transaction] -> [AccountName] -accountNamesFromTransactions ts = nub $ map account ts +accountNamesFromTransactions ts = nub $ map taccount ts sumTransactions :: [Transaction] -> MixedAmount -sumTransactions = sum . map amount +sumTransactions = sum . map tamount -nulltxn = Transaction 0 False (parsedate "1900/1/1") "" "" nullmixedamt RegularTransaction +nulltxn :: Transaction +nulltxn = Transaction 0 False (parsedate "1900/1/1") "" "" nullmixedamt RegularPosting + +-- | Does the given transaction fall within the given date span ? +isTransactionInDateSpan :: DateSpan -> Transaction -> Bool +isTransactionInDateSpan (DateSpan Nothing Nothing) _ = True +isTransactionInDateSpan (DateSpan Nothing (Just e)) (Transaction{tdate=d}) = d=b +isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{tdate=d}) = d>=b && d width of @@ -241,7 +246,7 @@ tz <- getCurrentTimeZone return $ utcToLocalTime tz t - +-- misc isLeft :: Either a b -> Bool isLeft (Left _) = True @@ -250,3 +255,5 @@ isRight :: Either a b -> Bool isRight = not . isLeft +strictReadFile :: FilePath -> IO String +strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s diff --git a/Options.hs b/Options.hs --- a/Options.hs +++ b/Options.hs @@ -1,77 +1,84 @@ {-# OPTIONS_GHC -cpp #-} +{-| +Command-line options for the application. +-} + module Options where import System import System.Console.GetOpt -import System.Directory 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.Utils import Ledger.Types import Ledger.Dates +import Codec.Binary.UTF8.String (decodeString) +import Control.Monad (liftM) progname = "hledger" -ledgerpath = "~/.ledger" -ledgerenvvar = "LEDGER" timeprogname = "hours" -timelogpath = "~/.timelog" -timelogenvvar = "TIMELOG" -usagehdr = printf ( - "Usage: one of\n" ++ - " %s [OPTIONS] COMMAND [PATTERNS]\n" ++ - " %s [OPTIONS] [PERIOD [COMMAND [PATTERNS]]]\n" ++ +usagehdr = ( + "Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++ + " hours [OPTIONS] [COMMAND [PATTERNS]]\n" ++ + " hledger convert CSVFILE ACCOUNTNAME RULESFILE\n" ++ "\n" ++ + "hledger uses your ~/.ledger or $LEDGER file (or another specified with -f),\n" ++ + "while hours uses your ~/.timelog or $TIMELOG file.\n" ++ + "\n" ++ "COMMAND is one of (may be abbreviated):\n" ++ - " balance - show account balances\n" ++ - " print - show formatted ledger entries\n" ++ - " register - show register transactions\n" ++ + " add - prompt for new transactions and add them to the ledger\n" ++ + " balance - show accounts, with balances\n" ++ + " convert - convert CSV data to ledger format and print on stdout\n" ++ + " 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" ++ #ifdef VTY - " ui - run a simple curses-based text ui\n" ++ + " ui - run a simple curses-based text ui\n" ++ #endif #ifdef HAPPS - " web - run a simple web ui\n" ++ + " web - run a simple web ui\n" ++ #endif - " test - run self-tests\n" ++ + " test - run self-tests\n" ++ "\n" ++ "PATTERNS are regular expressions which filter by account name.\n" ++ - "Or, prefix with desc: to filter by entry description.\n" ++ - "Or, prefix with not: to negate a pattern. (When using both, not: comes last.)\n" ++ + "Prefix with desc: to filter by transaction description instead.\n" ++ + "Prefix with not: to negate a pattern. When using both, not: comes last.\n" ++ "\n" ++ - "Dates can be y/m/d or ledger-style smart dates like \"last month\".\n" ++ + "DATES can be y/m/d or ledger-style smart dates like \"last month\".\n" ++ "\n" ++ "Options:" - ) progname timeprogname - - -usageftr = printf ( - "\n" ) - +usageftr = "" usage = usageInfo usagehdr options ++ usageftr -- | Command-line options we accept. options :: [OptDescr Opt] options = [ - Option ['f'] ["file"] (ReqArg File "FILE") filehelp - ,Option ['b'] ["begin"] (ReqArg Begin "DATE") "report on entries on or after this date" - ,Option ['e'] ["end"] (ReqArg End "DATE") "report on entries prior to this date" - ,Option ['p'] ["period"] (ReqArg Period "EXPR") ("report on entries during the specified period\n" ++ + Option ['f'] ["file"] (ReqArg File "FILE") "use a different ledger/timelog file; - means stdin" + ,Option ['b'] ["begin"] (ReqArg Begin "DATE") "report on transactions on or after this date" + ,Option ['e'] ["end"] (ReqArg End "DATE") "report on transactions before this date" + ,Option ['p'] ["period"] (ReqArg Period "EXPR") ("report on transactions during the specified period\n" ++ "and/or with the specified reporting interval\n") - ,Option ['C'] ["cleared"] (NoArg Cleared) "report only on cleared entries" + ,Option ['C'] ["cleared"] (NoArg Cleared) "report only on cleared transactions" + ,Option ['U'] ["uncleared"] (NoArg UnCleared) "report only on uncleared transactions" ,Option ['B'] ["cost","basis"] (NoArg CostBasis) "report cost of commodities" ,Option [] ["depth"] (ReqArg Depth "N") "hide accounts/transactions deeper than this" - ,Option ['d'] ["display"] (ReqArg Display "EXPR") ("show only transactions matching simple EXPR\n" ++ - "(where EXPR is 'dOP[DATE]', OP is <, <=, =, >=, >)") + ,Option ['d'] ["display"] (ReqArg Display "EXPR") ("show only transactions matching EXPR (where\n" ++ + "EXPR is 'dOP[DATE]' and OP is <, <=, =, >=, >)") ,Option ['E'] ["empty"] (NoArg Empty) "show empty/zero things which are normally elided" ,Option ['R'] ["real"] (NoArg Real) "report only on real (non-virtual) transactions" ,Option [] ["no-total"] (NoArg NoTotal) "balance report: hide the final total" -- ,Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts" ,Option ['W'] ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary" ,Option ['M'] ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary" + ,Option ['Q'] ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary" ,Option ['Y'] ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary" ,Option ['h'] ["help"] (NoArg Help) "show this help" ,Option ['V'] ["version"] (NoArg Version) "show version information" @@ -79,11 +86,6 @@ ,Option [] ["debug"] (NoArg Debug) "show some debug output" ,Option [] ["debug-no-ui"] (NoArg DebugNoUI) "run ui commands with no output" ] - where - filehelp = printf (intercalate "\n" - ["ledger file; default is the %s env. variable's" - ,"value, or %s. - means use standard input." - ]) ledgerenvvar ledgerpath -- | An option value from a command-line flag. data Opt = @@ -92,6 +94,7 @@ End {value::String} | Period {value::String} | Cleared | + UnCleared | CostBasis | Depth {value::String} | Display {value::String} | @@ -101,6 +104,7 @@ SubTotal | WeeklyOpt | MonthlyOpt | + QuarterlyOpt | YearlyOpt | Help | Verbose | @@ -109,10 +113,13 @@ | DebugNoUI deriving (Show,Eq) --- yow.. +-- these make me nervous optsWithConstructor f opts = concatMap get opts where get o = if f v == o then [o] else [] where v = value o +optsWithConstructors fs opts = concatMap get opts + where get o = if any (\f -> f == o) fs then [o] else [] + optValuesForConstructor f opts = concatMap get opts where get o = if f v == o then [v] else [] where v = value o @@ -120,29 +127,19 @@ where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o -- | Parse the command-line arguments into options, command name, and --- command arguments. Any dates in the options are converted to full --- YYYY/MM/DD format, while we are in the IO monad and can get the current --- time. Arguments are parsed differently if the program was invoked as --- \"hours\". +-- command arguments. Any dates in the options are converted to explicit +-- YYYY/MM/DD format based on the current time. parseArguments :: IO ([Opt], String, [String]) parseArguments = do - args <- getArgs - istimequery <- usingTimeProgramName + args <- liftM (map decodeString) getArgs let (os,as,es) = getOpt Permute options args - os' <- fixOptDates os - case istimequery of - False -> - case (os,as,es) of - (opts,cmd:args,[]) -> return (os',cmd,args) - (opts,[],[]) -> return (os',"",[]) - (opts,_,errs) -> ioError (userError (concat errs ++ usage)) - True -> - case (os,as,es) of - (opts,p:cmd:args,[]) -> return (os' ++ [Period p],cmd,args) - (opts,p:args,[]) -> return ([Period p,SubTotal] ++ os',"balance",args) - (opts,[],[]) -> return ([Period "today",SubTotal] ++ os',"balance",[]) - (opts,_,errs) -> ioError (userError (concat errs ++ usage)) - +-- istimequery <- usingTimeProgramName +-- let os' = if istimequery then (Period "today"):os else os + os'' <- fixOptDates os + case (as,es) of + (cmd:args,[]) -> return (os'',cmd,args) + ([],[]) -> return (os'',"",[]) + (_,errs) -> ioError (userError (concat errs ++ usage)) -- | Convert any fuzzy dates within these option values to explicit ones, -- based on today's date. @@ -183,10 +180,11 @@ | otherwise = case last otheropts of WeeklyOpt -> Weekly MonthlyOpt -> Monthly + QuarterlyOpt -> Quarterly YearlyOpt -> Yearly where popts = optValuesForConstructor Period opts - otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,YearlyOpt]) opts + otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- doesn't affect the interval, but parsePeriodExpr needs something refdate = parsedate "0001/01/01" @@ -204,6 +202,12 @@ listtomaybe [] = Nothing listtomaybe vs = Just $ last vs +-- | Get a maybe boolean representing the last cleared/uncleared option if any. +clearedValueFromOpts opts | null os = Nothing + | last os == Cleared = Just True + | otherwise = Just False + where os = optsWithConstructors [Cleared,UnCleared] opts + -- | Was the program invoked via the \"hours\" alias ? usingTimeProgramName :: IO Bool usingTimeProgramName = do @@ -214,34 +218,28 @@ ledgerFilePathFromOpts :: [Opt] -> IO String ledgerFilePathFromOpts opts = do istimequery <- usingTimeProgramName - let (e,d) = if istimequery - then (timelogenvvar,timelogpath) - else (ledgerenvvar,ledgerpath) - envordefault <- getEnv e `catch` \_ -> return d - paths <- mapM tildeExpand $ [envordefault] ++ optValuesForConstructor File opts - return $ last paths - --- | 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 + f <- if istimequery then myTimelogPath else myLedgerPath + return $ last $ f:(optValuesForConstructor File opts) --- | Gather any pattern arguments into a list of account patterns and a --- list of description patterns. For now we interpret pattern arguments as +-- | Gather filter pattern arguments into a list of account patterns and a +-- list of description patterns. We interpret pattern arguments as -- follows: those prefixed with "desc:" are description patterns, all --- others are account patterns. Also patterns prefixed with "not:" are +-- others are account patterns; also patterns prefixed with "not:" are -- negated. not: should come after desc: if both are used. --- This is different from ledger 2 and 3. -parseAccountDescriptionArgs :: [Opt] -> [String] -> ([String],[String]) -parseAccountDescriptionArgs opts args = (as, ds') +parsePatternArgs :: [String] -> ([String],[String]) +parsePatternArgs args = (as, ds') where descprefix = "desc:" (ds, as) = partition (descprefix `isPrefixOf`) args ds' = map (drop (length descprefix)) ds + +-- | Convert application options to more generic types for the library. +optsToIOArgs :: [Opt] -> [String] -> LocalTime -> IOArgs +optsToIOArgs opts args t = (dateSpanFromOpts (localDay t) opts + ,clearedValueFromOpts opts + ,Real `elem` opts + ,CostBasis `elem` opts + ,apats + ,dpats + ) where (apats,dpats) = parsePatternArgs args diff --git a/PrintCommand.hs b/PrintCommand.hs --- a/PrintCommand.hs +++ b/PrintCommand.hs @@ -6,20 +6,22 @@ module PrintCommand where +import Prelude hiding (putStr) import Ledger import Options +import System.IO.UTF8 --- | Print ledger entries in standard format. +-- | Print ledger transactions in standard format. print' :: [Opt] -> [String] -> Ledger -> IO () -print' opts args l = putStr $ showEntries opts args l +print' opts args l = putStr $ showLedgerTransactions opts args l -showEntries :: [Opt] -> [String] -> Ledger -> String -showEntries opts args l = concatMap showEntry $ filteredentries +showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String +showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns where - filteredentries = entries $ - filterRawLedgerTransactionsByDepth depth $ - filterRawLedgerEntriesByAccount apats $ + filteredtxns = ledger_txns $ + filterRawLedgerPostingsByDepth depth $ + filterRawLedgerTransactionsByAccount apats $ rawledger l depth = depthFromOpts opts - (apats,_) = parseAccountDescriptionArgs opts args + (apats,_) = parsePatternArgs args diff --git a/README b/README --- a/README +++ b/README @@ -15,24 +15,20 @@ Installation ------------ -Building hledger requires GHC (http://haskell.org/ghc); it is known to -build with GHC 6.8 and up. hledger should work on any platform which GHC -supports. - -Also, installing hledger easily requires the "cabal" command-line tool, -version 0.6.0 and up (http://www.haskell.org/cabal/download.html). (You -can manually download and install each dependency mentioned in -hledger.cabal from hackage.org, but installing cabal is much quicker.) +Platform binaries are not yet being published; you could try asking for +one on the #ledger channel. -Here's how to download and install the latest hledger release:: +Building hledger requires GHC 6.8 or later (http://haskell.org/ghc). +hledger should work on any platform which GHC supports. +Also, installing hledger's dependencies easily requires cabal-install +version 0.6 or later (http://www.haskell.org/cabal/download.html). +Once these tools are installed on your system, do:: cabal update - cabal install hledger (add -f happs to include the web ui) - -Or, to get the latest development code:: - - darcs get http://joyful.com/repos/hledger + cabal install hledger [-fvty] [-fhapps] +The vty and happs flags are optional; they enable hledger's "ui" and "web" +commands respectively. vty is not available on the windows platform. Usage ----- @@ -41,47 +37,50 @@ different file, specify it with the LEDGER environment variable or -f option (which may be - for standard input). Basic usage is:: - hledger [OPTIONS] COMMAND [PATTERNS] + hledger [OPTIONS] [COMMAND [PATTERNS]] -where COMMAND is one of balance, print, register, ui, web, test; and -PATTERNS are zero or more regular expressions used to narrow the results. -Here are some commands to try:: +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:: - hledger --help export LEDGER=sample.ledger - hledger balance - hledger bal --depth 1 - hledger register - hledger reg income - hledger reg desc:shop - hledger ui - hledger web # if you installed with -f happs + hledger --help # show usage & options + hledger balance # all accounts with aggregated balances + hledger bal --depth 1 # only top-level accounts + hledger register # transaction register + hledger reg income # transactions to/from an income account + 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 Time reporting -------------- + hledger will also read timeclock.el-format timelog entries. As a -convenience, if you invoke the hledger executable via a link or copy named -"hours", it looks for your timelog file (~/.timelog, or the file specified -by $TIMELOG or -f), and parses arguments slightly differently:: +convenience, if you invoke hledger via a link or copy named "hours", it +uses your timelog file (~/.timelog or $TIMELOG) by default.:: - hours [OPTIONS] [PERIOD [COMMAND [PATTERNS]]] + hours [OPTIONS] [COMMAND [PATTERNS]] -where PERIOD is a ledger-style period expression, defaulting to "today", -and COMMAND is one of the commands above. Timelog entries look like this:: +Timelog entries look like this:: i 2009/03/31 22:21:45 some:project o 2009/04/01 02:00:34 -The clock-in project is treated as an account. Here are some time queries to try:: +The clockin description is treated as an account name. Here are some +queries to try:: - export TIMELOG=/my/timelog # if it's not ~/.timelog - hours # today's balances - hours today # the same - hours 'this week' # so far this week - hours lastmonth # the space is optional - hours 'from 1/15' register # sessions since last january 15 - hours 'monthly in 2009' reg --depth 1 # monthly time summary, top level only + ln -s `which hledger` ~/bin/hours # add the "hours" symlink 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 Features -------- @@ -128,6 +127,9 @@ 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 + convert convert CSV bank data to ledger journal format ui a simple interactive text ui (only on unix platforms) web a simple web ui test run self-tests @@ -136,7 +138,7 @@ ............................. ledger features not currently supported include: modifier and periodic -entries, and options such as these:: +entries, and the following options and commands:: Basic options: -o, --output FILE write output to FILE @@ -209,3 +211,6 @@ * hledger always shows timelog balances in hours * hledger splits multi-day timelog sessions at midnight * 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 diff --git a/RegisterCommand.hs b/RegisterCommand.hs --- a/RegisterCommand.hs +++ b/RegisterCommand.hs @@ -6,10 +6,12 @@ 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. @@ -33,18 +35,17 @@ | otherwise = showtxns summaryts nulltxn startbal where interval = intervalFromOpts opts - ts = sort $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l - where sort = sortBy (\a b -> compare (date a) (date b)) - filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ account t) <= depth) + 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 . amount) + | otherwise = filter (not . isZeroMixedAmount . tamount) (precedingts, ts') = break (matchdisplayopt dopt) ts (displayedts, _) = span (matchdisplayopt dopt) ts' startbal = sumTransactions precedingts - matchapats t = matchpats apats $ account t - apats = fst $ parseAccountDescriptionArgs opts args + 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 @@ -62,7 +63,7 @@ -- 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 entryno value is provided so that the new transactions will be +-- 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 @@ -71,54 +72,47 @@ -- 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) entryno depth showempty ts +summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts | null ts && showempty = [txn] | null ts = [] | otherwise = summaryts' where - txn = nulltxn{entryno=entryno, date=b', description="- "++(showDate $ addDays (-1) e')} - b' = fromMaybe (date $ head ts) b - e' = fromMaybe (date $ last ts) e + 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 . amount) summaryts - txnanames = sort $ nub $ map account ts + | 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{account=a,amount=balancetoshowfor a} | a <- clippedanames] + 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 --- | Does the given transaction fall within the given date span ? -isTransactionInDateSpan :: DateSpan -> Transaction -> Bool -isTransactionInDateSpan (DateSpan Nothing Nothing) _ = True -isTransactionInDateSpan (DateSpan Nothing (Just e)) (Transaction{date=d}) = d=b -isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{date=d}) = d>=b && d Transaction -> MixedAmount -> String -showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n" +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 - txn = showRawTransaction $ RawTransaction s a amt "" tt + p = showPosting $ Posting s a amt "" tt bal = padleft 12 (showMixedAmountOrZero b) - Transaction{status=s,date=da,description=de,account=a,amount=amt,ttype=tt} = t + 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 @@ -18,8 +18,8 @@ - not platform independent -All doctests are included below. Some of these may also appear in other -modules as examples within the api docs. +Here are the hledger doctests (some may reappear in other modules as +examples): Run a few with c++ ledger first: @@ -80,7 +80,67 @@ $-2 income $1 liabilities @ +-} +{- +@ +$ 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: +2009/01/01 a + b 1.1 + c -1 + +@ + +Unicode input/output tests + +-- layout of the balance command with unicode names +@ +$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - bal + 10 руб τράπεζα + -10 руб नकद +@ + +-- layout of the register command with unicode names +@ +$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - reg +2009/01/01 проверка τράπεζα 10 руб 10 руб + नकद -10 руб 0 +@ + +-- layout of the print command with unicode names +@ +$ printf "2009-01-01 проверка\n счёт:первый 1\n счёт:второй\n" | hledger -f - print +2009/01/01 проверка + счёт:первый 1 + счёт:второй + +@ + +-- search for unicode account names +@ +$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - reg τράπ +2009/01/01 проверка τράπεζα 10 руб 10 руб +@ + +-- search for unicode descriptions (should choose only the first entry) +@ +$ printf "2009-01-01 аура (cyrillic letters)\n bank 10\n cash\n2010-01-01 aypa (roman letters)\n bank 20\n cash\n" | hledger -f - reg desc:аура +2009/01/01 аура (cyrillic let.. bank 10 10 + cash -10 0 +@ + +-- error message with unicode in ledger +-- not implemented yet +--@ +$ printf "2009-01-01 broken entry\n дебит 1\n кредит -2\n" | hledger -f - 2>&1 ; true +hledger: could not balance this transaction, amounts do not add up to zero: +2009/01/01 broken entry + дебит 1 + кредит -2 + + +--@ -} -- other test tools: -- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework @@ -129,20 +189,23 @@ -- | Simple way to assert something is some expected value, with no label. is :: (Eq a, Show a) => a -> a -> Assertion -a `is` e = assertEqual "" a e +a `is` e = assertEqual "" e a -- | Assert a parse result is some expected value, or print a parse error. parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion parse `parseis` expected = either printParseError (`is` expected) parse +parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a +parseWithCtx p ts = runParser p emptyCtx "" ts + ------------------------------------------------------------------------------ -- | Tests for any function or topic. Mostly ordered by test name. tests :: [Test] tests = [ "account directive" ~: - let sameParse str1 str2 = do l1 <- rawledgerfromstring str1 - l2 <- rawledgerfromstring str2 + let sameParse str1 str2 = do l1 <- rawLedgerFromString str1 + l2 <- rawLedgerFromString str2 l1 `is` l2 in TestList [ @@ -320,7 +383,7 @@ ] ,"balance report with cost basis" ~: do - rl <- rawledgerfromstring $ unlines + rl <- rawLedgerFromString $ unlines ["" ,"2008/1/1 test " ," a:b 10h @ $50" @@ -328,7 +391,7 @@ ,"" ] let l = cacheLedger [] $ - filterRawLedger (DateSpan Nothing Nothing) [] False False $ + filterRawLedger (DateSpan Nothing Nothing) [] Nothing False $ canonicaliseAmounts True rl -- enable cost basis adjustment showBalanceReport [] [] l `is` unlines @@ -337,7 +400,7 @@ ] ,"balance report elides zero-balance root account(s)" ~: do - l <- ledgerfromstringwithopts [] [] sampletime + l <- ledgerFromStringWithOpts [] [] sampletime (unlines ["2008/1/1 one" ," test:a 1" @@ -351,28 +414,28 @@ ] - ,"balanceEntry" ~: do + ,"balanceLedgerTransaction" ~: do assertBool "detect unbalanced entry, sign error" - (isLeft $ balanceEntry - (Entry (parsedate "2007/01/28") False "" "test" "" - [RawTransaction False "a" (Mixed [dollars 1]) "" RegularTransaction, - RawTransaction False "b" (Mixed [dollars 1]) "" RegularTransaction + (isLeft $ balanceLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "test" "" + [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, + Posting False "b" (Mixed [dollars 1]) "" RegularPosting ] "")) assertBool "detect unbalanced entry, multiple missing amounts" - (isLeft $ balanceEntry - (Entry (parsedate "2007/01/28") False "" "test" "" - [RawTransaction False "a" missingamt "" RegularTransaction, - RawTransaction False "b" missingamt "" RegularTransaction + (isLeft $ balanceLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "test" "" + [Posting False "a" missingamt "" RegularPosting, + Posting False "b" missingamt "" RegularPosting ] "")) - let e = balanceEntry (Entry (parsedate "2007/01/28") False "" "test" "" - [RawTransaction False "a" (Mixed [dollars 1]) "" RegularTransaction, - RawTransaction False "b" missingamt "" RegularTransaction + let e = balanceLedgerTransaction (LedgerTransaction (parsedate "2007/01/28") False "" "test" "" + [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, + Posting False "b" missingamt "" RegularPosting ] "") assertBool "one missing amount should be ok" (isRight e) assertEqual "balancing amount is added" (Mixed [dollars (-1)]) (case e of - Right e' -> (tamount $ last $ etransactions e') + Right e' -> (pamount $ last $ ltpostings e') Left _ -> error "should not happen") ,"cacheLedger" ~: do @@ -397,11 +460,11 @@ let now = utcToLocalTime tz now' nowstr = showtime now yesterday = prevday today - clockin t a = TimeLogEntry 'i' t a - clockout t = TimeLogEntry 'o' t "" + 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 edescription $ entriesFromTimeLogEntries now es) + assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es) assertEntriesGiveStrings "started yesterday, split session at midnight" [clockin (mktime yesterday "23:00:00") ""] @@ -427,9 +490,11 @@ [] `gives` NoInterval [WeeklyOpt] `gives` Weekly [MonthlyOpt] `gives` Monthly + [QuarterlyOpt] `gives` Quarterly [YearlyOpt] `gives` Yearly [Period "weekly"] `gives` Weekly [Period "monthly"] `gives` Monthly + [Period "quarterly"] `gives` Quarterly [WeeklyOpt, Period "yearly"] `gives` Yearly ,"isAccountNamePrefixOf" ~: do @@ -438,6 +503,52 @@ "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False + ,"isLedgerTransactionBalanced" ~: do + assertBool "detect balanced" + (isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting + ] "")) + assertBool "detect unbalanced" + (not $ isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting + ] "")) + assertBool "detect unbalanced, one posting" + (not $ isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ] "")) + assertBool "one zero posting is considered balanced for now" + (isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 0]) "" RegularPosting + ] "")) + assertBool "virtual postings don't need to balance" + (isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting + ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting + ] "")) + assertBool "balanced virtual postings need to balance among themselves" + (not $ isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting + ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting + ] "")) + assertBool "balanced virtual postings need to balance among themselves (2)" + (isLedgerTransactionBalanced + (LedgerTransaction (parsedate "2009/01/01") False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting + ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting + ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting + ] "")) + ,"isSubAccountNameOf" ~: do "assets" `isSubAccountNameOf` "assets" `is` False "assets:bank" `isSubAccountNameOf` "assets" `is` True @@ -445,19 +556,32 @@ "assets:bank" `isSubAccountNameOf` "my assets" `is` False ,"default year" ~: do - rl <- rawledgerfromstring defaultyear_ledger_str - (edate $ head $ entries rl) `is` fromGregorian 2009 1 1 + rl <- rawLedgerFromString defaultyear_ledger_str + (ltdate $ head $ ledger_txns rl) `is` fromGregorian 2009 1 1 return () - ,"ledgerEntry" ~: do - parseWithCtx ledgerEntry entry1_str `parseis` entry1 + ,"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 ,"ledgerHistoricalPrice" ~: do parseWithCtx ledgerHistoricalPrice price1_str `parseis` price1 - ,"ledgertransaction" ~: do - parseWithCtx ledgertransaction rawtransaction1_str `parseis` rawtransaction1 + ,"ledgerTransaction" ~: do + parseWithCtx ledgerTransaction entry1_str `parseis` entry1 + assertBool "ledgerTransaction should not parse just a date" + $ isLeft $ parseWithCtx ledgerTransaction "2009/1/1\n" + assertBool "ledgerTransaction should require some postings" + $ isLeft $ parseWithCtx ledgerTransaction "2009/1/1 a\n" + 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 + ,"ledgerposting" ~: do + parseWithCtx ledgerposting rawposting1_str `parseis` rawposting1 + ,"parsedate" ~: do parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate @@ -478,18 +602,18 @@ do let args = ["expenses"] l <- sampleledgerwithopts [] args - showEntries [] args l `is` unlines + showLedgerTransactions [] args l `is` unlines ["2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" - ," assets:cash $-2" + ," assets:cash" ,"" ] , "print report with depth arg" ~: do l <- sampleledger - showEntries [Depth "2"] [] l `is` unlines + showLedgerTransactions [Depth "2"] [] l `is` unlines ["2008/01/01 income" ," income:salary $-1" ,"" @@ -499,7 +623,7 @@ ,"2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" - ," assets:cash $-2" + ," assets:cash" ,"" ,"2008/12/31 * pay off" ," liabilities:debts $1" @@ -537,9 +661,32 @@ ," assets:bank:checking $-1 0" ] + ,"register report with cleared arg" ~: + do + l <- ledgerFromStringWithOpts [Cleared] [] sampletime sample_ledger_str + showRegisterReport [Cleared] [] l `is` unlines + ["2008/06/03 eat & shop expenses:food $1 $1" + ," expenses:supplies $1 $2" + ," assets:cash $-2 0" + ,"2008/12/31 pay off liabilities:debts $1 $1" + ," assets:bank:checking $-1 0" + ] + + ,"register report with uncleared arg" ~: + do + l <- ledgerFromStringWithOpts [UnCleared] [] sampletime sample_ledger_str + showRegisterReport [UnCleared] [] l `is` unlines + ["2008/01/01 income assets:bank:checking $1 $1" + ," income:salary $-1 0" + ,"2008/06/01 gift assets:bank:checking $1 $1" + ," income:gifts $-1 0" + ,"2008/06/02 save assets:bank:saving $1 $1" + ," assets:bank:checking $-1 0" + ] + ,"register report sorts by date" ~: do - l <- ledgerfromstringwithopts [] [] sampletime $ unlines + l <- ledgerFromStringWithOpts [] [] sampletime $ unlines ["2008/02/02 a" ," b 1" ," c" @@ -586,6 +733,7 @@ "2007" `gives` [] "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] + "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] showRegisterReport [Period "yearly"] [] l `is` unlines ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ," assets:cash $-2 $-1" @@ -616,6 +764,67 @@ ,"show hours" ~: show (hours 1) ~?= "1.0h" + ,"showLedgerTransaction" ~: do + assertEqual "show a balanced transaction, eliding last amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking" + ,"" + ]) + (showLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting + ] "")) + -- document some cases that arise in debug/testing: + assertEqual "show an unbalanced transaction, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.19" + ,"" + ]) + (showLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting + ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting + ] "")) + assertEqual "show an unbalanced transaction with one posting, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ,"" + ]) + (showLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting + ] "")) + assertEqual "show a transaction with one posting and a missing amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries " + ,"" + ]) + (showLedgerTransaction + (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" "" + [Posting False "expenses:food:groceries" missingamt "" RegularPosting + ] "")) + + ,"unicode in balance layout" ~: do + l <- ledgerFromStringWithOpts [] [] sampletime + "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" + showBalanceReport [] [] l `is` unlines + [" -100 актив:наличные" + ," 100 расходы:покупки"] + + ,"unicode in register layout" ~: do + l <- ledgerFromStringWithOpts [] [] sampletime + "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" + showRegisterReport [] [] l `is` unlines + ["2009/01/01 медвежья шкура расходы:покупки 100 100" + ," актив:наличные -100 0"] + ,"smart dates" ~: do let str `gives` datestr = fixSmartDateStr (parsedate "2008/11/26") str `is` datestr "1999-12-02" `gives` "1999/12/02" @@ -671,49 +880,46 @@ ,"subAccounts" ~: do l <- sampleledger let a = ledgerAccount l "assets" - (map aname $ subAccounts l a) `is` ["assets:bank","assets:cash"] + (map aname $ ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"] ,"summariseTransactionsInDateSpan" ~: do - let (b,e,entryno,depth,showempty,ts) `gives` summaryts = - summariseTransactionsInDateSpan (mkdatespan b e) entryno depth showempty ts `is` summaryts + let (b,e,tnum,depth,showempty,ts) `gives` summaryts = + summariseTransactionsInDateSpan (mkdatespan b e) tnum depth showempty ts `is` summaryts let ts = [ - nulltxn{description="desc",account="expenses:food:groceries",amount=Mixed [dollars 1]} - ,nulltxn{description="desc",account="expenses:food:dining", amount=Mixed [dollars 2]} - ,nulltxn{description="desc",account="expenses:food", amount=Mixed [dollars 4]} - ,nulltxn{description="desc",account="expenses:food:dining", amount=Mixed [dollars 8]} + nulltxn{tdescription="desc",taccount="expenses:food:groceries",tamount=Mixed [dollars 1]} + ,nulltxn{tdescription="desc",taccount="expenses:food:dining", tamount=Mixed [dollars 2]} + ,nulltxn{tdescription="desc",taccount="expenses:food", tamount=Mixed [dollars 4]} + ,nulltxn{tdescription="desc",taccount="expenses:food:dining", tamount=Mixed [dollars 8]} ] ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` [] ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` [ - nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31"} + nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31"} ] ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` [ - nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food", amount=Mixed [dollars 4]} - ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:dining", amount=Mixed [dollars 10]} - ,nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food:groceries",amount=Mixed [dollars 1]} + nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food", tamount=Mixed [dollars 4]} + ,nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food:dining", tamount=Mixed [dollars 10]} + ,nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food:groceries",tamount=Mixed [dollars 1]} ] ("2008/01/01","2009/01/01",0,2,False,ts) `gives` [ - nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses:food",amount=Mixed [dollars 15]} + nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food",tamount=Mixed [dollars 15]} ] ("2008/01/01","2009/01/01",0,1,False,ts) `gives` [ - nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="expenses",amount=Mixed [dollars 15]} + nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses",tamount=Mixed [dollars 15]} ] ("2008/01/01","2009/01/01",0,0,False,ts) `gives` [ - nulltxn{date=parsedate "2008/01/01",description="- 2008/12/31",account="",amount=Mixed [dollars 15]} + nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="",tamount=Mixed [dollars 15]} ] - ,"timelog" ~: do - parseWithCtx timelog timelog1_str `parseis` timelog1 - - ,"transactionamount" ~: do - parseWithCtx transactionamount " $47.18" `parseis` Mixed [dollars 47.18] - parseWithCtx transactionamount " $1." `parseis` + ,"postingamount" ~: do + parseWithCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18] + parseWithCtx postingamount " $1." `parseis` Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing] ] @@ -724,8 +930,8 @@ sampledate = parsedate "2008/11/26" sampletime = LocalTime sampledate midday -sampleledger = ledgerfromstringwithopts [] [] sampletime sample_ledger_str -sampleledgerwithopts opts args = ledgerfromstringwithopts opts args sampletime sample_ledger_str +sampleledger = ledgerFromStringWithOpts [] [] sampletime sample_ledger_str +sampleledgerwithopts opts args = ledgerFromStringWithOpts opts args sampletime sample_ledger_str sample_ledger_str = unlines ["; A sample ledger file." @@ -780,28 +986,28 @@ write_sample_ledger = writeFile "sample.ledger" sample_ledger_str -rawtransaction1_str = " expenses:food:dining $10.00\n" +rawposting1_str = " expenses:food:dining $10.00\n" -rawtransaction1 = RawTransaction False "expenses:food:dining" (Mixed [dollars 10]) "" RegularTransaction +rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting entry1_str = unlines ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking" + ," expenses:food:groceries $47.18" + ," assets:checking" ,"" ] entry1 = - (Entry (parsedate "2007/01/28") False "" "coopportunity" "" - [RawTransaction False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularTransaction, - RawTransaction False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularTransaction] "") + (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting, + Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting] "") entry2_str = unlines ["2007/01/27 * joes diner" - ," expenses:food:dining $10.00" - ," expenses:gifts $10.00" - ," assets:checking $-20.00" + ," expenses:food:dining $10.00" + ," expenses:gifts $10.00" + ," assets:checking $-20.00" ,"" ] @@ -940,159 +1146,160 @@ [] [] [ - Entry { - edate= parsedate "2007/01/01", - estatus=False, - ecode="*", - edescription="opening balance", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="assets:cash", - tamount=(Mixed [dollars 4.82]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate= parsedate "2007/01/01", + ltstatus=False, + ltcode="*", + ltdescription="opening balance", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="assets:cash", + pamount=(Mixed [dollars 4.82]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="equity:opening balances", - tamount=(Mixed [dollars (-4.82)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="equity:opening balances", + pamount=(Mixed [dollars (-4.82)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } , - Entry { - edate= parsedate "2007/02/01", - estatus=False, - ecode="*", - edescription="ayres suites", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="expenses:vacation", - tamount=(Mixed [dollars 179.92]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate= parsedate "2007/02/01", + ltstatus=False, + ltcode="*", + ltdescription="ayres suites", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="expenses:vacation", + pamount=(Mixed [dollars 179.92]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="assets:checking", - tamount=(Mixed [dollars (-179.92)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="assets:checking", + pamount=(Mixed [dollars (-179.92)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } , - Entry { - edate=parsedate "2007/01/02", - estatus=False, - ecode="*", - edescription="auto transfer to savings", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="assets:saving", - tamount=(Mixed [dollars 200]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate=parsedate "2007/01/02", + ltstatus=False, + ltcode="*", + ltdescription="auto transfer to savings", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="assets:saving", + pamount=(Mixed [dollars 200]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="assets:checking", - tamount=(Mixed [dollars (-200)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="assets:checking", + pamount=(Mixed [dollars (-200)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } , - Entry { - edate=parsedate "2007/01/03", - estatus=False, - ecode="*", - edescription="poquito mas", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="expenses:food:dining", - tamount=(Mixed [dollars 4.82]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate=parsedate "2007/01/03", + ltstatus=False, + ltcode="*", + ltdescription="poquito mas", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="expenses:food:dining", + pamount=(Mixed [dollars 4.82]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="assets:cash", - tamount=(Mixed [dollars (-4.82)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="assets:cash", + pamount=(Mixed [dollars (-4.82)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } , - Entry { - edate=parsedate "2007/01/03", - estatus=False, - ecode="*", - edescription="verizon", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="expenses:phone", - tamount=(Mixed [dollars 95.11]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate=parsedate "2007/01/03", + ltstatus=False, + ltcode="*", + ltdescription="verizon", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="expenses:phone", + pamount=(Mixed [dollars 95.11]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="assets:checking", - tamount=(Mixed [dollars (-95.11)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="assets:checking", + pamount=(Mixed [dollars (-95.11)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } , - Entry { - edate=parsedate "2007/01/03", - estatus=False, - ecode="*", - edescription="discover", - ecomment="", - etransactions=[ - RawTransaction { - tstatus=False, - taccount="liabilities:credit cards:discover", - tamount=(Mixed [dollars 80]), - tcomment="", - rttype=RegularTransaction + LedgerTransaction { + ltdate=parsedate "2007/01/03", + ltstatus=False, + ltcode="*", + ltdescription="discover", + ltcomment="", + ltpostings=[ + Posting { + pstatus=False, + paccount="liabilities:credit cards:discover", + pamount=(Mixed [dollars 80]), + pcomment="", + ptype=RegularPosting }, - RawTransaction { - tstatus=False, - taccount="assets:checking", - tamount=(Mixed [dollars (-80)]), - tcomment="", - rttype=RegularTransaction + Posting { + pstatus=False, + paccount="assets:checking", + pamount=(Mixed [dollars (-80)]), + pcomment="", + ptype=RegularPosting } ], - epreceding_comment_lines="" + ltpreceding_comment_lines="" } ] [] [] "" + "" ledger7 = cacheLedger [] rawledger7 @@ -1104,19 +1311,10 @@ ] timelogentry1_str = "i 2007/03/11 16:19:00 hledger\n" -timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger" +timelogentry1 = TimeLogEntry In (parsedatetime "2007/03/11 16:19:00") "hledger" timelogentry2_str = "o 2007/03/11 16:30:00\n" -timelogentry2 = TimeLogEntry 'o' (parsedatetime "2007/03/11 16:30:00") "" - -timelog1_str = concat [ - timelogentry1_str, - timelogentry2_str - ] -timelog1 = TimeLog [ - timelogentry1, - timelogentry2 - ] +timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") "" price1_str = "P 2004/05/01 XYZ $55\n" price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" "$" 55 @@ -1125,13 +1323,15 @@ a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}] a3 = Mixed $ (amounts a1) ++ (amounts a2) +rawLedgerWithAmounts :: [String] -> RawLedger rawLedgerWithAmounts as = RawLedger [] [] - [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as] + [nullledgertxn{ltdescription=a,ltpostings=[nullrawposting{pamount=parse a}]} | a <- as] [] [] "" - where parse = fromparse . parseWithCtx transactionamount . (" "++) + "" + where parse = fromparse . parseWithCtx postingamount . (" "++) diff --git a/UICommand.hs b/UICommand.hs --- a/UICommand.hs +++ b/UICommand.hs @@ -44,8 +44,8 @@ -- | The screens available within the user interface. data Screen = BalanceScreen -- ^ like hledger balance, shows accounts - | RegisterScreen -- ^ like hledger register, shows transactions - | PrintScreen -- ^ like hledger print, shows entries + | RegisterScreen -- ^ like hledger register, shows transaction-postings + | PrintScreen -- ^ like hledger print, shows ledger transactions | LedgerScreen -- ^ shows the raw ledger deriving (Eq,Show) @@ -221,7 +221,7 @@ updateData a@AppState{aopts=opts,aargs=args,aledger=l} | scr == BalanceScreen = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l} - | scr == PrintScreen = a{abuf=lines $ showEntries opts args l} + | scr == PrintScreen = a{abuf=lines $ showLedgerTransactions opts args l} | scr == LedgerScreen = a{abuf=lines $ rawledgertext l} where scr = screen a @@ -233,11 +233,11 @@ drilldown :: AppState -> AppState drilldown a | screen a == BalanceScreen = enter RegisterScreen a{aargs=[currentAccountName a]} - | screen a == RegisterScreen = scrollToEntry e $ enter PrintScreen 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 = currentEntry a + where e = currentLedgerTransaction a -- | Get the account name currently highlighted by the cursor on the -- balance screen. Results undefined while on other screens. @@ -265,10 +265,10 @@ -- | If on the print screen, move the cursor to highlight the specified entry -- (or a reasonable guess). Doesn't work. -scrollToEntry :: Entry -> AppState -> AppState -scrollToEntry e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a +scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState +scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a where - entryfirstline = head $ lines $ showEntry $ e + entryfirstline = head $ lines $ showLedgerTransaction $ e halfph = pageHeight a `div` 2 y = fromMaybe 0 $ findIndex (== entryfirstline) buf sy = max 0 $ y - halfph @@ -277,11 +277,11 @@ -- | Get the entry containing the transaction currently highlighted by the -- cursor on the register screen (or best guess). Results undefined while -- on other screens. Doesn't work. -currentEntry :: AppState -> Entry -currentEntry a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t +currentLedgerTransaction :: AppState -> LedgerTransaction +currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t where t = safehead nulltxn $ filter ismatch $ ledgerTransactions l - ismatch t = date t == (parsedate $ take 10 datedesc) + 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 @@ -291,8 +291,8 @@ -- | Get the entry which contains the given transaction. -- Will raise an error if there are problems. -entryContainingTransaction :: AppState -> Transaction -> Entry -entryContainingTransaction AppState{aledger=l} t = (entries $ rawledger l) !! entryno t +entryContainingTransaction :: AppState -> Transaction -> LedgerTransaction +entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !! tnum t -- renderers diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -1,57 +1,54 @@ {-| -Utilities for top-level modules and/or ghci. See also "Ledger.Utils". +Utilities for top-level modules and ghci. See also "Ledger.IO" and +"Ledger.Utils". -} module Utils where import Control.Monad.Error -import qualified Data.Map as Map (lookup) import Data.Time.Clock -import Text.ParserCombinators.Parsec -import System.IO -import Options 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) --- | Convert a RawLedger to a canonicalised, cached and filtered Ledger --- based on the command-line options/arguments and the current date/time. -prepareLedger :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger -prepareLedger opts args reftime rawtext rl = l{rawledgertext=rawtext} - where - l = cacheLedger apats $ filterRawLedger span dpats c r $ canonicaliseAmounts cb rl - (apats,dpats) = parseAccountDescriptionArgs [] args - span = dateSpanFromOpts (localDay reftime) opts - c = Cleared `elem` opts - r = Real `elem` opts - cb = CostBasis `elem` opts - --- | Get a RawLedger from the given string, or raise an error. --- This uses the current local time as the reference time (for closing --- open timelog entries). -rawledgerfromstring :: String -> IO RawLedger -rawledgerfromstring s = do +-- | Parse the user's specified ledger file and run a hledger command on +-- it, or report a parse error. This function makes the whole thing go. +withLedgerDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () +withLedgerDo opts args cmdname cmd = do + -- We kludgily read the file before parsing to grab the full text, unless + -- it's stdin, or it doesn't exist and we are adding. We read it strictly + -- to let the add command work. + f <- ledgerFilePathFromOpts opts + let f' = if f == "-" then "/dev/null" else f + fileexists <- doesFileExist f + let creating = not fileexists && cmdname == "add" + rawtext <- if creating then return "" else strictReadFile f' t <- getCurrentLocalTime - liftM (either error id) $ runErrorT $ parseLedger t "(string)" s + let go = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext . (\rl -> rl{filepath=f}) + case creating of + True -> return rawLedgerEmpty >>= go + False -> return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) go -- | Get a Ledger from the given string and options, or raise an error. -ledgerfromstringwithopts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger -ledgerfromstringwithopts opts args reftime s = - liftM (prepareLedger opts args reftime s) $ rawledgerfromstring s +ledgerFromStringWithOpts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger +ledgerFromStringWithOpts opts args reftime s = + liftM (filterAndCacheLedgerWithOpts opts args reftime s) $ rawLedgerFromString s --- | Get a Ledger from the given file path and options, or raise an error. -ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger -ledgerfromfilewithopts opts args f = do - s <- readFile f - rl <- rawledgerfromstring s - reftime <- getCurrentLocalTime - return $ prepareLedger opts args reftime s rl +-- | Read a Ledger from the given file, filtering according to the +-- options, or give an error. +readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger +readLedgerWithOpts opts args f = do + t <- getCurrentLocalTime + readLedgerWithIOArgs (optsToIOArgs opts args t) f --- | Get a Ledger from your default ledger file, or raise an error. --- Assumes no options. -myledger :: IO Ledger -myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] [] +-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger +-- based on the command-line options/arguments and a reference time. +filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger +filterAndCacheLedgerWithOpts opts args t = filterAndCacheLedger (optsToIOArgs opts args t) -parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a -parseWithCtx p ts = runParser p emptyCtx "" ts diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -5,7 +5,7 @@ import Options (progname) -- updated by build process from VERSION -version = "0.4.0" +version = "0.5.0" #ifdef PATCHES -- a "make" development build defines PATCHES from the repo state patchlevel = "." ++ show PATCHES -- must be numeric ! diff --git a/WebCommand.hs b/WebCommand.hs --- a/WebCommand.hs +++ b/WebCommand.hs @@ -26,6 +26,7 @@ import BalanceCommand import RegisterCommand import PrintCommand +import HistogramCommand tcpport = 5000 @@ -40,7 +41,7 @@ putStrLn $ printf "starting web server on port %d" tcpport tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers putStrLn "starting web browser" - openBrowserOn $ printf "http://localhost:%s/balance" (show tcpport) + openBrowserOn $ printf "http://localhost:%d/balance" tcpport waitForTermination putStrLn "shutting down web server..." killThread tid @@ -49,18 +50,25 @@ where handlers :: ServerPartT IO Response handlers = msum - [dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a] + [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 = showEntries opts (apats ++ args) l + 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 @@ -78,6 +86,8 @@ ," register" ,"|" ," print" + ,"|" + ," histogram" ,"" ,"
%s
" ]) diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -1,6 +1,6 @@ Name: hledger -- updated by build process from VERSION -Version: 0.4 +Version: 0.5 Category: Finance Synopsis: A ledger-compatible text-based accounting tool. Description: hledger is a partial haskell clone of John Wiegley's "ledger" text-based @@ -28,7 +28,7 @@ Library Build-Depends: base, containers, haskell98, directory, parsec, regex-compat, - old-locale, time, HUnit, filepath + old-locale, time, HUnit, filepath, utf8-string Exposed-modules:Ledger Ledger.Account @@ -36,10 +36,11 @@ Ledger.Amount Ledger.Commodity Ledger.Dates - Ledger.Entry + Ledger.IO + Ledger.LedgerTransaction Ledger.RawLedger Ledger.Ledger - Ledger.RawTransaction + Ledger.Posting Ledger.Parse Ledger.TimeLog Ledger.Transaction @@ -51,10 +52,13 @@ Build-Depends: base, containers, haskell98, directory, parsec, regex-compat, regexpr>=0.5.1, old-locale, time, - HUnit, mtl, bytestring, filepath, process, testpack + HUnit, mtl, bytestring, filepath, process, testpack, + regex-pcre, csv, split, utf8-string Other-Modules: + AddCommand BalanceCommand + HistogramCommand Options PrintCommand RegisterCommand @@ -68,17 +72,18 @@ Ledger.Amount Ledger.Commodity Ledger.Dates - Ledger.Entry + Ledger.IO + Ledger.LedgerTransaction Ledger.Ledger Ledger.Parse Ledger.RawLedger - Ledger.RawTransaction + Ledger.Posting Ledger.TimeLog Ledger.Transaction Ledger.Types Ledger.Utils - -- how to set patchlevel in cabal builds ? + -- need to set patchlevel here (darcs changes --from-tag=. --count) cpp-options: -DPATCHES=0 if flag(vty) diff --git a/hledger.hs b/hledger.hs --- a/hledger.hs +++ b/hledger.hs @@ -9,7 +9,7 @@ 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. For more information, see ledger.org . +implementation of ledger. For more information, see http:\/\/hledger.org . You can use the command line: @@ -18,18 +18,21 @@ or ghci: > $ ghci hledger -> > l <- ledgerfromfilewithopts [] [] "sample.ledger" -> > balance [] [] l -> $-1 assets -> $2 expenses -> $-2 income -> $1 liabilities +> > l <- readLedger "sample.ledger" > > register [] ["income","expenses"] l > 2008/01/01 income income:salary $-1 $-1 > 2008/06/01 gift income:gifts $-1 $-2 > 2008/06/03 eat & shop expenses:food $1 $-1 > expenses:supplies $1 0 +> > balance [Depth "1"] [] l +> $-1 assets +> $2 expenses +> $-2 income +> $1 liabilities +> > l <- myLedger +> > t <- myTimelog +See "Ledger.Ledger" for more examples. -} module Main ( @@ -38,25 +41,36 @@ 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) -import System.IO +import System.IO.UTF8 +import System.IO (stderr) import Version (versionmsg) import Ledger -import Utils +import Utils (withLedgerDo) import Options import Tests import BalanceCommand +import ConvertCommand import PrintCommand import RegisterCommand +import HistogramCommand +import AddCommand #ifdef VTY import UICommand #endif @@ -71,29 +85,20 @@ run cmd opts args where run cmd opts args - | Help `elem` opts = putStr $ usage - | Version `elem` opts = putStr versionmsg - | cmd `isPrefixOf` "balance" = parseLedgerAndDo opts args balance - | cmd `isPrefixOf` "print" = parseLedgerAndDo opts args print' - | cmd `isPrefixOf` "register" = parseLedgerAndDo opts args register + | Help `elem` opts = putStr $ usage + | Version `elem` opts = putStr versionmsg + | 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 #ifdef VTY - | cmd `isPrefixOf` "ui" = parseLedgerAndDo opts args ui + | cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui #endif #ifdef HAPPS - | cmd `isPrefixOf` "web" = parseLedgerAndDo opts args web + | cmd `isPrefixOf` "web" = withLedgerDo opts args cmd web #endif - | cmd `isPrefixOf` "test" = runtests opts args >> return () - | otherwise = putStr $ usage + | cmd `isPrefixOf` "test" = runtests opts args >> return () + | otherwise = putStr $ usage --- | parse the user's specified ledger file and do some action with it --- (or report a parse error). This function makes the whole thing go. -parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () -parseLedgerAndDo opts args cmd = do - f <- ledgerFilePathFromOpts opts - -- XXX we read the file twice - inelegant - -- and, doesn't work with stdin. kludge it, stdin won't work with ui command - let f' = if f == "-" then "/dev/null" else f - rawtext <- readFile f' - t <- getCurrentLocalTime - let runcmd = cmd opts args . prepareLedger opts args t rawtext - return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) runcmd