diff --git a/Commands/Add.hs b/Commands/Add.hs --- a/Commands/Add.hs +++ b/Commands/Add.hs @@ -15,59 +15,61 @@ import System.IO.Error import Text.ParserCombinators.Parsec import Utils (ledgerFromStringWithOpts) - +import qualified Data.Foldable as Foldable (find) -- | Read ledger transactions from the terminal, prompting for each field, -- and append them to the ledger file. If the ledger came from stdin, this -- command has no effect. add :: [Opt] -> [String] -> Ledger -> IO () -add _ args l - | filepath (rawledger l) == "-" = return () +add opts args l + | filepath (journal l) == "-" = return () | otherwise = do hPutStrLn stderr "Enter one or more transactions, which will be added to your ledger file.\n\ - \To complete a transaction, enter . as account name. To quit, enter control-d." - getAndAddTransactions l args `catch` (\e -> unless (isEOFError e) $ ioError e) + \To complete a transaction, enter . as account name. To quit, press control-c." + today <- getCurrentDay + getAndAddTransactions l opts args today `catch` (\e -> unless (isEOFError e) $ ioError e) -- | Read a number of ledger transactions from the command line, -- prompting, validating, displaying and appending them to the ledger -- file, until end of input (then raise an EOF exception). Any -- command-line arguments are used as the first transaction's description. -getAndAddTransactions :: Ledger -> [String] -> IO () -getAndAddTransactions l args = do - l <- getTransaction l args >>= addTransaction l - getAndAddTransactions l [] +getAndAddTransactions :: Ledger -> [Opt] -> [String] -> Day -> IO () +getAndAddTransactions l opts args defaultDate = do + (ledgerTransaction,date) <- getTransaction l opts args defaultDate + l <- ledgerAddTransaction l ledgerTransaction + getAndAddTransactions l opts args date -- | Read a transaction from the command line, with history-aware prompting. -getTransaction :: Ledger -> [String] -> IO LedgerTransaction -getTransaction l args = do +getTransaction :: Ledger -> [Opt] -> [String] -> Day -> IO (Transaction,Day) +getTransaction l opts args defaultDate = do today <- getCurrentDay datestr <- askFor "date" - (Just $ showDate today) + (Just $ showDate defaultDate) (Just $ \s -> null s || isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) - description <- if null args - then askFor "description" Nothing (Just $ not . null) - else do - let description = unwords args - hPutStrLn stderr $ "description: " ++ description - return description - let historymatches = transactionsSimilarTo l description + description <- askFor "description" Nothing (Just $ not . null) + let historymatches = transactionsSimilarTo l args description bestmatch | null historymatches = Nothing | otherwise = Just $ snd $ head historymatches - bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch + bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr + accept x = x == "." || (not . null) x && + if NoNewAccts `elem` opts + then isJust $ Foldable.find (== x) ant + else True + where (ant,_,_,_) = groupPostings . journalPostings . journal $ l getpostingsandvalidate = do - ps <- getPostings bestmatchpostings [] - let t = nullledgertxn{ltdate=date - ,ltstatus=False - ,ltdescription=description - ,ltpostings=ps - } + ps <- getPostings accept bestmatchpostings [] + let t = nulltransaction{tdate=date + ,tstatus=False + ,tdescription=description + ,tpostings=ps + } retry = do hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:" getpostingsandvalidate - either (const retry) return $ balanceLedgerTransaction t + either (const retry) (return . flip (,) date) $ balanceTransaction t unless (null historymatches) (do hPutStrLn stderr "Similar transactions found, using the first for defaults:\n" @@ -76,18 +78,18 @@ -- | Read postings from the command line until . is entered, using the -- provided historical postings, if any, to guess defaults. -getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting] -getPostings historicalps enteredps = do - account <- askFor (printf "account %d" n) defaultaccount (Just $ not . null) +getPostings :: (AccountName -> Bool) -> Maybe [Posting] -> [Posting] -> IO [Posting] +getPostings accept historicalps enteredps = do + account <- askFor (printf "account %d" n) defaultaccount (Just accept) if account=="." then return enteredps else do amountstr <- askFor (printf "amount %d" n) defaultamount validateamount let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr - let p = nullrawposting{paccount=stripbrackets account, - pamount=amount, - ptype=postingtype account} - getPostings historicalps $ enteredps ++ [p] + let p = nullposting{paccount=stripbrackets account, + pamount=amount, + ptype=postingtype account} + getPostings accept historicalps $ enteredps ++ [p] where n = length enteredps + 1 enteredrealps = filter isReal enteredps @@ -125,14 +127,14 @@ -- | 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 +ledgerAddTransaction :: Ledger -> Transaction -> IO Ledger +ledgerAddTransaction l t = do appendToLedgerFile l $ show t - putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l) + putStrLn $ printf "\nAdded transaction to %s:" (filepath $ journal l) putStrLn =<< registerFromString (show t) - return l{rawledger=rl{ledger_txns=ts}} - where rl = rawledger l - ts = ledger_txns rl ++ [t] + return l{journal=rl{jtxns=ts}} + where rl = journal l + ts = jtxns 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. @@ -142,10 +144,10 @@ 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 + f = filepath $ journal l + -- XXX we are looking at the original raw text from when the ledger -- was first read, but that's good enough for now - t = rawledgertext l + t = jtext $ journal l sep | null $ strip t = "" | otherwise = replicate (2 - min 2 (length lastnls)) '\n' where lastnls = takeWhile (=='\n') $ reverse t @@ -154,8 +156,9 @@ registerFromString :: String -> IO String registerFromString s = do now <- getCurrentLocalTime - l <- ledgerFromStringWithOpts [] [] now s - return $ showRegisterReport [Empty] [] l + l <- ledgerFromStringWithOpts [] s + return $ showRegisterReport opts (optsToFilterSpec opts [] now) l + where opts = [Empty] -- | Return a similarity measure, from 0 to 1, for two strings. -- This is Simon White's letter pairs algorithm from @@ -176,18 +179,19 @@ letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest) letterPairs _ = [] +compareLedgerDescriptions :: [Char] -> [Char] -> Double compareLedgerDescriptions s t = compareStrings s' t' where s' = simplify s t' = simplify t simplify = filter (not . (`elem` "0123456789")) -transactionsSimilarTo :: Ledger -> String -> [(Double,LedgerTransaction)] -transactionsSimilarTo l s = +transactionsSimilarTo :: Ledger -> [String] -> String -> [(Double,Transaction)] +transactionsSimilarTo l apats s = sortBy compareRelevanceAndRecency $ filter ((> threshold).fst) - [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts] + [(compareLedgerDescriptions s $ tdescription t, t) | t <- ts] where - compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1) - ts = ledger_txns $ rawledger l + compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1) + ts = jtxns $ filterJournalTransactionsByAccount apats $ journal l threshold = 0 diff --git a/Commands/All.hs b/Commands/All.hs --- a/Commands/All.hs +++ b/Commands/All.hs @@ -21,6 +21,9 @@ #ifdef WEB module Commands.Web, #endif +#ifdef CHART + module Commands.Chart +#endif ) where import Commands.Add @@ -35,4 +38,7 @@ #endif #ifdef WEB import Commands.Web +#endif +#ifdef CHART +import Commands.Chart #endif diff --git a/Commands/Balance.hs b/Commands/Balance.hs --- a/Commands/Balance.hs +++ b/Commands/Balance.hs @@ -101,7 +101,7 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName -import Ledger.Transaction +import Ledger.Posting import Ledger.Ledger import Options import System.IO.UTF8 @@ -109,23 +109,26 @@ -- | Print a balance report. balance :: [Opt] -> [String] -> Ledger -> IO () -balance opts args = putStr . showBalanceReport opts args +balance opts args l = do + t <- getCurrentLocalTime + putStr $ showBalanceReport opts (optsToFilterSpec opts args t) l -- | Generate a balance report with the specified options for this ledger. -showBalanceReport :: [Opt] -> [String] -> Ledger -> String -showBalanceReport opts _ l = acctsstr ++ totalstr +showBalanceReport :: [Opt] -> FilterSpec -> Ledger -> String +showBalanceReport opts filterspec l = acctsstr ++ totalstr where + l' = cacheLedger'' filterspec l acctsstr = unlines $ map showacct interestingaccts where - showacct = showInterestingAccount l interestingaccts - interestingaccts = filter (isInteresting opts l) acctnames + showacct = showInterestingAccount l' interestingaccts + interestingaccts = filter (isInteresting opts l') acctnames acctnames = sort $ tail $ flatten $ treemap aname accttree - accttree = ledgerAccountTree (depthFromOpts opts) l + accttree = ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) l' totalstr | NoTotal `elem` opts = "" | notElem Empty opts && isZeroMixedAmount total = "" | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice total where - total = sum $ map abalance $ ledgerTopAccounts l + total = sum $ map abalance $ ledgerTopAccounts l' -- | Display one line of the balance report with appropriate indenting and eliding. showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String @@ -147,11 +150,11 @@ | numinterestingsubs==1 && not atmaxdepth = notlikesub | otherwise = notzero || emptyflag where - atmaxdepth = accountNameLevel a == depthFromOpts opts + atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts emptyflag = Empty `elem` opts acct = ledgerAccount l a notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct - notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct + notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct numinterestingsubs = length $ filter isInterestingTree subtrees where isInterestingTree = treeany (isInteresting opts l . aname) diff --git a/Commands/Chart.hs b/Commands/Chart.hs new file mode 100644 --- /dev/null +++ b/Commands/Chart.hs @@ -0,0 +1,108 @@ +{-| + +Generate balances pie chart + +-} + +module Commands.Chart +where +import Ledger.Utils +import Ledger.Types +import Ledger.Amount +import Ledger.Ledger +import Ledger.Commodity +import Options + +import Control.Monad (liftM3) +import Graphics.Rendering.Chart +import Data.Colour +import Data.Colour.Names +import Data.Colour.RGBSpace +import Data.Colour.RGBSpace.HSL (hsl) +import Data.Colour.SRGB.Linear (rgb) +import Data.List +import Safe (readDef) + +-- | Generate an image with the pie chart and write it to a file +chart :: [Opt] -> [String] -> Ledger -> IO () +chart opts args l = do + t <- getCurrentLocalTime + let chart = genPie opts (optsToFilterSpec opts args t) l + renderableToPNGFile (toRenderable chart) w h filename + where + filename = getOption opts ChartOutput chartoutput + (w,h) = parseSize $ getOption opts ChartSize chartsize + +-- | Extract string option value from a list of options or use the default +getOption :: [Opt] -> (String->Opt) -> String -> String +getOption opts opt def = + case reverse $ optValuesForConstructor opt opts of + [] -> def + x:_ -> x + +-- | Parse image size from a command-line option +parseSize :: String -> (Int,Int) +parseSize str = (read w, read h) + where + x = fromMaybe (error "Size should be in WIDTHxHEIGHT format") $ findIndex (=='x') str + (w,_:h) = splitAt x str + +-- | Generate pie chart +genPie :: [Opt] -> FilterSpec -> Ledger -> PieLayout +genPie opts filterspec l = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white + , pie_plot_ = pie_chart } + where + pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems' + , pie_start_angle_ = (-90) + , pie_colors_ = mkColours hue + , pie_label_style_ = defaultFontStyle{font_size_=12} + } + chartitems' = debug "chart" $ top num samesignitems + (samesignitems, sign) = sameSignNonZero rawitems + rawitems = debug "raw" $ flatten $ balances $ + ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) $ cacheLedger'' filterspec l + top n t = topn ++ [other] + where + (topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t + other = ("other", sum $ map snd rest) + num = readDef (fromIntegral chartitems) (getOption opts ChartItems (show chartitems)) + hue = if sign > 0 then red else green where (red, green) = (0, 110) + debug s = if Debug `elem` opts then ltrace s else id + +-- | Select the nonzero items with same sign as the first, and make +-- them positive. Also return a 1 or -1 corresponding to the original sign. +sameSignNonZero :: [(AccountName, Double)] -> ([(AccountName, Double)], Int) +sameSignNonZero is | null nzs = ([], 1) + | otherwise = (map pos $ filter (test.snd) nzs, sign) + where + nzs = filter ((/=0).snd) is + pos (a,b) = (a, abs b) + sign = if snd (head nzs) >= 0 then 1 else (-1) + test = if sign > 0 then (>0) else (<0) + +-- | Convert all quantities of MixedAccount to a single commodity +amountValue :: MixedAmount -> Double +amountValue = quantity . convertMixedAmountTo unknown + +-- | Generate a tree of account names together with their balances. +-- The balance of account is decremented by the balance of its subaccounts +-- which are drawn on the chart. +balances :: Tree Account -> Tree (AccountName, Double) +balances (Node rootAcc subAccs) = Node newroot newsubs + where + newroot = (aname rootAcc, + amountValue $ + abalance rootAcc - (sum . map (abalance . root)) subAccs) + newsubs = map balances subAccs + +-- | Build a single pie chart item +accountPieItem :: AccountName -> Double -> PieItem +accountPieItem accname balance = PieItem accname offset balance where offset = 0 + +-- | Generate an infinite color list suitable for charts. +mkColours :: Double -> [AlphaColour Double] +mkColours hue = cycle $ [opaque $ rgbToColour $ hsl h s l | (h,s,l) <- liftM3 (,,) + [hue] [0.7] [0.1,0.2..0.7] ] + +rgbToColour :: (Fractional a) => RGB a -> Colour a +rgbToColour (RGB r g b) = rgb r g b diff --git a/Commands/Convert.hs b/Commands/Convert.hs --- a/Commands/Convert.hs +++ b/Commands/Convert.hs @@ -6,7 +6,7 @@ module Commands.Convert where import Options (Opt(Debug)) import Version (versionstr) -import Ledger.Types (Ledger,AccountName,LedgerTransaction(..),Posting(..),PostingType(..)) +import Ledger.Types (Ledger,AccountName,Transaction(..),Posting(..),PostingType(..)) import Ledger.Utils (strip, spacenonewline, restofline) import Ledger.Parse (someamount, emptyCtx, ledgeraccountname) import Ledger.Amount (nullmixedamt) @@ -237,7 +237,7 @@ -- csv record conversion -transactionFromCsvRecord :: CsvRules -> CsvRecord -> LedgerTransaction +transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord rules fields = let date = parsedate $ normaliseDate $ maybe "1900/1/1" (fields !!) (dateField rules) @@ -256,32 +256,34 @@ unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown" | otherwise = "expenses:unknown" (acct,newdesc) = identify (accountRules rules) unknownacct desc - in - LedgerTransaction { - ltdate=date, - lteffectivedate=Nothing, - ltstatus=status, - ltcode=code, - ltdescription=newdesc, - ltcomment=comment, - ltpreceding_comment_lines=precomment, - ltpostings=[ + t = Transaction { + tdate=date, + teffectivedate=Nothing, + tstatus=status, + tcode=code, + tdescription=newdesc, + tcomment=comment, + tpreceding_comment_lines=precomment, + tpostings=[ Posting { pstatus=False, paccount=acct, pamount=amount, pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Just t }, Posting { pstatus=False, paccount=baseAccount rules, pamount=(-amount), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Just t } ] } + in t -- | Convert some date string with unknown format to YYYY/MM/DD. normaliseDate :: String -> String diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs --- a/Commands/Histogram.hs +++ b/Commands/Histogram.hs @@ -15,35 +15,33 @@ barchar = '*' -- | Print a histogram of some statistic per reporting interval, such as --- number of transactions per day. +-- number of postings per day. histogram :: [Opt] -> [String] -> Ledger -> IO () -histogram opts args = putStr . showHistogram opts args +histogram opts args l = do + t <- getCurrentLocalTime + putStr $ showHistogram opts (optsToFilterSpec opts args t) l -showHistogram :: [Opt] -> [String] -> Ledger -> String -showHistogram opts args l = concatMap (printDayWith countBar) daytxns +showHistogram :: [Opt] -> FilterSpec -> Ledger -> String +showHistogram opts filterspec l = concatMap (printDayWith countBar) dayps where i = intervalFromOpts opts interval | i == NoInterval = Daily | otherwise = i - fullspan = rawLedgerDateSpan $ rawledger l + fullspan = journalDateSpan $ journal l days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan - daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days] + dayps = [(s, filter (isPostingInDateSpan s) ps) | s <- days] -- same as Register - -- should count raw transactions, not posting transactions - ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l + -- should count transactions, not postings ? + ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ ledgerPostings l filterempties | Empty `elem` opts = id - | otherwise = filter (not . isZeroMixedAmount . tamount) - matchapats = matchpats apats . taccount - (apats,_) = parsePatternArgs args - filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth) + | otherwise = filter (not . isZeroMixedAmount . pamount) + matchapats = matchpats apats . paccount + apats = acctpats filterspec + filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth) | otherwise = id - depth = depthFromOpts opts + depth = fromMaybe 99999 $ depthFromOpts opts printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) -countBar ts = replicate (length ts) barchar - -total = show . sumTransactions - --- totalBar ts = replicate (sumTransactions ts) barchar +countBar ps = replicate (length ps) barchar diff --git a/Commands/Print.hs b/Commands/Print.hs --- a/Commands/Print.hs +++ b/Commands/Print.hs @@ -14,16 +14,13 @@ -- | Print ledger transactions in standard format. print' :: [Opt] -> [String] -> Ledger -> IO () -print' opts args = putStr . showLedgerTransactions opts args +print' opts args l = do + t <- getCurrentLocalTime + putStr $ showTransactions (optsToFilterSpec opts args t) l -showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String -showLedgerTransactions opts args l = concatMap (showLedgerTransactionForPrint effective) txns - where - txns = sortBy (comparing ltdate) $ - ledger_txns $ - filterRawLedgerPostingsByDepth depth $ - filterRawLedgerTransactionsByAccount apats $ - rawledger l - depth = depthFromOpts opts - effective = Effective `elem` opts - (apats,_) = parsePatternArgs args +showTransactions :: FilterSpec -> Ledger -> String +showTransactions filterspec l = + concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns + where + effective = EffectiveDate == whichdate filterspec + txns = jtxns $ filterJournalTransactions filterspec $ journal l diff --git a/Commands/Register.hs b/Commands/Register.hs --- a/Commands/Register.hs +++ b/Commands/Register.hs @@ -6,7 +6,6 @@ module Commands.Register where -import Data.Function (on) import Prelude hiding (putStr) import Ledger import Options @@ -15,106 +14,101 @@ -- | Print a register report. register :: [Opt] -> [String] -> Ledger -> IO () -register opts args = putStr . showRegisterReport opts args - -{- | -Generate the register report. Each ledger entry is displayed as two or -more lines like this: +register opts args l = do + t <- getCurrentLocalTime + putStr $ showRegisterReport opts (optsToFilterSpec opts args t) l -@ -date (10) description (20) account (22) amount (11) balance (12) -DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - ... ... ... -@ --} -showRegisterReport :: [Opt] -> [String] -> Ledger -> String -showRegisterReport opts args l - | interval == NoInterval = showtxns displayedts nulltxn startbal - | otherwise = showtxns summaryts nulltxn startbal +-- | Generate the register report, which is a list of postings with transaction +-- info and a running balance. +showRegisterReport :: [Opt] -> FilterSpec -> Ledger -> String +showRegisterReport opts filterspec l + | interval == NoInterval = showpostings displayedps nullposting startbal + | otherwise = showpostings summaryps nullposting startbal where + startbal = sumPostings precedingps + (displayedps, _) = span displayExprMatches restofps + (precedingps, restofps) = break displayExprMatches sortedps + sortedps = sortBy (comparing postingDate) ps + ps = journalPostings $ filterJournalPostings filterspec $ journal l + summaryps = concatMap summarisespan spans + summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) + postingsinspan s = filter (isPostingInDateSpan s) displayedps + spans = splitSpan interval (postingsDateSpan displayedps) interval = intervalFromOpts opts - ts = sortBy (comparing tdate) $ filterempties $ filtertxns apats $ filterdepth $ ledgerTransactions l - filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth) - | otherwise = id - filterempties - | Empty `elem` opts = id - | otherwise = filter (not . isZeroMixedAmount . tamount) - (precedingts, ts') = break (matchdisplayopt dopt) ts - (displayedts, _) = span (matchdisplayopt dopt) ts' - startbal = sumTransactions precedingts - (apats,_) = parsePatternArgs args - matchdisplayopt Nothing _ = True - matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t - dopt = displayFromOpts opts empty = Empty `elem` opts depth = depthFromOpts opts - summaryts = concatMap summarisespan (zip spans [1..]) - summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s) - transactionsinspan s = filter (isTransactionInDateSpan s) displayedts - spans = splitSpan interval (ledgerDateSpan l) + dispexpr = displayExprFromOpts opts + displayExprMatches p = case dispexpr of + Nothing -> True + Just e -> (fromparse $ parsewith datedisplayexpr e) p --- | Convert a date span (representing a reporting interval) and a list of --- transactions within it to a new list of transactions aggregated by --- account, which showtxns will render as a summary for this interval. +-- | Given a date span (representing a reporting interval) and a list of +-- postings within it: aggregate the postings so there is only one per +-- account, and adjust their date/description so that they will render +-- as a summary for this interval. -- -- As usual with date spans the end date is exclusive, but for display -- purposes we show the previous day as end date, like ledger. -- --- A unique tnum value is provided so that the new transactions will be --- grouped as one entry. --- --- When a depth argument is present, transactions to accounts of greater +-- When a depth argument is present, postings to accounts of greater -- depth are aggregated where possible. -- --- The showempty flag forces the display of a zero-transaction span --- and also zero-transaction accounts within the span. -summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction] -summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts - | null ts && showempty = [txn] - | null ts = [] - | otherwise = summaryts' +-- The showempty flag forces the display of a zero-posting span +-- and also zero-posting accounts within the span. +summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting] +summarisePostingsInDateSpan (DateSpan b e) depth showempty ps + | null ps && showempty = [p] + | null ps = [] + | otherwise = summaryps' where - txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++ showDate (addDays (-1) e')} - b' = fromMaybe (tdate $ head ts) b - e' = fromMaybe (tdate $ last ts) e - summaryts' - | showempty = summaryts - | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts - txnanames = sort $ nub $ map taccount ts + postingwithinfo date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} + p = postingwithinfo b' ("- "++ showDate (addDays (-1) e')) + b' = fromMaybe (postingDate $ head ps) b + e' = fromMaybe (postingDate $ last ps) e + summaryps' + | showempty = summaryps + | otherwise = filter (not . isZeroMixedAmount . pamount) summaryps + anames = sort $ nub $ map paccount ps -- aggregate balances by account, like cacheLedger, then do depth-clipping - (_,_,exclbalof,inclbalof) = groupTransactions ts - clippedanames = clipAccountNames depth txnanames - isclipped a = accountNameLevel a >= depth + (_,_,exclbalof,inclbalof) = groupPostings ps + clippedanames = nub $ map (clipAccountName d) anames + isclipped a = accountNameLevel a >= d + d = fromMaybe 99999 $ depth balancetoshowfor a = (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) - summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames] + summaryps = [p{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames] -clipAccountNames :: Int -> [AccountName] -> [AccountName] -clipAccountNames d as = nub $ map (clip d) as - where clip d = accountNameFromComponents . take d . accountNameComponents +{- | +Show postings one per line, plus transaction info for the first posting of +each transaction, and a running balance. Eg: --- | Show transactions one per line, with each date/description appearing --- only once, and a running balance. -showtxns [] _ _ = "" -showtxns (t:ts) tprev bal = this ++ showtxns ts t bal' +@ +date (10) description (20) account (22) amount (11) balance (12) +DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA + aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA +@ +-} +showpostings :: [Posting] -> Posting -> MixedAmount -> String +showpostings [] _ _ = "" +showpostings (p:ps) pprev bal = this ++ showpostings ps p bal' where - this = showtxn (t `issame` tprev) t bal' - issame = (==) `on` tnum - bal' = bal + tamount t + this = showposting isfirst p bal' + isfirst = ptransaction p /= ptransaction pprev + bal' = bal + pamount p --- | Show one transaction line and balance with or without the entry details. -showtxn :: Bool -> Transaction -> MixedAmount -> String -showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n" +-- | Show one posting and running balance, with or without transaction info. +showposting :: Bool -> Posting -> MixedAmount -> String +showposting withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n" where ledger3ishlayout = False datedescwidth = if ledger3ishlayout then 34 else 32 - entrydesc = if omitdesc then replicate datedescwidth ' ' else printf "%s %s " date desc + txninfo = if withtxninfo then printf "%s %s " date desc else replicate datedescwidth ' ' date = showDate da datewidth = 10 descwidth = datedescwidth - datewidth - 2 desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String - p = showPostingWithoutPrice $ Posting s a amt "" tt + pstr = showPostingWithoutPrice p bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b) - Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t + (da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de') + Nothing -> (nulldate,"") diff --git a/Commands/Stats.hs b/Commands/Stats.hs --- a/Commands/Stats.hs +++ b/Commands/Stats.hs @@ -16,7 +16,7 @@ stats :: [Opt] -> [String] -> Ledger -> IO () stats opts args l = do today <- getCurrentDay - putStr $ showStats opts args l today + putStr $ showStats opts args (cacheLedger' l) today showStats :: [Opt] -> [String] -> Ledger -> Day -> String showStats _ _ l today = @@ -27,14 +27,14 @@ w1 = maximum $ map (length . fst) stats w2 = maximum $ map (length . show . snd) stats stats = [ - ("File", filepath $ rawledger l) + ("File", filepath $ journal l) ,("Period", printf "%s to %s (%d days)" (start span) (end span) days) ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate) ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30) ,("Transactions last 7 days", printf "%d (%0.1f per day)" tnum7 txnrate7) ,("Last transaction", maybe "none" show lastdate ++ maybe "" (printf " (%d days ago)") lastelapsed) --- ,("Payees/descriptions", show $ length $ nub $ map ltdescription ts) +-- ,("Payees/descriptions", show $ length $ nub $ map tdescription ts) ,("Accounts", show $ length $ accounts l) ,("Commodities", show $ length $ commodities l) -- Transactions this month : %(monthtxns)s (last month in the same period: %(lastmonthtxns)s) @@ -43,9 +43,9 @@ -- Days since last transaction : %(recentelapsed)s ] where - ts = sortBy (comparing ltdate) $ ledger_txns $ rawledger l + ts = sortBy (comparing tdate) $ jtxns $ journal l lastdate | null ts = Nothing - | otherwise = Just $ ltdate $ last ts + | otherwise = Just $ tdate $ last ts lastelapsed = maybe Nothing (Just . diffDays today) lastdate tnum = length ts span = rawdatespan l @@ -57,9 +57,9 @@ txnrate | days==0 = 0 | otherwise = fromIntegral tnum / fromIntegral days :: Double tnum30 = length $ filter withinlast30 ts - withinlast30 t = d >= addDays (-30) today && (d<=today) where d = ltdate t + withinlast30 t = d >= addDays (-30) today && (d<=today) where d = tdate t txnrate30 = fromIntegral tnum30 / 30 :: Double tnum7 = length $ filter withinlast7 ts - withinlast7 t = d >= addDays (-7) today && (d<=today) where d = ltdate t + withinlast7 t = d >= addDays (-7) today && (d<=today) where d = tdate t txnrate7 = fromIntegral tnum7 / 7 :: Double diff --git a/Commands/UI.hs b/Commands/UI.hs --- a/Commands/UI.hs +++ b/Commands/UI.hs @@ -52,7 +52,8 @@ v <- mkVty DisplayRegion w h <- display_bounds $ terminal v let opts' = SubTotal:opts - let a = enter BalanceScreen + t <- getCurrentLocalTime + let a = enter t BalanceScreen AppState { av=v ,aw=fromIntegral w @@ -71,15 +72,16 @@ go a@AppState{av=av,aopts=opts} = do when (notElem DebugNoUI opts) $ update av (renderScreen a) k <- next_event av + t <- getCurrentLocalTime case k of EvResize x y -> go $ resize x y a EvKey (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg} - EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter BalanceScreen a - EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter RegisterScreen a - EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter PrintScreen a - EvKey KRight [] -> go $ drilldown a - EvKey KEnter [] -> go $ drilldown a - EvKey KLeft [] -> go $ backout a + EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter t BalanceScreen a + EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter t RegisterScreen a + EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter t PrintScreen a + EvKey KRight [] -> go $ drilldown t a + EvKey KEnter [] -> go $ drilldown t a + EvKey KLeft [] -> go $ backout t a EvKey KUp [] -> go $ moveUpAndPushEdge a EvKey KDown [] -> go $ moveDownAndPushEdge a EvKey KHome [] -> go $ moveToTop a @@ -208,32 +210,32 @@ screen a = scr where (Loc scr _ _) = loc a -- | Enter a new screen, saving the old ui location on the stack. -enter :: Screen -> AppState -> AppState -enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a -enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a -enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter :: LocalTime -> Screen -> AppState -> AppState +enter t scr@BalanceScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter t scr@RegisterScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter t scr@PrintScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a -resetTrailAndEnter scr = enter scr . clearLocs +resetTrailAndEnter t scr = enter t scr . clearLocs -- | Regenerate the display data appropriate for the current screen. -updateData :: AppState -> AppState -updateData a@AppState{aopts=opts,aargs=args,aledger=l} = +updateData :: LocalTime -> AppState -> AppState +updateData t a@AppState{aopts=opts,aargs=args,aledger=l} = case screen a of - BalanceScreen -> a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} - RegisterScreen -> a{abuf=lines $ showRegisterReport opts args l} - PrintScreen -> a{abuf=lines $ showLedgerTransactions opts args l} + BalanceScreen -> a{abuf=lines $ showBalanceReport opts (optsToFilterSpec opts args t) l, aargs=[]} + RegisterScreen -> a{abuf=lines $ showRegisterReport opts (optsToFilterSpec opts args t) l} + PrintScreen -> a{abuf=lines $ showTransactions (optsToFilterSpec opts args t) l} -backout :: AppState -> AppState -backout a | screen a == BalanceScreen = a - | otherwise = updateData $ popLoc a +backout :: LocalTime -> AppState -> AppState +backout t a | screen a == BalanceScreen = a + | otherwise = updateData t $ popLoc a -drilldown :: AppState -> AppState -drilldown a = +drilldown :: LocalTime -> AppState -> AppState +drilldown t a = case screen a of - BalanceScreen -> enter RegisterScreen a{aargs=[currentAccountName a]} - RegisterScreen -> scrollToLedgerTransaction e $ enter PrintScreen a + BalanceScreen -> enter t RegisterScreen a{aargs=[currentAccountName a]} + RegisterScreen -> scrollToTransaction e $ enter t PrintScreen a PrintScreen -> a - where e = currentLedgerTransaction a + where e = currentTransaction a -- | Get the account name currently highlighted by the cursor on the -- balance screen. Results undefined while on other screens. @@ -260,34 +262,30 @@ -- | If on the print screen, move the cursor to highlight the specified entry -- (or a reasonable guess). Doesn't work. -scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState -scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a +scrollToTransaction :: Maybe Transaction -> AppState -> AppState +scrollToTransaction Nothing a = a +scrollToTransaction (Just t) a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a where - entryfirstline = head $ lines $ showLedgerTransaction e + entryfirstline = head $ lines $ showTransaction t halfph = pageHeight a `div` 2 y = fromMaybe 0 $ findIndex (== entryfirstline) buf sy = max 0 $ y - halfph cy = y - sy --- | Get the entry containing the transaction currently highlighted by the --- cursor on the register screen (or best guess). Results undefined while --- on other screens. Doesn't work. -currentLedgerTransaction :: AppState -> LedgerTransaction -currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t +-- | Get the transaction containing the posting currently highlighted by +-- the cursor on the register screen (or best guess). Results undefined +-- while on other screens. +currentTransaction :: AppState -> Maybe Transaction +currentTransaction a@AppState{aledger=l,abuf=buf} = ptransaction p where - t = safehead nulltxn $ filter ismatch $ ledgerTransactions l - ismatch t = tdate t == parsedate (take 10 datedesc) - && take 70 (showtxn False t nullmixedamt) == (datedesc ++ acctamt) + p = safehead nullposting $ filter ismatch $ ledgerPostings l + ismatch p = postingDate p == parsedate (take 10 datedesc) + && take 70 (showposting False p nullmixedamt) == (datedesc ++ acctamt) datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ safehead "" rest : reverse above acctamt = drop 32 $ safehead "" rest safehead d ls = if null ls then d else head ls (above,rest) = splitAt y buf y = posY a - --- | Get the entry which contains the given transaction. --- Will raise an error if there are problems. -entryContainingTransaction :: AppState -> Transaction -> LedgerTransaction -entryContainingTransaction AppState{aledger=l} t = ledger_txns (rawledger l) !! tnum t -- renderers diff --git a/Commands/Web.hs b/Commands/Web.hs --- a/Commands/Web.hs +++ b/Commands/Web.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} {-| A web-based UI. @@ -6,6 +6,7 @@ module Commands.Web where +import Codec.Binary.UTF8.String (decodeString) import Control.Applicative.Error (Failing(Success,Failure)) import Control.Concurrent import Control.Monad.Reader (ask) @@ -23,6 +24,11 @@ import Network.Loli.Type (AppUnit) import Network.Loli.Utils (update) import Options hiding (value) +#ifdef MAKE +import Paths_hledger_make (getDataFileName) +#else +import Paths_hledger (getDataFileName) +#endif import System.Directory (getModificationTime) import System.IO.Storage (withStore, putValue, getValue) import System.Process (readProcess) @@ -36,13 +42,14 @@ import qualified Hack.Contrib.Response (redirect) -- import qualified Text.XHtml.Strict as H -import Commands.Add (addTransaction) +import Commands.Add (ledgerAddTransaction) import Commands.Balance import Commands.Histogram import Commands.Print import Commands.Register import Ledger -import Utils (openBrowserOn, readLedgerWithOpts) +import Utils (openBrowserOn) +import Ledger.IO (readLedger) -- import Debug.Trace -- strace :: Show a => a -> a @@ -80,14 +87,14 @@ ledgerFileModifiedTime l | null path = getClockTime | otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime - where path = filepath $ rawledger l + where path = filepath $ journal l ledgerFileReadTime :: Ledger -> ClockTime -ledgerFileReadTime l = filereadtime $ rawledger l +ledgerFileReadTime l = filereadtime $ journal l reload :: Ledger -> IO Ledger reload l = do - l' <- readLedgerWithOpts [] [] (filepath $ rawledger l) + l' <- readLedger (filepath $ journal l) putValue "hledger" "ledger" l' return l' @@ -99,24 +106,25 @@ -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer) if newer then do - when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ rawledger l) + when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ journal l) reload l else return l -- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger --- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (rawledgertext l) (rawledger l) +-- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l) server :: [Opt] -> [String] -> Ledger -> IO () server opts args l = -- server initialisation withStore "hledger" $ do -- IO () + t <- getCurrentLocalTime + webfiles <- getDataFileName "web" putValue "hledger" "ledger" l -- XXX hack-happstack abstraction leak hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname" runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO () \env -> do -- IO Response -- general request handler - printf $ "request\n" let a = intercalate "+" $ reqparam env "a" p = intercalate "+" $ reqparam env "p" opts' = opts ++ [Period p] @@ -124,20 +132,20 @@ l' <- fromJust `fmap` getValue "hledger" "ledger" l'' <- reloadIfChanged opts' args' l' -- declare path-specific request handlers - let command :: [String] -> ([Opt] -> [String] -> Ledger -> String) -> AppUnit - command msgs f = string msgs $ f opts' args' l'' + let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit + command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l'' (loli $ -- State Loli () -> (Env -> IO Response) do - get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli () + get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli () get "/register" $ command [] showRegisterReport get "/histogram" $ command [] showHistogram - get "/journal" $ ledgerpage [] l'' (showLedgerTransactions opts' args') - post "/journal" $ handleAddform l'' + get "/transactions" $ ledgerpage [] l'' (showTransactions (optsToFilterSpec opts' args' t)) + post "/transactions" $ handleAddform l'' get "/env" $ getenv >>= (text . show) get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params) get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs) - public (Just "Commands/Web") ["/static"] - get "/" $ redirect ("journal") Nothing + public (Just webfiles) ["/style.css"] + get "/" $ redirect ("transactions") Nothing ) env ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit @@ -186,7 +194,7 @@ - + <% title %> @@ -201,8 +209,8 @@ getParamOrNull p = fromMaybe "" `fmap` getParam p @@ -214,7 +222,7 @@ let addparams=(++(printf "?a=%s&p=%s" (urlEncode a) (urlEncode p))) link s = <% s %> @@ -236,8 +244,8 @@ addform :: Hack.Env -> HSP XML addform env = do let inputs = Hack.Contrib.Request.inputs env - date = fromMaybe "" $ lookup "date" inputs - desc = fromMaybe "" $ lookup "desc" inputs + date = decodeString $ fromMaybe "" $ lookup "date" inputs + desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
@@ -260,8 +268,8 @@ transactionfields :: Int -> Hack.Env -> HSP XML transactionfields n env = do let inputs = Hack.Contrib.Request.inputs env - acct = fromMaybe "" $ lookup acctvar inputs - amt = fromMaybe "" $ lookup amtvar inputs + acct = decodeString $ fromMaybe "" $ lookup acctvar inputs + amt = decodeString $ fromMaybe "" $ lookup amtvar inputs [NBSP][NBSP] @@ -278,17 +286,18 @@ handleAddform l = do env <- getenv d <- io getCurrentDay - handle $ validate env d + t <- io getCurrentLocalTime + handle t $ validate env d where - validate :: Hack.Env -> Day -> Failing LedgerTransaction + validate :: Hack.Env -> Day -> Failing Transaction validate env today = let inputs = Hack.Contrib.Request.inputs env - date = fromMaybe "" $ lookup "date" inputs - desc = fromMaybe "" $ lookup "desc" inputs - acct1 = fromMaybe "" $ lookup "acct1" inputs - amt1 = fromMaybe "" $ lookup "amt1" inputs - acct2 = fromMaybe "" $ lookup "acct2" inputs - amt2 = fromMaybe "" $ lookup "amt2" inputs + date = decodeString $ fromMaybe "today" $ lookup "date" inputs + desc = decodeString $ fromMaybe "" $ lookup "desc" inputs + acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs + amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs + acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs + amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs validateDate "" = ["missing date"] validateDate _ = [] validateDesc "" = ["missing description"] @@ -302,20 +311,20 @@ validateAmt2 _ = [] amt1' = either (const missingamt) id $ parse someamount "" amt1 amt2' = either (const missingamt) id $ parse someamount "" amt2 - t = LedgerTransaction { - ltdate = parsedate $ fixSmartDateStr today date - ,lteffectivedate=Nothing - ,ltstatus=False - ,ltcode="" - ,ltdescription=desc - ,ltcomment="" - ,ltpostings=[ - Posting False acct1 amt1' "" RegularPosting - ,Posting False acct2 amt2' "" RegularPosting + t = Transaction { + tdate = parsedate $ fixSmartDateStr today date + ,teffectivedate=Nothing + ,tstatus=False + ,tcode="" + ,tdescription=desc + ,tcomment="" + ,tpostings=[ + Posting False acct1 amt1' "" RegularPosting (Just t') + ,Posting False acct2 amt2' "" RegularPosting (Just t') ] - ,ltpreceding_comment_lines="" + ,tpreceding_comment_lines="" } - (t', berr) = case balanceLedgerTransaction t of + (t', berr) = case balanceTransaction t of Right t'' -> (t'', []) Left e -> (t, [e]) errs = concat [ @@ -331,10 +340,10 @@ False -> Failure errs True -> Success t' - handle :: Failing LedgerTransaction -> AppUnit - handle (Failure errs) = hsp errs addform - handle (Success t) = do - io $ addTransaction l t >> reload l - ledgerpage [msg] l (showLedgerTransactions [] []) + handle :: LocalTime -> Failing Transaction -> AppUnit + handle _ (Failure errs) = hsp errs addform + handle ti (Success t) = do + io $ ledgerAddTransaction l t >> reload l + ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti)) where msg = printf "Added transaction:\n%s" (show t) diff --git a/Ledger.hs b/Ledger.hs --- a/Ledger.hs +++ b/Ledger.hs @@ -13,13 +13,12 @@ module Ledger.Commodity, module Ledger.Dates, module Ledger.IO, - module Ledger.LedgerTransaction, + module Ledger.Transaction, module Ledger.Ledger, module Ledger.Parse, - module Ledger.RawLedger, + module Ledger.Journal, module Ledger.Posting, module Ledger.TimeLog, - module Ledger.Transaction, module Ledger.Types, module Ledger.Utils, ) @@ -30,12 +29,11 @@ import Ledger.Commodity import Ledger.Dates import Ledger.IO -import Ledger.LedgerTransaction +import Ledger.Transaction import Ledger.Ledger import Ledger.Parse -import Ledger.RawLedger +import Ledger.Journal import Ledger.Posting import Ledger.TimeLog -import Ledger.Transaction import Ledger.Types import Ledger.Utils diff --git a/Ledger/Account.hs b/Ledger/Account.hs --- a/Ledger/Account.hs +++ b/Ledger/Account.hs @@ -4,8 +4,7 @@ - an 'AccountName', -- all 'Transaction's (postings plus ledger transaction info) in the - account, excluding subaccounts +- all 'Posting's 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 @@ -73,6 +73,8 @@ accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] subs = subAccountNamesFrom (expandAccountNames accts) +nullaccountnametree = Node "top" [] + accountNameTreeFrom2 accts = Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts where @@ -164,4 +166,6 @@ | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) | otherwise = done++ss +clipAccountName :: Int -> AccountName -> AccountName +clipAccountName n = accountNameFromComponents . take n . accountNameComponents diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs --- a/Ledger/Amount.hs +++ b/Ledger/Amount.hs @@ -10,31 +10,28 @@ EUR 3.44 GOOG 500 1.5h - 90apples + 90 apples 0 @ -A 'MixedAmount' is zero or more simple amounts: +An amount may also have a per-unit price, or conversion rate, in terms +of some other commodity. If present, this is displayed after \@: @ - $50 + EUR 3 - 16h + $13.55 + AAPL 500 + 6 oranges + EUR 3 \@ $1.35 @ -Amounts often have a price per unit, or conversion rate, in terms of -another commodity. If present, this is displayed after \@: +A 'MixedAmount' is zero or more simple amounts. Mixed amounts are +usually normalised so that there is no more than one amount in each +commodity, and no zero amounts (or, there is just a single zero amount +and no others.): @ - EUR 3 \@ $1.35 + $50 + EUR 3 + 16h + $13.55 + AAPL 500 + 6 oranges + 0 @ -A normalised mixed amount has at most one amount in each commodity-price, -and no zero amounts (or it has just a single zero amount and no others.) - -In principle we can convert an amount to any other commodity to which we -have a known sequence of conversion rates; in practice we only do one -conversion step (eg to show cost basis with -B). - We can do limited arithmetic with simple or mixed amounts: either price-preserving arithmetic with similarly-priced amounts, or price-discarding arithmetic which ignores and discards prices. @@ -88,6 +85,12 @@ -- exchange rate (which is currently always 1). convertAmountTo :: Commodity -> Amount -> Amount convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing + +-- | Convert mixed amount to the specified commodity +convertMixedAmountTo :: Commodity -> MixedAmount -> Amount +convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing + where + total = sum . map (quantity . convertAmountTo c2) $ ams -- | Convert an amount to the commodity of its saved price, if any. costOfAmount :: Amount -> Amount diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -1,9 +1,11 @@ {-| +Date parsing and utilities for hledger. + For date and time values, we use the standard Day and UTCTime types. A 'SmartDate' is a date which may be partially-specified or relative. -Eg 2008/12/31, but also 2008/12, 12/31, tomorrow, last week, next year. +Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. We represent these as a triple of strings like (\"2008\",\"12\",\"\"), (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). @@ -115,7 +117,7 @@ span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) --- | Convert a smart date string to an explicit yyyy/mm/dd string using +-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date. fixSmartDateStr :: Day -> String -> String fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d @@ -422,3 +424,5 @@ nulldatespan = DateSpan Nothing Nothing mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate + +nulldate = parsedate "1900/01/01" diff --git a/Ledger/IO.hs b/Ledger/IO.hs --- a/Ledger/IO.hs +++ b/Ledger/IO.hs @@ -5,14 +5,15 @@ module Ledger.IO where import Control.Monad.Error -import Ledger.Ledger (cacheLedger) +import Ledger.Ledger (cacheLedger', nullledger) import Ledger.Parse (parseLedger) -import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger,rawLedgerSelectingDate) -import Ledger.Types (FilterSpec(..),WhichDate(..),DateSpan(..),RawLedger(..),Ledger(..)) +import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..)) import Ledger.Utils (getCurrentLocalTime) +import Ledger.Dates (nulldatespan) import System.Directory (getHomeDirectory) import System.Environment (getEnv) -import System.IO +import Prelude hiding (readFile) +import System.IO.UTF8 import System.FilePath (()) import System.Time (getClockTime) @@ -23,14 +24,16 @@ timelogdefaultfilename = ".timelog" nullfilterspec = FilterSpec { - datespan=DateSpan Nothing Nothing - ,cleared=Nothing - ,real=False - ,costbasis=False - ,acctpats=[] - ,descpats=[] - ,whichdate=ActualDate - } + datespan=nulldatespan + ,cleared=Nothing + ,real=False + ,empty=False + ,costbasis=False + ,acctpats=[] + ,descpats=[] + ,whichdate=ActualDate + ,depth=Nothing + } -- | Get the user's default ledger file path. myLedgerPath :: IO String @@ -58,36 +61,27 @@ -- | Read a ledger from this file, with no filtering, or give an error. readLedger :: FilePath -> IO Ledger -readLedger = readLedgerWithFilterSpec nullfilterspec - --- | Read a ledger from this file, filtering according to the filter spec., --- | or give an error. -readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger -readLedgerWithFilterSpec fspec f = do - s <- readFile f +readLedger f = do t <- getClockTime - rl <- rawLedgerFromString s - return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t} + s <- readFile f + j <- journalFromString s + return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}} --- | Read a RawLedger from the given string, using the current time as +-- -- | Read a ledger from this file, filtering according to the filter spec., +-- -- | or give an error. +-- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger +-- readLedgerWithFilterSpec fspec f = do +-- s <- readFile f +-- t <- getClockTime +-- rl <- journalFromString s +-- return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t} + +-- | Read a Journal from the given string, using the current time as -- reference time, or give a parse error. -rawLedgerFromString :: String -> IO RawLedger -rawLedgerFromString s = do +journalFromString :: String -> IO Journal +journalFromString s = do t <- getCurrentLocalTime liftM (either error id) $ runErrorT $ parseLedger t "(string)" s - --- | Convert a RawLedger to a canonicalised, cached and filtered Ledger. -filterAndCacheLedger :: FilterSpec -> String -> RawLedger -> Ledger -filterAndCacheLedger (FilterSpec{datespan=datespan,cleared=cleared,real=real, - costbasis=costbasis,acctpats=acctpats, - descpats=descpats,whichdate=whichdate}) - rawtext - rl = - (cacheLedger acctpats - $ filterRawLedger datespan descpats cleared real - $ rawLedgerSelectingDate whichdate - $ canonicaliseAmounts costbasis rl - ){rawledgertext=rawtext} -- -- | Expand ~ in a file path (does not handle ~name). -- tildeExpand :: FilePath -> IO FilePath diff --git a/Ledger/Journal.hs b/Ledger/Journal.hs new file mode 100644 --- /dev/null +++ b/Ledger/Journal.hs @@ -0,0 +1,321 @@ +{-| + +A 'Journal' is a parsed ledger file, containing 'Transaction's. +It can be filtered and massaged in various ways, then \"crunched\" +to form a 'Ledger'. + +-} + +module Ledger.Journal +where +import qualified Data.Map as Map +import Data.Map (findWithDefault, (!)) +import System.Time (ClockTime(TOD)) +import Ledger.Utils +import Ledger.Types +import Ledger.AccountName +import Ledger.Amount +import Ledger.Transaction (ledgerTransactionWithDate) +import Ledger.Posting +import Ledger.TimeLog + + +instance Show Journal where + show j = printf "Journal with %d transactions, %d accounts: %s" + (length (jtxns j) + + length (jmodifiertxns j) + + length (jperiodictxns j)) + (length accounts) + (show accounts) + -- ++ (show $ journalTransactions l) + where accounts = flatten $ journalAccountNameTree j + +nulljournal :: Journal +nulljournal = Journal { jmodifiertxns = [] + , jperiodictxns = [] + , jtxns = [] + , open_timelog_entries = [] + , historical_prices = [] + , final_comment_lines = [] + , filepath = "" + , filereadtime = TOD 0 0 + , jtext = "" + } + +addTransaction :: Transaction -> Journal -> Journal +addTransaction t l0 = l0 { jtxns = t : jtxns l0 } + +addModifierTransaction :: ModifierTransaction -> Journal -> Journal +addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 } + +addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal +addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 } + +addHistoricalPrice :: HistoricalPrice -> Journal -> Journal +addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 } + +addTimeLogEntry :: TimeLogEntry -> Journal -> Journal +addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } + +journalPostings :: Journal -> [Posting] +journalPostings = concatMap tpostings . jtxns + +journalAccountNamesUsed :: Journal -> [AccountName] +journalAccountNamesUsed = accountNamesFromPostings . journalPostings + +journalAccountNames :: Journal -> [AccountName] +journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed + +journalAccountNameTree :: Journal -> Tree AccountName +journalAccountNameTree = accountNameTreeFrom . journalAccountNames + +-- Various kinds of filtering on journals. We do it differently depending +-- on the command. + +-- | Keep only transactions we are interested in, as described by +-- the filter specification. May also massage the data a little. +filterJournalTransactions :: FilterSpec -> Journal -> Journal +filterJournalTransactions FilterSpec{datespan=datespan + ,cleared=cleared + -- ,real=real + -- ,empty=empty + -- ,costbasis=_ + ,acctpats=apats + ,descpats=dpats + ,whichdate=whichdate + ,depth=depth + } = + filterJournalTransactionsByClearedStatus cleared . + filterJournalPostingsByDepth depth . + filterJournalTransactionsByAccount apats . + filterJournalTransactionsByDescription dpats . + filterJournalTransactionsByDate datespan . + journalSelectingDate whichdate + +-- | Keep only postings we are interested in, as described by +-- the filter specification. May also massage the data a little. +-- This can leave unbalanced transactions. +filterJournalPostings :: FilterSpec -> Journal -> Journal +filterJournalPostings FilterSpec{datespan=datespan + ,cleared=cleared + ,real=real + ,empty=empty +-- ,costbasis=costbasis + ,acctpats=apats + ,descpats=dpats + ,whichdate=whichdate + ,depth=depth + } = + filterJournalPostingsByRealness real . + filterJournalPostingsByClearedStatus cleared . + filterJournalPostingsByEmpty empty . + filterJournalPostingsByDepth depth . + filterJournalPostingsByAccount apats . + filterJournalTransactionsByDescription dpats . + filterJournalTransactionsByDate datespan . + journalSelectingDate whichdate + +-- | Keep only ledger transactions whose description matches the description patterns. +filterJournalTransactionsByDescription :: [String] -> Journal -> Journal +filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts} + where matchdesc = matchpats pats . tdescription + +-- | 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. +filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal +filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end + +-- | Keep only ledger transactions which have the requested +-- cleared/uncleared status, if there is one. +filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal +filterJournalTransactionsByClearedStatus Nothing j = j +filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match = (==val).tstatus + +-- | Keep only postings which have the requested cleared/uncleared status, +-- if there is one. +filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal +filterJournalPostingsByClearedStatus Nothing j = j +filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps} + +-- | Strip out any virtual postings, if the flag is true, otherwise do +-- no filtering. +filterJournalPostingsByRealness :: Bool -> Journal -> Journal +filterJournalPostingsByRealness False l = l +filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps} + +-- | Strip out any postings with zero amount, unless the flag is true. +filterJournalPostingsByEmpty :: Bool -> Journal -> Journal +filterJournalPostingsByEmpty True l = l +filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps} + +-- | Keep only transactions which affect accounts deeper than the specified depth. +filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal +filterJournalTransactionsByDepth Nothing j = j +filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} = + j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)} + +-- | Strip out any postings to accounts deeper than the specified depth +-- (and any ledger transactions which have no postings as a result). +filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal +filterJournalPostingsByDepth Nothing j = j +filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} = + j{jtxns=filter (not . null . tpostings) $ map filtertxns ts} + where filtertxns t@Transaction{tpostings=ps} = + t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} + +-- | Keep only transactions which affect accounts matched by the account patterns. +filterJournalTransactionsByAccount :: [String] -> Journal -> Journal +filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match = any (matchpats apats . paccount) . tpostings + +-- | Keep only postings which affect accounts matched by the account patterns. +-- This can leave transactions unbalanced. +filterJournalPostingsByAccount :: [String] -> Journal -> Journal +filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps} + +-- | Convert this journal's transactions' primary date to either the +-- actual or effective date. +journalSelectingDate :: WhichDate -> Journal -> Journal +journalSelectingDate ActualDate j = j +journalSelectingDate EffectiveDate j = + j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j} + +-- | Convert all the journal's amounts to their canonical display settings. +-- Ie, in each commodity, amounts will use the display settings of the first +-- amount detected, and the greatest precision of the amounts detected. +-- Also, missing unit prices are added if known from the price history. +-- Also, amounts are converted to cost basis if that flag is active. +-- XXX refactor +canonicaliseAmounts :: Bool -> Journal -> Journal +canonicaliseAmounts costbasis j@Journal{jtxns=ts} = j{jtxns=map fixledgertransaction ts} + where + fixledgertransaction (Transaction d ed s c de co ts pr) = Transaction d ed s c de co (map fixrawposting ts) pr + where + fixrawposting (Posting s ac a c t txn) = Posting s ac (fixmixedamount a) c t txn + fixmixedamount (Mixed as) = Mixed $ map fixamount as + fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity + fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a) + canonicalcommoditymap = + Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols, + let cs = commoditymap ! s, + let firstc = head cs, + let maxp = maximum $ map precision cs + ] + commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] + commoditieswithsymbol s = filter ((s==) . symbol) commodities + commoditysymbols = nub $ map symbol commodities + commodities = map commodity (concatMap (amounts . pamount) (journalPostings j) + ++ concatMap (amounts . hamount) (historical_prices j)) + fixprice :: Amount -> Amount + fixprice a@Amount{price=Just _} = a + fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c} + + -- | Get the price for a commodity on the specified day from the price database, if known. + -- Does only one lookup step, ie will not look up the price of a price. + journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount + journalHistoricalPriceFor j d Commodity{symbol=s} = do + let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j + case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a + _ -> Nothing + where + canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as + where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} = + a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap} + +-- | Get just the amounts from a ledger, in the order parsed. +journalAmounts :: Journal -> [MixedAmount] +journalAmounts = map pamount . journalPostings + +-- | Get just the ammount commodities from a ledger, in the order parsed. +journalCommodities :: Journal -> [Commodity] +journalCommodities = map commodity . concatMap amounts . journalAmounts + +-- | Get just the amount precisions from a ledger, in the order parsed. +journalPrecisions :: Journal -> [Int] +journalPrecisions = map precision . journalCommodities + +-- | Close any open timelog sessions using the provided current time. +journalConvertTimeLog :: LocalTime -> Journal -> Journal +journalConvertTimeLog t l0 = l0 { jtxns = convertedTimeLog ++ jtxns l0 + , open_timelog_entries = [] + } + where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 + +-- | The (fully specified) date span containing all the raw ledger's transactions, +-- or DateSpan Nothing Nothing if there are none. +journalDateSpan :: Journal -> DateSpan +journalDateSpan j + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) + where + ts = sortBy (comparing tdate) $ jtxns j + +-- | Check if a set of ledger account/description patterns matches the +-- given account name or entry description. Patterns are case-insensitive +-- regular expression strings; those beginning with - are anti-patterns. +matchpats :: [String] -> String -> Bool +matchpats pats str = + (null positives || any match positives) && (null negatives || not (any match negatives)) + where + (negatives,positives) = partition isnegativepat pats + match "" = True + match pat = containsRegex (abspat pat) str + negateprefix = "not:" + isnegativepat = (negateprefix `isPrefixOf`) + abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat + +-- | Calculate the account tree and account balances from a journal's +-- postings, and return the results for efficient lookup. +crunchJournal :: Journal -> (Tree AccountName, Map.Map AccountName Account) +crunchJournal j = (ant,amap) + where + (ant,psof,_,inclbalof) = (groupPostings . journalPostings) j + amap = Map.fromList [(a, acctinfo a) | a <- flatten ant] + acctinfo a = Account a (psof a) (inclbalof a) + +-- | Given a list of postings, return an account name tree and three query +-- functions that fetch postings, balance, and subaccount-including +-- balance by account name. This factors out common logic from +-- cacheLedger and summarisePostingsInDateSpan. +groupPostings :: [Posting] -> (Tree AccountName, + (AccountName -> [Posting]), + (AccountName -> MixedAmount), + (AccountName -> MixedAmount)) +groupPostings ps = (ant,psof,exclbalof,inclbalof) + where + anames = sort $ nub $ map paccount ps + ant = accountNameTreeFrom $ expandAccountNames anames + allanames = flatten ant + pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames]) + psof = (pmap !) + balmap = Map.fromList $ flatten $ calculateBalances ant psof + exclbalof = fst . (balmap !) + inclbalof = snd . (balmap !) + +-- | Add subaccount-excluding and subaccount-including balances to a tree +-- of account names somewhat efficiently, given a function that looks up +-- transactions by account name. +calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount)) +calculateBalances ant psof = addbalances ant + where + addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' + where + bal = sumPostings $ psof a + subsbal = sum $ map (snd . snd . root) subs' + subs' = map addbalances subs + +-- | Convert a list of postings to a map from account name to that +-- account's postings. +postingsByAccount :: [Posting] -> Map.Map AccountName [Posting] +postingsByAccount ps = m' + where + sortedps = sortBy (comparing paccount) ps + groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps + m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -1,11 +1,11 @@ {-| 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 +from a 'Journal' for easier querying. Also it typically has had +uninteresting 'Transaction's and 'Posting's filtered out. It contains: -- the original unfiltered 'RawLedger' +- the original unfiltered 'Journal' - a tree of 'AccountName's @@ -54,88 +54,56 @@ module Ledger.Ledger where import qualified Data.Map as Map -import Data.Map ((!)) +import Data.Map (findWithDefault, fromList) import Ledger.Utils import Ledger.Types -import Ledger.Account () +import Ledger.Account (nullacct) import Ledger.AccountName -import Ledger.Transaction -import Ledger.RawLedger +import Ledger.Journal +import Ledger.Posting instance Show Ledger where 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 (jtxns $ journal l) + + length (jmodifiertxns $ journal l) + + length (jperiodictxns $ journal l)) (length $ accountnames l) (showtree $ accountnametree l) --- | Convert a raw ledger to a more efficient cached type, described above. -cacheLedger :: [String] -> RawLedger -> Ledger -cacheLedger apats l = Ledger{rawledgertext="",rawledger=l,accountnametree=ant,accountmap=acctmap} - where - (ant,txnsof,_,inclbalof) = groupTransactions $ filtertxns apats $ rawLedgerTransactions l - acctmap = Map.fromList [(a, mkacct a) | a <- flatten ant] - where mkacct a = Account a (txnsof a) (inclbalof a) +nullledger :: Ledger +nullledger = Ledger{ + journal = nulljournal, + accountnametree = nullaccountnametree, + accountmap = fromList [] + } --- | Given a list of transactions, return an account name tree and three --- query functions that fetch transactions, balance, and --- subaccount-including balance by account name. --- This is to factor out common logic from cacheLedger and --- summariseTransactionsInDateSpan. -groupTransactions :: [Transaction] -> (Tree AccountName, - (AccountName -> [Transaction]), - (AccountName -> MixedAmount), - (AccountName -> MixedAmount)) -groupTransactions ts = (ant,txnsof,exclbalof,inclbalof) - where - txnanames = sort $ nub $ map taccount ts - ant = accountNameTreeFrom $ expandAccountNames txnanames - allanames = flatten ant - txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allanames]) - balmap = Map.fromList $ flatten $ calculateBalances ant txnsof - txnsof = (txnmap !) - exclbalof = fst . (balmap !) - inclbalof = snd . (balmap !) --- debug --- txnsof a = (txnmap ! (trace ("ts "++a) a)) --- exclbalof a = fst $ (balmap ! (trace ("eb "++a) a)) --- inclbalof a = snd $ (balmap ! (trace ("ib "++a) a)) +-- | Convert a journal to a more efficient cached ledger, described above. +cacheLedger :: Journal -> Ledger +cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal j --- | Add subaccount-excluding and subaccount-including balances to a tree --- of account names somewhat efficiently, given a function that looks up --- transactions by account name. -calculateBalances :: Tree AccountName -> (AccountName -> [Transaction]) -> Tree (AccountName, (MixedAmount, MixedAmount)) -calculateBalances ant txnsof = addbalances ant - where - addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' - where - bal = sumTransactions $ txnsof a - subsbal = sum $ map (snd . snd . root) subs' - subs' = map addbalances subs +-- | Add (or recalculate) the cached journal info in a ledger. +cacheLedger' :: Ledger -> CachedLedger +cacheLedger' l = l{accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal $ journal l --- | Convert a list of transactions to a map from account name to the list --- of all transactions in that account. -transactionsByAccount :: [Transaction] -> Map.Map AccountName [Transaction] -transactionsByAccount ts = m' - where - 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 +-- | Like cacheLedger, but filtering the journal first. +cacheLedger'' filterspec l@Ledger{journal=j} = l{journal=j',accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal j' + j' = filterJournalPostings filterspec{depth=Nothing} j -filtertxns :: [String] -> [Transaction] -> [Transaction] -filtertxns apats = filter (matchpats apats . taccount) +type CachedLedger = Ledger -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . flatten . accountnametree --- | Get the named account from a ledger. +-- | Get the named account from a (cached) ledger. +-- If the ledger has not been cached (with crunchJournal or +-- cacheLedger'), this returns the null account. ledgerAccount :: Ledger -> AccountName -> Account -ledgerAccount = (!) . accountmap +ledgerAccount l a = findWithDefault nullacct a $ accountmap l -- | List a ledger's accounts, in tree order ledgerAccounts :: Ledger -> [Account] @@ -154,9 +122,9 @@ ledgerSubAccounts l Account{aname=a} = map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l --- | List a ledger's "transactions", ie postings with transaction info attached. -ledgerTransactions :: Ledger -> [Transaction] -ledgerTransactions = rawLedgerTransactions . rawledger +-- | List a ledger's postings, in the order parsed. +ledgerPostings :: Ledger -> [Posting] +ledgerPostings = journalPostings . journal -- | Get a ledger's tree of accounts to the specified depth. ledgerAccountTree :: Int -> Ledger -> Tree Account @@ -169,11 +137,7 @@ -- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan -ledgerDateSpan l - | null ts = DateSpan Nothing Nothing - | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) - where - ts = sortBy (comparing tdate) $ ledgerTransactions l +ledgerDateSpan = postingsDateSpan . ledgerPostings -- | Convenience aliases. accountnames :: Ledger -> [AccountName] @@ -194,11 +158,11 @@ subaccounts :: Ledger -> Account -> [Account] subaccounts = ledgerSubAccounts -transactions :: Ledger -> [Transaction] -transactions = ledgerTransactions +postings :: Ledger -> [Posting] +postings = ledgerPostings commodities :: Ledger -> [Commodity] -commodities = nub . rawLedgerCommodities . rawledger +commodities = nub . journalCommodities . journal accounttree :: Int -> Ledger -> Tree Account accounttree = ledgerAccountTree @@ -210,7 +174,7 @@ -- datespan = ledgerDateSpan rawdatespan :: Ledger -> DateSpan -rawdatespan = rawLedgerDateSpan . rawledger +rawdatespan = journalDateSpan . journal ledgeramounts :: Ledger -> [MixedAmount] -ledgeramounts = rawLedgerAmounts . rawledger +ledgeramounts = journalAmounts . journal diff --git a/Ledger/LedgerTransaction.hs b/Ledger/LedgerTransaction.hs deleted file mode 100644 --- a/Ledger/LedgerTransaction.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-| - -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 = showLedgerTransactionUnelided - -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", - lteffectivedate=Nothing, - 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 False - -showLedgerTransactionUnelided :: LedgerTransaction -> String -showLedgerTransactionUnelided = showLedgerTransaction' False False - -showLedgerTransactionForPrint :: Bool -> LedgerTransaction -> String -showLedgerTransactionForPrint effective = showLedgerTransaction' False effective - -showLedgerTransaction' :: Bool -> Bool -> LedgerTransaction -> String -showLedgerTransaction' elide effective t = - unlines $ [description] ++ showpostings (ltpostings t) ++ [""] - where - description = concat [date, status, code, desc, comment] - date | effective = showdate $ fromMaybe (ltdate t) $ lteffectivedate t - | otherwise = showdate (ltdate t) ++ maybe "" showedate (lteffectivedate t) - status = if ltstatus t then " *" else "" - code = if length (ltcode t) > 0 then printf " (%s)" $ ltcode t else "" - desc = ' ' : ltdescription t - comment = if null com then "" else " ; " ++ com where com = ltcomment t - showdate = printf "%-10s" . showDate - showedate = printf "=%s" . showdate - 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 ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) - w = maximum $ map (length . paccount) ps - showamount = printf "%12s" . showMixedAmount - showcomment s = if null s then "" else " ; "++s - showstatus p = if pstatus p then "* " else "" - --- | Show an account name, clipped to the given width if any, and --- appropriately bracketed/parenthesised for the given posting type. -showAccountName :: Maybe Int -> PostingType -> AccountName -> String -showAccountName w = fmt - where - fmt RegularPosting = take w' - fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse - fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse - w' = fromMaybe 999999 w - parenthesise s = "("++s++")" - bracket s = "["++s++"]" - -isLedgerTransactionBalanced :: LedgerTransaction -> Bool -isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) = - 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 - (_, missingamounts') = partition hasAmount 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" - --- | Convert the primary date to either the actual or effective date. -ledgerTransactionWithDate :: WhichDate -> LedgerTransaction -> LedgerTransaction -ledgerTransactionWithDate ActualDate t = t -ledgerTransactionWithDate EffectiveDate t = t{ltdate=fromMaybe (ltdate t) (lteffectivedate t)} - diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -18,9 +18,9 @@ import Ledger.Dates import Ledger.AccountName (accountNameFromComponents,accountNameComponents) import Ledger.Amount -import Ledger.LedgerTransaction +import Ledger.Transaction import Ledger.Posting -import Ledger.RawLedger +import Ledger.Journal import System.FilePath(takeDirectory,combine) @@ -63,21 +63,21 @@ -- let's get to it -parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger +parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-" 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, -- we pass it in for repeatability. -parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger +parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO Journal parseLedger reftime inname intxt = case runParser ledgerFile emptyCtx inname intxt of - Right m -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` return rawLedgerEmpty + Right m -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal Left err -> throwError $ show err -ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerFile = do items <- many ledgerItem eof return $ liftM (foldr (.) id) $ sequence items @@ -86,7 +86,7 @@ -- 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 . addTransaction) ledgerTransaction , liftM (return . addModifierTransaction) ledgerModifierTransaction , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction , liftM (return . addHistoricalPrice) ledgerHistoricalPrice @@ -95,7 +95,7 @@ , liftM (return . addTimeLogEntry) timelogentry ] -ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDirective = do char '!' "directive" directive <- many nonspace case directive of @@ -104,7 +104,7 @@ "end" -> ledgerAccountEnd _ -> mzero -ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerInclude = do many1 spacenonewline filename <- restofline outerState <- getState @@ -127,19 +127,19 @@ return $ homedir ++ drop 1 inname | otherwise = return inname -ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountBegin = do many1 spacenonewline parent <- ledgeraccountname newline pushParentAccount parent return $ return id -ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountEnd = popParentAccount >> return (return id) -- parsers --- | Parse a RawLedger from either a ledger file or a timelog file. +-- | Parse a Journal from either a ledger file or a timelog file. -- It tries first the timelog parser then the ledger parser; this means -- parse errors for ledgers are useful while those for timelogs are not. @@ -295,7 +295,7 @@ return $ HistoricalPrice date symbol price -- like ledgerAccountBegin, updates the LedgerFileCtx -ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDefaultYear = do char 'Y' "default year" many spacenonewline @@ -307,18 +307,18 @@ -- | Try to parse a ledger entry. If we successfully parse an entry, ensure it is balanced, -- and if we cannot, raise an error. -ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction +ledgerTransaction :: GenParser Char LedgerFileCtx Transaction ledgerTransaction = do date <- ledgerdate "transaction" - edate <- try (ledgereffectivedate "effective date") <|> return Nothing + edate <- try (ledgereffectivedate date "effective date") <|> return Nothing status <- ledgerstatus code <- ledgercode description <- many1 spacenonewline >> liftM rstrip (many1 (noneOf ";\n") "description") comment <- ledgercomment <|> return "" restofline postings <- ledgerpostings - let t = LedgerTransaction date edate status code description comment postings "" - case balanceLedgerTransaction t of + let t = txnTieKnot $ Transaction date edate status code description comment postings "" + case balanceTransaction t of Right t' -> return t' Left err -> fail err @@ -352,10 +352,17 @@ let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) return $ LocalTime day tod -ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day) -ledgereffectivedate = do +ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx (Maybe Day) +ledgereffectivedate actualdate = do char '=' - edate <- ledgerdate + -- kludgily use actual date for default year + let withDefaultYear d p = do + y <- getYear + let (y',_,_) = toGregorian d in setYear y' + r <- p + when (isJust y) $ setYear $ fromJust y + return r + edate <- withDefaultYear actualdate ledgerdate return $ Just edate ledgerstatus :: GenParser Char st Bool @@ -392,7 +399,7 @@ many spacenonewline comment <- ledgercomment <|> return "" restofline - return (Posting status account' amount comment ptype) + return (Posting status account' amount comment ptype Nothing) -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName @@ -557,8 +564,8 @@ -- misc parsing -- | Parse a --display expression which is a simple date predicate, like --- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate. -datedisplayexpr :: GenParser Char st (Transaction -> Bool) +-- "d>[DATE]" or "d<=[DATE]", and return a posting-matching predicate. +datedisplayexpr :: GenParser Char st (Posting -> Bool) datedisplayexpr = do char 'd' op <- compareop @@ -566,7 +573,7 @@ (y,m,d) <- smartdate char ']' let date = parsedate $ printf "%04s/%02s/%02s" y m d - test op = return $ (`op` date) . tdate + test op = return $ (`op` date) . postingDate case op of "<" -> test (<) "<=" -> test (<=) diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs --- a/Ledger/Posting.hs +++ b/Ledger/Posting.hs @@ -1,11 +1,9 @@ {-| 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'. +single 'Account'. Each 'Transaction' contains two or more postings which +should add up to 0. Postings also reference their parent transaction, so +we can get a date or description for a posting (from the transaction). -} @@ -15,33 +13,34 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName +import Ledger.Dates (nulldate) instance Show Posting where show = showPosting -nullrawposting = Posting False "" nullmixedamt "" RegularPosting +nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing showPosting :: Posting -> String -showPosting (Posting _ a amt com ttype) = +showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = concatTopPadded [showaccountname a ++ " ", showamount amt, comment] where ledger3ishlayout = False acctnamewidth = if ledger3ishlayout then 25 else 22 showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width - (bracket,width) = case ttype of + (bracket,width) = case t of BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) _ -> (id,acctnamewidth) showamount = padleft 12 . showMixedAmountOrZero comment = if null com then "" else " ; " ++ com -- XXX refactor -showPostingWithoutPrice (Posting _ a amt com ttype) = +showPostingWithoutPrice (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = concatTopPadded [showaccountname a ++ " ", showamount amt, comment] where ledger3ishlayout = False acctnamewidth = if ledger3ishlayout then 25 else 22 showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width - (bracket,width) = case ttype of + (bracket,width) = case t of BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) _ -> (id,acctnamewidth) @@ -64,4 +63,33 @@ | head a == '[' && last a == ']' = BalancedVirtualPosting | head a == '(' && last a == ')' = VirtualPosting | otherwise = RegularPosting + +accountNamesFromPostings :: [Posting] -> [AccountName] +accountNamesFromPostings = nub . map paccount + +sumPostings :: [Posting] -> MixedAmount +sumPostings = sum . map pamount + +postingDate :: Posting -> Day +postingDate p = maybe nulldate tdate $ ptransaction p + +postingCleared :: Posting -> Bool +postingCleared p = maybe False tstatus $ ptransaction p + +-- | Does this posting fall within the given date span ? +isPostingInDateSpan :: DateSpan -> Posting -> Bool +isPostingInDateSpan (DateSpan Nothing Nothing) _ = True +isPostingInDateSpan (DateSpan Nothing (Just e)) p = postingDate p < e +isPostingInDateSpan (DateSpan (Just b) Nothing) p = postingDate p >= b +isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p + +isEmptyPosting :: Posting -> Bool +isEmptyPosting = isZeroMixedAmount . pamount + +-- | Get the minimal date span which contains all the postings, or +-- DateSpan Nothing Nothing if there are none. +postingsDateSpan :: [Posting] -> DateSpan +postingsDateSpan [] = DateSpan Nothing Nothing +postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') + where ps' = sortBy (comparing postingDate) ps diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs deleted file mode 100644 --- a/Ledger/RawLedger.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| - -A 'RawLedger' is a parsed ledger file. We call it raw to distinguish from -the cached 'Ledger'. - --} - -module Ledger.RawLedger -where -import qualified Data.Map as Map -import Data.Map (findWithDefault, (!)) -import System.Time (ClockTime(TOD)) -import Ledger.Utils -import Ledger.Types -import Ledger.AccountName -import Ledger.Amount -import Ledger.LedgerTransaction (ledgerTransactionWithDate) -import Ledger.Transaction -import Ledger.Posting -import Ledger.TimeLog - - -instance Show RawLedger where - 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_txns = [] - , periodic_txns = [] - , ledger_txns = [] - , open_timelog_entries = [] - , historical_prices = [] - , final_comment_lines = [] - , filepath = "" - , filereadtime = TOD 0 0 - } - -addLedgerTransaction :: LedgerTransaction -> RawLedger -> RawLedger -addLedgerTransaction t l0 = l0 { ledger_txns = t : ledger_txns l0 } - -addModifierTransaction :: ModifierTransaction -> RawLedger -> RawLedger -addModifierTransaction mt l0 = l0 { modifier_txns = mt : modifier_txns 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 } - -addTimeLogEntry :: TimeLogEntry -> RawLedger -> RawLedger -addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } - -rawLedgerTransactions :: RawLedger -> [Transaction] -rawLedgerTransactions = txnsof . ledger_txns - where txnsof ts = concatMap flattenLedgerTransaction $ zip ts [1..] - -rawLedgerAccountNamesUsed :: RawLedger -> [AccountName] -rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions - -rawLedgerAccountNames :: RawLedger -> [AccountName] -rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed - -rawLedgerAccountNameTree :: RawLedger -> Tree AccountName -rawLedgerAccountNameTree = accountNameTreeFrom . rawLedgerAccountNames - --- | 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] -> Maybe Bool -> Bool -> RawLedger -> RawLedger -filterRawLedger span pats clearedonly realonly = - filterRawLedgerPostingsByRealness realonly . - filterRawLedgerTransactionsByClearedStatus clearedonly . - filterRawLedgerTransactionsByDate span . - filterRawLedgerTransactionsByDescription pats - --- | Keep only ledger transactions whose description matches the description patterns. -filterRawLedgerTransactionsByDescription :: [String] -> RawLedger -> RawLedger -filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp ft) = - RawLedger ms ps (filter matchdesc ts) tls hs f fp ft - where matchdesc = matchpats pats . ltdescription - --- | 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. -filterRawLedgerTransactionsByDate :: DateSpan -> RawLedger -> RawLedger -filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp ft) = - RawLedger ms ps (filter matchdate ts) tls hs f fp ft - where - matchdate t = maybe True (ltdate t>=) begin && maybe True (ltdate t<) end - --- | 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 ft) = - RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp ft - --- | Strip out any virtual postings, if the flag is true, otherwise do --- no filtering. -filterRawLedgerPostingsByRealness :: Bool -> RawLedger -> RawLedger -filterRawLedgerPostingsByRealness False l = l -filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp ft) = - RawLedger mts pts (map filtertxns ts) tls hs f fp ft - where filtertxns t@LedgerTransaction{ltpostings=ps} = t{ltpostings=filter isReal ps} - --- | 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 ft) = - RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp ft - where filtertxns t@LedgerTransaction{ltpostings=ps} = - t{ltpostings=filter ((<= depth) . accountNameLevel . paccount) ps} - --- | 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 ft) = - RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp ft - --- | Convert this ledger's transactions' primary date to either their --- actual or effective date. -rawLedgerSelectingDate :: WhichDate -> RawLedger -> RawLedger -rawLedgerSelectingDate ActualDate rl = rl -rawLedgerSelectingDate EffectiveDate rl = - rl{ledger_txns=map (ledgerTransactionWithDate EffectiveDate) $ ledger_txns rl} - --- | Give all a ledger's amounts their canonical display settings. That --- is, in each commodity, amounts will use the display settings of the --- first amount detected, and the greatest precision of the amounts --- detected. --- Also, missing unit prices are added if known from the price history. --- Also, amounts are converted to cost basis if that flag is active. --- XXX refactor -canonicaliseAmounts :: Bool -> RawLedger -> RawLedger -canonicaliseAmounts costbasis rl@(RawLedger ms ps ts tls hs f fp ft) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp ft - where - fixledgertransaction (LedgerTransaction d ed s c de co ts pr) = LedgerTransaction d ed s c de co (map fixrawposting ts) pr - where - fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t - fixmixedamount (Mixed as) = Mixed $ map fixamount as - fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity - fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a) - canonicalcommoditymap = - Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols, - let cs = commoditymap ! s, - let firstc = head cs, - let maxp = maximum $ map precision cs - ] - commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] - commoditieswithsymbol s = filter ((s==) . symbol) commodities - commoditysymbols = nub $ map symbol commodities - commodities = map commodity (concatMap (amounts . tamount) (rawLedgerTransactions rl) - ++ concatMap (amounts . hamount) (historical_prices rl)) - fixprice :: Amount -> Amount - fixprice a@Amount{price=Just _} = a - fixprice a@Amount{commodity=c} = a{price=rawLedgerHistoricalPriceFor rl d c} - - -- | Get the price for a commodity on the specified day from the price database, if known. - -- Does only one lookup step, ie will not look up the price of a price. - rawLedgerHistoricalPriceFor :: RawLedger -> Day -> Commodity -> Maybe MixedAmount - rawLedgerHistoricalPriceFor rl d Commodity{symbol=s} = do - let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices rl - case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a - _ -> Nothing - where - canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as - where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} = - a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap} - --- | Get just the amounts from a ledger, in the order parsed. -rawLedgerAmounts :: RawLedger -> [MixedAmount] -rawLedgerAmounts = map tamount . rawLedgerTransactions - --- | Get just the ammount commodities from a ledger, in the order parsed. -rawLedgerCommodities :: RawLedger -> [Commodity] -rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts - --- | Get just the amount precisions from a ledger, in the order parsed. -rawLedgerPrecisions :: RawLedger -> [Int] -rawLedgerPrecisions = map precision . rawLedgerCommodities - --- | Close any open timelog sessions using the provided current time. -rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger -rawLedgerConvertTimeLog t l0 = l0 { ledger_txns = convertedTimeLog ++ ledger_txns l0 - , open_timelog_entries = [] - } - where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 - --- | The (fully specified) date span containing all the raw ledger's transactions, --- or DateSpan Nothing Nothing if there are none. -rawLedgerDateSpan :: RawLedger -> DateSpan -rawLedgerDateSpan rl - | 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 - --- | Check if a set of ledger account/description patterns matches the --- given account name or entry description. Patterns are case-insensitive --- regular expression strings; those beginning with - are anti-patterns. -matchpats :: [String] -> String -> Bool -matchpats pats str = - (null positives || any match positives) && (null negatives || not (any match negatives)) - where - (negatives,positives) = partition isnegativepat pats - match "" = True - match pat = containsRegex (abspat pat) str - negateprefix = "not:" - isnegativepat = (negateprefix `isPrefixOf`) - abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -2,7 +2,7 @@ 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. +converted to 'Transactions' and queried like a ledger. -} @@ -12,7 +12,7 @@ import Ledger.Types import Ledger.Dates import Ledger.Commodity -import Ledger.LedgerTransaction +import Ledger.Transaction instance Show TimeLogEntry where show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) @@ -35,7 +35,7 @@ -- | 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] -> [LedgerTransaction] +entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Transaction] entriesFromTimeLogEntries _ [] = [] entriesFromTimeLogEntries now [i] | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o] @@ -59,21 +59,21 @@ -- | 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 -> LedgerTransaction +entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction entryFromTimeLogInOut i o | otime >= itime = t | otherwise = - error $ "clock-out time less than clock-in time in:\n" ++ showLedgerTransaction t + error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t where - t = LedgerTransaction { - ltdate = idate, - lteffectivedate = Nothing, - ltstatus = True, - ltcode = "", - ltdescription = showtime itod ++ "-" ++ showtime otod, - ltcomment = "", - ltpostings = ps, - ltpreceding_comment_lines="" + t = Transaction { + tdate = idate, + teffectivedate = Nothing, + tstatus = True, + tcode = "", + tdescription = showtime itod ++ "-" ++ showtime otod, + tcomment = "", + tpostings = ps, + tpreceding_comment_lines="" } showtime = take 5 . show acctname = tlcomment i @@ -84,6 +84,7 @@ idate = localDay itime hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] - ps = [Posting False acctname amount "" RegularPosting + ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, + pcomment="",ptype=RegularPosting,ptransaction=Just t} --,Posting "assets:time" (-amount) "" RegularPosting ] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -1,50 +1,142 @@ {-| -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. +A 'Transaction' represents a single balanced entry in the ledger file. It +normally contains two or more balanced 'Posting's. -} module Ledger.Transaction where -import Ledger.Dates import Ledger.Utils import Ledger.Types -import Ledger.LedgerTransaction (showAccountName) +import Ledger.Dates +import Ledger.Posting import Ledger.Amount -instance Show Transaction where show=showTransaction +instance Show Transaction where show = showTransactionUnelided +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)) + +nulltransaction :: Transaction +nulltransaction = Transaction { + tdate=nulldate, + teffectivedate=Nothing, + tstatus=False, + tcode="", + tdescription="", + tcomment="", + tpostings=[], + tpreceding_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 +@ +-} showTransaction :: Transaction -> String -showTransaction (Transaction _ stat d desc a amt ttype) = - s ++ unwords [showDate d,desc,a',show amt,show ttype] - where s = if stat then " *" else "" - a' = showAccountName Nothing ttype a +showTransaction = showTransaction' True False --- | 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. -flattenLedgerTransaction :: (LedgerTransaction, Int) -> [Transaction] -flattenLedgerTransaction (LedgerTransaction d _ s _ desc _ ps _, n) = - [Transaction n s d desc (paccount p) (pamount p) (ptype p) | p <- ps] +showTransactionUnelided :: Transaction -> String +showTransactionUnelided = showTransaction' False False -accountNamesFromTransactions :: [Transaction] -> [AccountName] -accountNamesFromTransactions = nub . map taccount +showTransactionForPrint :: Bool -> Transaction -> String +showTransactionForPrint effective = showTransaction' False effective -sumTransactions :: [Transaction] -> MixedAmount -sumTransactions = sum . map tamount +showTransaction' :: Bool -> Bool -> Transaction -> String +showTransaction' elide effective t = + unlines $ [description] ++ showpostings (tpostings t) ++ [""] + where + description = concat [date, status, code, desc, comment] + date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t + | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) + status = if tstatus t then " *" else "" + code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" + desc = ' ' : tdescription t + comment = if null com then "" else " ; " ++ com where com = tcomment t + showdate = printf "%-10s" . showDate + showedate = printf "=%s" . showdate + showpostings ps + | elide && length ps > 1 && isTransactionBalanced 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 ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) + w = maximum $ map (length . paccount) ps + showamount = printf "%12s" . showMixedAmount + showcomment s = if null s then "" else " ; "++s + showstatus p = if pstatus p then "* " else "" -nulltxn :: Transaction -nulltxn = Transaction 0 False (parsedate "1900/1/1") "" "" nullmixedamt RegularPosting +-- | Show an account name, clipped to the given width if any, and +-- appropriately bracketed/parenthesised for the given posting type. +showAccountName :: Maybe Int -> PostingType -> AccountName -> String +showAccountName w = fmt + where + fmt RegularPosting = take w' + fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse + fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse + w' = fromMaybe 999999 w + parenthesise s = "("++s++")" + bracket s = "["++s++"]" --- | 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 Bool +isTransactionBalanced (Transaction {tpostings=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. +balanceTransaction :: Transaction -> Either String Transaction +balanceTransaction t@Transaction{tpostings=ps} + | length missingamounts' > 1 = Left $ printerr "could not balance this transaction, too many missing amounts" + | not $ isTransactionBalanced t' = Left $ printerr nonzerobalanceerror + | otherwise = Right t' + where + (withamounts, missingamounts) = partition hasAmount $ filter isReal ps + (_, missingamounts') = partition hasAmount ps + t' = t{tpostings=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 (showTransactionUnelided t) + +nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero" + +-- | Convert the primary date to either the actual or effective date. +ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction +ledgerTransactionWithDate ActualDate t = t +ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} + + +-- | Ensure a transaction's postings refer back to it. +txnTieKnot :: Transaction -> Transaction +txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} + +-- | Set a posting's parent transaction. +settxn :: Transaction -> Posting -> Posting +settxn t p = p{ptransaction=Just t} diff --git a/Ledger/Types.hs b/Ledger/Types.hs --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -1,26 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} {-| -Most data types are defined here to avoid import cycles. See the -corresponding modules for each type's documentation. +Most data types are defined here to avoid import cycles. +Here is an overview of the hledger data model: -A note about entry\/transaction\/posting terminology: +> Ledger -- hledger's ledger is a journal file plus cached/derived data +> Journal -- a representation of the journal file, containing.. +> [Transaction] -- ..journal transactions, which have date, status, code, description and.. +> [Posting] -- ..two or more account postings (account name and amount) +> Tree AccountName -- all account names as a tree +> Map AccountName Account -- a map from account name to account info (postings and balances) - - ledger 2 had Entrys containing Transactions. - - - hledger 0.4 had Entrys containing RawTransactions, plus Transactions - which were a RawTransaction with its parent Entry's info added. - The latter are what we most work with when reporting and are - ubiquitous in the code and docs. - - - ledger 3 has Transactions containing Postings. - +For more detailed documentation on each type, see the corresponding modules. - - hledger 0.5 has LedgerTransactions containing Postings, plus - Transactions as before (a Posting plus it's parent's info). The - \"transaction\" term is pretty ingrained in the code, docs and with - users, so we've kept it. +Terminology has been in flux: + - ledger 2 had entries containing transactions. + + - hledger 0.4 had Entrys containing RawTransactions, which were flattened to Transactions. + + - ledger 3 has transactions containing postings. + + - hledger 0.5 had LedgerTransactions containing Postings, which were flattened to Transactions. + + - hledger 0.8 has Transactions containing Postings, and no flattened type. + -} module Ledger.Types @@ -33,7 +37,7 @@ type SmartDate = (String,String,String) -data WhichDate = ActualDate | EffectiveDate +data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) @@ -69,9 +73,22 @@ paccount :: AccountName, pamount :: MixedAmount, pcomment :: String, - ptype :: PostingType + ptype :: PostingType, + ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). + -- Tying this knot gets tedious, Maybe makes it easier/optional. } deriving (Eq) +data Transaction = Transaction { + tdate :: Day, + teffectivedate :: Maybe Day, + tstatus :: Bool, -- XXX tcleared ? + tcode :: String, + tdescription :: String, + tcomment :: String, + tpostings :: [Posting], + tpreceding_comment_lines :: String + } deriving (Eq) + data ModifierTransaction = ModifierTransaction { mtvalueexpr :: String, mtpostings :: [Posting] @@ -82,17 +99,6 @@ ptpostings :: [Posting] } deriving (Eq) -data LedgerTransaction = LedgerTransaction { - ltdate :: Day, - lteffectivedate :: Maybe Day, - ltstatus :: Bool, - ltcode :: String, - ltdescription :: String, - ltcomment :: String, - ltpostings :: [Posting], - ltpreceding_comment_lines :: String - } deriving (Eq) - data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) data TimeLogEntry = TimeLogEntry { @@ -107,48 +113,41 @@ hamount :: MixedAmount } deriving (Eq) -- & Show (in Amount.hs) -data RawLedger = RawLedger { - modifier_txns :: [ModifierTransaction], - periodic_txns :: [PeriodicTransaction], - ledger_txns :: [LedgerTransaction], +data Journal = Journal { + jmodifiertxns :: [ModifierTransaction], + jperiodictxns :: [PeriodicTransaction], + jtxns :: [Transaction], open_timelog_entries :: [TimeLogEntry], historical_prices :: [HistoricalPrice], final_comment_lines :: String, filepath :: FilePath, - filereadtime :: ClockTime - } deriving (Eq) - --- | A generic, pure specification of how to filter raw ledger transactions. -data FilterSpec = FilterSpec { - datespan :: DateSpan -- ^ only include transactions in this date span - ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care - ,real :: Bool -- ^ only include if real\/don't care - ,costbasis :: Bool -- ^ convert all amounts to cost basis - ,acctpats :: [String] -- ^ only include if matching these account patterns - ,descpats :: [String] -- ^ only include if matching these description patterns - ,whichdate :: WhichDate -- ^ which dates to use (transaction or effective) - } - -data Transaction = Transaction { - tnum :: Int, - tstatus :: Bool, -- ^ posting status - tdate :: Day, -- ^ transaction date - tdescription :: String, -- ^ ledger transaction description - taccount :: AccountName, -- ^ posting account - tamount :: MixedAmount, -- ^ posting amount - ttype :: PostingType -- ^ posting type + filereadtime :: ClockTime, + jtext :: String } deriving (Eq) data Account = Account { aname :: AccountName, - atransactions :: [Transaction], -- ^ transactions in this account - abalance :: MixedAmount -- ^ sum of transactions in this account and subaccounts + apostings :: [Posting], -- ^ transactions in this account + abalance :: MixedAmount -- ^ sum of transactions in this account and subaccounts } data Ledger = Ledger { - rawledgertext :: String, - rawledger :: RawLedger, + journal :: Journal, accountnametree :: Tree AccountName, accountmap :: Map.Map AccountName Account } deriving Typeable + +-- | A generic, pure specification of how to filter transactions/postings. +-- This exists to keep app-specific options out of the hledger library. +data FilterSpec = FilterSpec { + datespan :: DateSpan -- ^ only include if in this date span + ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care + ,real :: Bool -- ^ only include if real\/don't care + ,empty :: Bool -- ^ include if empty (ie amount is zero) + ,costbasis :: Bool -- ^ convert all amounts to cost basis + ,acctpats :: [String] -- ^ only include if matching these account patterns + ,descpats :: [String] -- ^ only include if matching these description patterns + ,whichdate :: WhichDate -- ^ which dates to use (actual or effective) + ,depth :: Maybe Int + } deriving (Show) diff --git a/Options.hs b/Options.hs --- a/Options.hs +++ b/Options.hs @@ -16,6 +16,11 @@ progname = "hledger" timeprogname = "hours" +#ifdef CHART +chartoutput = "hledger.png" +chartitems = 10 +chartsize = "600x400" +#endif usagehdr = "Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++ @@ -39,6 +44,9 @@ #ifdef WEB " web - run a simple web-based UI\n" ++ #endif +#ifdef CHART + " chart - generate balances pie chart\n" ++ +#endif " test - run self-tests\n" ++ "\n" ++ "PATTERNS are regular expressions which filter by account name.\n" ++ @@ -56,6 +64,7 @@ options :: [OptDescr Opt] options = [ Option "f" ["file"] (ReqArg File "FILE") "use a different ledger/timelog file; - means stdin" + ,Option "" ["no-new-accounts"] (NoArg NoNewAccts) "don't allow to create new accounts" ,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" ++ @@ -81,11 +90,17 @@ ,Option "" ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build" ,Option "" ["debug"] (NoArg Debug) "show extra debug output; implies verbose" ,Option "" ["debug-no-ui"] (NoArg DebugNoUI) "run ui commands with no output" +#ifdef CHART + ,Option "o" ["output"] (ReqArg ChartOutput "FILE") ("chart: output filename (default: "++chartoutput++")") + ,Option "" ["items"] (ReqArg ChartItems "N") ("chart: number of accounts to show (default: "++show chartitems++")") + ,Option "" ["size"] (ReqArg ChartSize "WIDTHxHEIGHT") ("chart: image size (default: "++chartsize++")") +#endif ] -- | An option value from a command-line flag. data Opt = File {value::String} | + NoNewAccts | Begin {value::String} | End {value::String} | Period {value::String} | @@ -109,6 +124,11 @@ | BinaryFilename | Debug | DebugNoUI +#ifdef CHART + | ChartOutput {value::String} + | ChartItems {value::String} + | ChartSize {value::String} +#endif deriving (Show,Eq) -- these make me nervous @@ -186,15 +206,15 @@ intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- | Get the value of the (last) depth option, if any, otherwise a large number. -depthFromOpts :: [Opt] -> Int -depthFromOpts opts = fromMaybe 9999 $ listtomaybeint $ optValuesForConstructor Depth opts +depthFromOpts :: [Opt] -> Maybe Int +depthFromOpts opts = listtomaybeint $ optValuesForConstructor Depth opts where listtomaybeint [] = Nothing listtomaybeint vs = Just $ read $ last vs -- | Get the value of the (last) display option, if any. -displayFromOpts :: [Opt] -> Maybe String -displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts +displayExprFromOpts :: [Opt] -> Maybe String +displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts where listtomaybe [] = Nothing listtomaybe vs = Just $ last vs @@ -236,10 +256,17 @@ datespan=dateSpanFromOpts (localDay t) opts ,cleared=clearedValueFromOpts opts ,real=Real `elem` opts + ,empty=Empty `elem` opts ,costbasis=CostBasis `elem` opts ,acctpats=apats ,descpats=dpats ,whichdate = if Effective `elem` opts then EffectiveDate else ActualDate + ,depth = depthFromOpts opts } where (apats,dpats) = parsePatternArgs args + +-- currentLocalTimeFromOpts opts = listtomaybe $ optValuesForConstructor CurrentLocalTime opts +-- where +-- listtomaybe [] = Nothing +-- listtomaybe vs = Just $ last vs diff --git a/README b/README --- a/README +++ b/README @@ -16,16 +16,17 @@ Here is a **demo_** of the web interface. +Here are ready-to-run **binaries_** for mac, windows and gnu/linux. + Here is the **manual_**. For support and more technical info, see **`hledger for techies`_** or **`email me`_**. -Download and try **`hledger for mac`_**, **`hledger for windows`_**, or **hledger for linux (`32 bit intel`_, `64 bit intel`_)**. - .. (If you're reading this in plain text, see also README2, MANUAL etc., or http://hledger.org) .. _hledger for techies: README2.html .. _manual: MANUAL.html .. _demo: http://demo.hledger.org +.. _binaries: http://hledger.org/binaries/ .. _hledger for mac: http://hledger.org/binaries/hledger-0.6-mac-i386.gz .. _hledger for windows: http://hledger.org/binaries/hledger-0.6-win-i386.zip .. _32 bit intel: http://hledger.org/binaries/hledger-0.6.1+9-linux-i386.gz diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -85,8 +85,8 @@ tests = [ "account directive" ~: - let sameParse str1 str2 = do l1 <- rawLedgerFromString str1 - l2 <- rawLedgerFromString str2 + let sameParse str1 str2 = do l1 <- journalFromString str1 + l2 <- journalFromString str2 l1 `is` l2 in TestList [ @@ -155,7 +155,8 @@ ,"balance report tests" ~: let (opts,args) `gives` es = do l <- sampleledgerwithopts opts args - showBalanceReport opts args l `is` unlines es + t <- getCurrentLocalTime + showBalanceReport opts (optsToFilterSpec opts args t) l `is` unlines es in TestList [ @@ -275,30 +276,28 @@ ] ,"balance report with cost basis" ~: do - rl <- rawLedgerFromString $ unlines + j <- journalFromString $ unlines ["" ,"2008/1/1 test " ," a:b 10h @ $50" ," c:d " ,"" ] - let l = cacheLedger [] $ - filterRawLedger (DateSpan Nothing Nothing) [] Nothing False $ - canonicaliseAmounts True rl -- enable cost basis adjustment - showBalanceReport [] [] l `is` + let j' = canonicaliseAmounts True j -- enable cost basis adjustment + showBalanceReport [] nullfilterspec nullledger{journal=j'} `is` unlines [" $500 a:b" ," $-500 c:d" ] ,"balance report elides zero-balance root account(s)" ~: do - l <- ledgerFromStringWithOpts [] [] sampletime + l <- ledgerFromStringWithOpts [] (unlines ["2008/1/1 one" ," test:a 1" ," test:b" ]) - showBalanceReport [] [] l `is` + showBalanceReport [] nullfilterspec l `is` unlines [" 1 test:a" ," -1 test:b" @@ -306,36 +305,36 @@ ] - ,"balanceLedgerTransaction" ~: do + ,"balanceTransaction" ~: do assertBool "detect unbalanced entry, sign error" - (isLeft $ balanceLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" "" - [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, - Posting False "b" (Mixed [dollars 1]) "" RegularPosting + (isLeft $ balanceTransaction + (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" + [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing, + Posting False "b" (Mixed [dollars 1]) "" RegularPosting Nothing ] "")) assertBool "detect unbalanced entry, multiple missing amounts" - (isLeft $ balanceLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" "" - [Posting False "a" missingamt "" RegularPosting, - Posting False "b" missingamt "" RegularPosting + (isLeft $ balanceTransaction + (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" + [Posting False "a" missingamt "" RegularPosting Nothing, + Posting False "b" missingamt "" RegularPosting Nothing ] "")) - let e = balanceLedgerTransaction (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" "" - [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, - Posting False "b" missingamt "" RegularPosting + let e = balanceTransaction (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" + [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing, + Posting False "b" missingamt "" RegularPosting Nothing ] "") assertBool "one missing amount should be ok" (isRight e) assertEqual "balancing amount is added" (Mixed [dollars (-1)]) (case e of - Right e' -> (pamount $ last $ ltpostings e') + Right e' -> (pamount $ last $ tpostings e') Left _ -> error "should not happen") ,"cacheLedger" ~: - length (Map.keys $ accountmap $ cacheLedger [] rawledger7) `is` 15 + length (Map.keys $ accountmap $ cacheLedger journal7) `is` 15 ,"canonicaliseAmounts" ~: "use the greatest precision" ~: - rawLedgerPrecisions (canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2] + journalPrecisions (canonicaliseAmounts False $ journalWithAmounts ["1","2.00"]) `is` [2,2] ,"commodities" ~: commodities ledger7 `is` [Commodity {symbol="$", side=L, spaced=False, comma=False, precision=2}] @@ -365,7 +364,7 @@ clockin = TimeLogEntry In mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S" showtime = formatTime defaultTimeLocale "%H:%M" - assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es) + assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ entriesFromTimeLogEntries now es) assertEntriesGiveStrings "started yesterday, split session at midnight" [clockin (mktime yesterday "23:00:00") ""] @@ -404,51 +403,44 @@ "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") Nothing 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") Nothing 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") Nothing 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") Nothing False "" "a" "" - [Posting False "b" (Mixed [dollars 0]) "" RegularPosting - ] "")) - assertBool "virtual postings don't need to balance" - (isLedgerTransactionBalanced - (LedgerTransaction (parsedate "2009/01/01") Nothing 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") Nothing 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") Nothing 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 - ] "")) + ,"isTransactionBalanced" ~: do + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t) + ] "" + assertBool "detect balanced" (isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting (Just t) + ] "" + assertBool "detect unbalanced" (not $ isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ] "" + assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 0]) "" RegularPosting (Just t) + ] "" + assertBool "one zero posting is considered balanced for now" (isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t) + ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting (Just t) + ] "" + assertBool "virtual postings don't need to balance" (isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t) + ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t) + ] "" + assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced t) + let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" + [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t) + ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t) + ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t) + ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting (Just t) + ] "" + assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced t) ,"isSubAccountNameOf" ~: do "assets" `isSubAccountNameOf` "assets" `is` False @@ -457,14 +449,14 @@ "assets:bank" `isSubAccountNameOf` "my assets" `is` False ,"default year" ~: do - rl <- rawLedgerFromString defaultyear_ledger_str - ltdate (head $ ledger_txns rl) `is` fromGregorian 2009 1 1 + rl <- journalFromString defaultyear_ledger_str + tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1 return () ,"ledgerFile" ~: do assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx 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 + r <- journalFromString "" -- don't know how to get it from ledgerFile + assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r ,"ledgerHistoricalPrice" ~: parseWithCtx emptyCtx ledgerHistoricalPrice price1_str `parseis` price1 @@ -477,7 +469,7 @@ $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n" let t = parseWithCtx emptyCtx 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 + $ either (const False) ((== "a") . tdescription) t ,"ledgeraccountname" ~: do assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") @@ -489,8 +481,8 @@ parseWithCtx emptyCtx 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 + parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 + parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 ,"period expressions" ~: do let todaysdate = parsedate "2008/11/26" @@ -508,7 +500,8 @@ do let args = ["expenses"] l <- sampleledgerwithopts [] args - showLedgerTransactions [] args l `is` unlines + t <- getCurrentLocalTime + showTransactions (optsToFilterSpec [] args t) l `is` unlines ["2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" @@ -519,7 +512,8 @@ , "print report with depth arg" ~: do l <- sampleledger - showLedgerTransactions [Depth "2"] [] l `is` unlines + t <- getCurrentLocalTime + showTransactions (optsToFilterSpec [Depth "2"] [] t) l `is` unlines ["2008/01/01 income" ," income:salary $-1" ,"" @@ -553,7 +547,7 @@ "register report with no args" ~: do l <- sampleledger - showRegisterReport [] [] l `is` unlines + showRegisterReport [] (optsToFilterSpec [] [] t1) 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" @@ -567,10 +561,11 @@ ," assets:bank:checking $-1 0" ] - ,"register report with cleared arg" ~: + ,"register report with cleared option" ~: do - l <- ledgerFromStringWithOpts [Cleared] [] sampletime sample_ledger_str - showRegisterReport [Cleared] [] l `is` unlines + let opts = [Cleared] + l <- ledgerFromStringWithOpts opts sample_ledger_str + showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines ["2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" ," assets:cash $-2 0" @@ -578,10 +573,11 @@ ," assets:bank:checking $-1 0" ] - ,"register report with uncleared arg" ~: + ,"register report with uncleared option" ~: do - l <- ledgerFromStringWithOpts [UnCleared] [] sampletime sample_ledger_str - showRegisterReport [UnCleared] [] l `is` unlines + let opts = [UnCleared] + l <- ledgerFromStringWithOpts opts sample_ledger_str + showRegisterReport opts (optsToFilterSpec opts [] t1) 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" @@ -592,7 +588,7 @@ ,"register report sorts by date" ~: do - l <- ledgerFromStringWithOpts [] [] sampletime $ unlines + l <- ledgerFromStringWithOpts [] $ unlines ["2008/02/02 a" ," b 1" ," c" @@ -601,19 +597,19 @@ ," e 1" ," f" ] - registerdates (showRegisterReport [] [] l) `is` ["2008/01/01","2008/02/02"] + registerdates (showRegisterReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"] ,"register report with account pattern" ~: do l <- sampleledger - showRegisterReport [] ["cash"] l `is` unlines + showRegisterReport [] (optsToFilterSpec [] ["cash"] t1) l `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] ,"register report with account pattern, case insensitive" ~: do l <- sampleledger - showRegisterReport [] ["cAsH"] l `is` unlines + showRegisterReport [] (optsToFilterSpec [] ["cAsH"] t1) l `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] @@ -621,7 +617,8 @@ do l <- sampleledger let gives displayexpr = - (registerdates (showRegisterReport [Display displayexpr] [] l) `is`) + (registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is`) + where opts = [Display displayexpr] "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"] @@ -632,15 +629,17 @@ do l <- sampleledger let periodexpr `gives` dates = do - lopts <- sampleledgerwithopts [Period periodexpr] [] - registerdates (showRegisterReport [Period periodexpr] [] lopts) `is` dates + l' <- sampleledgerwithopts opts [] + registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l') `is` dates + where opts = [Period periodexpr] "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "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 + let opts = [Period "yearly"] + showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ," assets:cash $-2 $-1" ," expenses:food $1 0" @@ -649,15 +648,18 @@ ," income:salary $-1 $-1" ," liabilities:debts $1 0" ] - registerdates (showRegisterReport [Period "quarterly"] [] l) `is` ["2008/01/01","2008/04/01","2008/10/01"] - registerdates (showRegisterReport [Period "quarterly",Empty] [] l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] + let opts = [Period "quarterly"] + registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"] + let opts = [Period "quarterly",Empty] + registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] ] , "register report with depth arg" ~: do l <- sampleledger - showRegisterReport [Depth "2"] [] l `is` unlines + let opts = [Depth "2"] + showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines ["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" @@ -670,7 +672,7 @@ ,"show hours" ~: show (hours 1) ~?= "1.0h" - ,"showLedgerTransaction" ~: do + ,"showTransaction" ~: do assertEqual "show a balanced transaction, eliding last amount" (unlines ["2007/01/28 coopportunity" @@ -678,11 +680,11 @@ ," assets:checking" ,"" ]) - (showLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting - ] "")) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransaction t) assertEqual "show a balanced transaction, no eliding" (unlines ["2007/01/28 coopportunity" @@ -690,11 +692,11 @@ ," assets:checking $-47.18" ,"" ]) - (showLedgerTransactionUnelided - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting - ] "")) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransactionUnelided t) -- document some cases that arise in debug/testing: assertEqual "show an unbalanced transaction, should not elide" (unlines @@ -703,10 +705,10 @@ ," assets:checking $-47.19" ,"" ]) - (showLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting - ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing ] "")) assertEqual "show an unbalanced transaction with one posting, should not elide" (unlines @@ -714,9 +716,9 @@ ," expenses:food:groceries $47.18" ,"" ]) - (showLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing ] "")) assertEqual "show a transaction with one posting and a missing amount" (unlines @@ -724,22 +726,22 @@ ," expenses:food:groceries " ,"" ]) - (showLedgerTransaction - (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" missingamt "" RegularPosting + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing ] "")) ,"unicode in balance layout" ~: do - l <- ledgerFromStringWithOpts [] [] sampletime + l <- ledgerFromStringWithOpts [] "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" - showBalanceReport [] [] l `is` unlines + showBalanceReport [] (optsToFilterSpec [] [] t1) l `is` unlines [" -100 актив:наличные" ," 100 расходы:покупки"] ,"unicode in register layout" ~: do - l <- ledgerFromStringWithOpts [] [] sampletime + l <- ledgerFromStringWithOpts [] "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" - showRegisterReport [] [] l `is` unlines + showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines ["2009/01/01 медвежья шкура расходы:покупки 100 100" ," актив:наличные -100 0"] @@ -796,44 +798,44 @@ [mkdatespan "2008/01/01" "2008/01/01"] ,"subAccounts" ~: do - l <- sampleledger + l <- liftM cacheLedger' sampleledger let a = ledgerAccount l "assets" map aname (ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"] - ,"summariseTransactionsInDateSpan" ~: do - let gives (b,e,tnum,depth,showempty,ts) = - (summariseTransactionsInDateSpan (mkdatespan b e) tnum depth showempty ts `is`) - let ts = - [ - 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{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31"} - ] - ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` - [ - 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{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{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{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="",tamount=Mixed [dollars 15]} - ] + -- ,"summarisePostingsInDateSpan" ~: do + -- let gives (b,e,depth,showempty,ps) = + -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) + -- let ps = + -- [ + -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 2]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 8]} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` + -- [] + -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 10]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} + -- ] + -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]} + -- ] ,"postingamount" ~: do parseWithCtx emptyCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18] @@ -846,11 +848,12 @@ ------------------------------------------------------------------------------ -- test data -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 +date1 = parsedate "2008/11/26" +t1 = LocalTime date1 midday +sampleledger = ledgerFromStringWithOpts [] sample_ledger_str +sampleledgerwithopts opts _ = ledgerFromStringWithOpts opts sample_ledger_str + sample_ledger_str = unlines ["; A sample ledger file." ,";" @@ -906,19 +909,19 @@ rawposting1_str = " expenses:food:dining $10.00\n" -rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting +rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing entry1_str = unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" - ," assets:checking" + ," assets:checking $-47.18" ,"" ] entry1 = - LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting, - Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting] "" + txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, + Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] "" entry2_str = unlines @@ -1060,173 +1063,186 @@ ,"" ] -rawledger7 = RawLedger +journal7 = Journal [] [] [ - LedgerTransaction { - ltdate=parsedate "2007/01/01", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="opening balance", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/01/01", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="opening balance", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="assets:cash", + paccount="assets:cash", pamount=(Mixed [dollars 4.82]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="equity:opening balances", + paccount="equity:opening balances", pamount=(Mixed [dollars (-4.82)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } , - LedgerTransaction { - ltdate=parsedate "2007/02/01", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="ayres suites", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/02/01", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="ayres suites", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="expenses:vacation", + paccount="expenses:vacation", pamount=(Mixed [dollars 179.92]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="assets:checking", + paccount="assets:checking", pamount=(Mixed [dollars (-179.92)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } , - LedgerTransaction { - ltdate=parsedate "2007/01/02", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="auto transfer to savings", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/01/02", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="auto transfer to savings", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="assets:saving", + paccount="assets:saving", pamount=(Mixed [dollars 200]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="assets:checking", + paccount="assets:checking", pamount=(Mixed [dollars (-200)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } , - LedgerTransaction { - ltdate=parsedate "2007/01/03", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="poquito mas", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/01/03", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="poquito mas", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="expenses:food:dining", + paccount="expenses:food:dining", pamount=(Mixed [dollars 4.82]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="assets:cash", + paccount="assets:cash", pamount=(Mixed [dollars (-4.82)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } , - LedgerTransaction { - ltdate=parsedate "2007/01/03", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="verizon", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/01/03", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="verizon", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="expenses:phone", + paccount="expenses:phone", pamount=(Mixed [dollars 95.11]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="assets:checking", + paccount="assets:checking", pamount=(Mixed [dollars (-95.11)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } , - LedgerTransaction { - ltdate=parsedate "2007/01/03", - lteffectivedate=Nothing, - ltstatus=False, - ltcode="*", - ltdescription="discover", - ltcomment="", - ltpostings=[ + txnTieKnot $ Transaction { + tdate=parsedate "2007/01/03", + teffectivedate=Nothing, + tstatus=False, + tcode="*", + tdescription="discover", + tcomment="", + tpostings=[ Posting { pstatus=False, - paccount="liabilities:credit cards:discover", + paccount="liabilities:credit cards:discover", pamount=(Mixed [dollars 80]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing }, Posting { pstatus=False, - paccount="assets:checking", + paccount="assets:checking", pamount=(Mixed [dollars (-80)]), pcomment="", - ptype=RegularPosting + ptype=RegularPosting, + ptransaction=Nothing } ], - ltpreceding_comment_lines="" + tpreceding_comment_lines="" } - ] + ] [] [] "" "" (TOD 0 0) + "" -ledger7 = cacheLedger [] rawledger7 +ledger7 = cacheLedger journal7 ledger8_str = unlines ["2008/1/1 test " @@ -1248,16 +1264,17 @@ a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}] a3 = Mixed $ amounts a1 ++ amounts a2 -rawLedgerWithAmounts :: [String] -> RawLedger -rawLedgerWithAmounts as = - RawLedger - [] - [] - [nullledgertxn{ltdescription=a,ltpostings=[nullrawposting{pamount=parse a}]} | a <- as] +journalWithAmounts :: [String] -> Journal +journalWithAmounts as = + Journal [] [] + [t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}] + [] + [] "" "" (TOD 0 0) + "" where parse = fromparse . parseWithCtx emptyCtx postingamount . (" "++) diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -9,18 +9,20 @@ where import Control.Monad.Error import Ledger -import Options (Opt,ledgerFilePathFromOpts,optsToFilterSpec) +import Options (Opt(..),ledgerFilePathFromOpts) -- ,optsToFilterSpec) import System.Directory (doesFileExist) import System.IO (stderr) import System.IO.UTF8 (hPutStrLn) import System.Exit import System.Cmd (system) import System.Info (os) -import System.Time (getClockTime) +import System.Time (ClockTime,getClockTime) -- | 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. +-- Warning, this provides only an uncached Ledger (no accountnametree or +-- accountmap), so cmd must cacheLedger'/crunchJournal if needed. 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 @@ -30,30 +32,37 @@ 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 tc <- getClockTime - let go = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext . (\rl -> rl{filepath=f,filereadtime=tc}) - if creating then go rawLedgerEmpty else (runErrorT . parseLedgerFile t) f - >>= flip either go - (\e -> hPutStrLn stderr e >> exitWith (ExitFailure 1)) + txt <- if creating then return "" else strictReadFile f' + let runcmd = cmd opts args . mkLedger opts f tc txt + if creating + then runcmd nulljournal + else (runErrorT . parseLedgerFile t) f >>= either parseerror runcmd + where parseerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1) +mkLedger :: [Opt] -> FilePath -> ClockTime -> String -> Journal -> Ledger +mkLedger opts f tc txt j = nullledger{journal=j'} + where j' = (canonicaliseAmounts costbasis j){filepath=f,filereadtime=tc,jtext=txt} + costbasis=CostBasis `elem` opts + -- | 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 (filterAndCacheLedgerWithOpts opts args reftime s) $ rawLedgerFromString s +ledgerFromStringWithOpts :: [Opt] -> String -> IO Ledger +ledgerFromStringWithOpts opts s = do + tc <- getClockTime + j <- journalFromString s + return $ mkLedger opts "" tc s j --- | 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 - readLedgerWithFilterSpec (optsToFilterSpec opts args t) f +-- -- | Read a Ledger from the given file, or give an error. +-- readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger +-- readLedgerWithOpts opts args f = do +-- t <- getCurrentLocalTime +-- readLedger f --- | 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 = filterAndCacheLedger . optsToFilterSpec opts args +-- -- | Convert a Journal to a canonicalised, cached and filtered Ledger +-- -- based on the command-line options/arguments and a reference time. +-- filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> Journal -> Ledger +-- filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args -- | Attempt to open a web browser on the given url, all platforms. openBrowserOn :: String -> IO ExitCode diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -11,7 +11,7 @@ import Options (progname) -- version and PATCHLEVEL are set by the makefile -version = "0.7.0" +version = "0.8.0" #ifdef PATCHLEVEL patchlevel = "." ++ show PATCHLEVEL -- must be numeric ! @@ -66,5 +66,8 @@ #endif #ifdef WEB ,"web" +#endif +#ifdef CHART + ,"chart" #endif ] diff --git a/data/web/style.css b/data/web/style.css new file mode 100644 --- /dev/null +++ b/data/web/style.css @@ -0,0 +1,15 @@ +/* hledger web ui stylesheet */ + +body { font-family: "helvetica","arial", "sans serif"; margin:0; } +#navbar { background-color:#eeeeee; border-bottom:2px solid #dddddd; padding:4px 4px 6px 4px; } +#navlinks { display:inline; } +.navlink { font-weight:normal; } +#searchform { font-size:small; display:inline; margin-left:1em; } +#hledgerorglink { font-size:small; float:right; } +#helplink { font-size:small; margin-left:1em; } +#resetlink { font-size:small; } +#messages { color:red; background-color:#ffeeee; margin:0.5em;} +#content { padding:0 4px 0 4px; } +#addform { margin-left:1em; font-size:small; float:right;} +#addform table { background-color:#eeeeee; border:2px solid #dddddd; } +#addform #addbuttonrow td { text-align:left; } diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -1,6 +1,6 @@ name: hledger -- Version is set by the makefile -version: 0.7.0 +version: 0.8 category: Finance synopsis: A command-line (or curses or web-based) double-entry accounting tool. description: @@ -22,7 +22,9 @@ tested-with: GHC==6.8, GHC==6.10 cabal-version: >= 1.2 build-type: Custom - +data-dir: data +data-files: + web/style.css extra-tmp-files: extra-source-files: README @@ -37,6 +39,10 @@ description: enable the web ui default: False +flag chart + description: enable the pie chart generation + default: False + library exposed-modules: Ledger @@ -46,13 +52,12 @@ Ledger.Commodity Ledger.Dates Ledger.IO - Ledger.LedgerTransaction - Ledger.RawLedger + Ledger.Transaction + Ledger.Journal Ledger.Ledger Ledger.Posting Ledger.Parse Ledger.TimeLog - Ledger.Transaction Ledger.Types Ledger.Utils Build-Depends: @@ -64,7 +69,7 @@ ,old-time ,parsec ,time - ,utf8-string >= 0.3 && < 0.4 + ,utf8-string >= 0.3 ,HUnit executable hledger @@ -85,16 +90,16 @@ Ledger.Commodity Ledger.Dates Ledger.IO - Ledger.LedgerTransaction + Ledger.Transaction Ledger.Ledger Ledger.Parse - Ledger.RawLedger + Ledger.Journal Ledger.Posting Ledger.TimeLog - Ledger.Transaction Ledger.Types Ledger.Utils Options + Paths_hledger Tests Utils Version @@ -114,7 +119,7 @@ ,split ,testpack ,time - ,utf8-string >= 0.3 && < 0.4 + ,utf8-string >= 0.3 ,HUnit ,safe >= 0.2 @@ -125,7 +130,7 @@ cpp-options: -DVTY other-modules:Commands.UI build-depends: - vty >= 4.0.0.1 && < 4.1 + vty >= 4.0.0.1 if flag(web) cpp-options: -DWEB @@ -133,19 +138,25 @@ build-depends: hsp ,hsx - ,xhtml >= 3000.2 && < 3000.3 + ,xhtml >= 3000.2 ,loli ,io-storage ,hack-contrib ,hack ,hack-handler-happstack - ,happstack >= 0.3 && < 0.4 - ,happstack-data >= 0.3 && < 0.4 - ,happstack-server >= 0.3 && < 0.4 - ,happstack-state >= 0.3 && < 0.4 - ,HTTP >= 4000.0 && < 4000.1 + ,happstack >= 0.3 + ,happstack-data >= 0.3 + ,happstack-server >= 0.3 + ,happstack-state >= 0.3 + ,HTTP >= 4000.0 ,applicative-extras + if flag(chart) + cpp-options: -DCHART + other-modules:Commands.Chart + build-depends: + Chart >= 0.11 + ,colour -- source-repository head -- type: darcs diff --git a/hledger.hs b/hledger.hs --- a/hledger.hs +++ b/hledger.hs @@ -68,5 +68,8 @@ #ifdef WEB | cmd `isPrefixOf` "web" = withLedgerDo opts args cmd web #endif +#ifdef CHART + | cmd `isPrefixOf` "chart" = withLedgerDo opts args cmd chart +#endif | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr usage