From a2b8faa4d67421b62d07a7b1d921d9cdebe4f0c0 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 21 Dec 2009 05:23:07 +0000 Subject: [PATCH] big refactoring, do filtering afresh in each command We now do data filtering/massage as late as possible, not just once at startup. This should work better for multiple commands, as with web or ui. The basic benchmark seems at least as good as before thanks to laziness. --- Commands/Add.hs | 5 +- Commands/Balance.hs | 22 ++++-- Commands/Histogram.hs | 12 +-- Commands/Print.hs | 21 +++-- Commands/Register.hs | 84 ++++++++++---------- Commands/UI.hs | 52 +++++++------ Commands/Web.hs | 25 +++--- Ledger/AccountName.hs | 4 + Ledger/IO.hs | 68 +++++++++-------- Ledger/Journal.hs | 173 ++++++++++++++++++++++++++++++++++-------- Ledger/Ledger.hs | 65 +++++----------- Ledger/Posting.hs | 7 ++ Ledger/Transaction.hs | 5 +- Ledger/Types.hs | 9 ++- Options.hs | 15 +++- Tests.hs | 92 ++++++++++++---------- Utils.hs | 47 +++++++----- 17 files changed, 418 insertions(+), 288 deletions(-) diff --git a/Commands/Add.hs b/Commands/Add.hs index 44997a2e5..1763be6ef 100644 --- a/Commands/Add.hs +++ b/Commands/Add.hs @@ -154,8 +154,9 @@ appendToLedgerFile l s = 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 diff --git a/Commands/Balance.hs b/Commands/Balance.hs index 27723fcc7..6a66fb439 100644 --- a/Commands/Balance.hs +++ b/Commands/Balance.hs @@ -102,6 +102,7 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName import Ledger.Posting +import Ledger.Journal import Ledger.Ledger import Options import System.IO.UTF8 @@ -109,23 +110,28 @@ import System.IO.UTF8 -- | 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@Ledger{journal=j} = acctsstr ++ totalstr where + l' = l{journal=j',accountnametree=ant,accountmap=amap} -- like cacheLedger + where (ant, amap) = crunchJournal j' + j' = filterJournalPostings filterspec{depth=Nothing} j 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,7 +153,7 @@ isInteresting opts l a | 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 diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs index bd451dab3..ae8d7ad27 100644 --- a/Commands/Histogram.hs +++ b/Commands/Histogram.hs @@ -17,10 +17,12 @@ barchar = '*' -- | Print a histogram of some statistic per reporting interval, such as -- 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) dayps +showHistogram :: [Opt] -> FilterSpec -> Ledger -> String +showHistogram opts filterspec l = concatMap (printDayWith countBar) dayps where i = intervalFromOpts opts interval | i == NoInterval = Daily @@ -35,10 +37,10 @@ showHistogram opts args l = concatMap (printDayWith countBar) dayps | Empty `elem` opts = id | otherwise = filter (not . isZeroMixedAmount . pamount) matchapats = matchpats apats . paccount - (apats,_) = parsePatternArgs args + 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) diff --git a/Commands/Print.hs b/Commands/Print.hs index 770f7d8d5..886873ae8 100644 --- a/Commands/Print.hs +++ b/Commands/Print.hs @@ -14,16 +14,13 @@ import System.IO.UTF8 -- | Print ledger transactions in standard format. print' :: [Opt] -> [String] -> Ledger -> IO () -print' opts args = putStr . showTransactions opts args +print' opts args l = do + t <- getCurrentLocalTime + putStr $ showTransactions (optsToFilterSpec opts args t) l -showTransactions :: [Opt] -> [String] -> Ledger -> String -showTransactions opts args l = concatMap (showTransactionForPrint effective) txns - where - txns = sortBy (comparing tdate) $ - jtxns $ - filterJournalPostingsByDepth depth $ - filterJournalPostingsByAccount apats $ - journal 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 index a548a176b..d6619e6fc 100644 --- a/Commands/Register.hs +++ b/Commands/Register.hs @@ -14,44 +14,33 @@ import System.IO.UTF8 -- | Print a register report. register :: [Opt] -> [String] -> Ledger -> IO () -register opts args = putStr . showRegisterReport opts args +register opts args l = do + t <- getCurrentLocalTime + putStr $ showRegisterReport opts (optsToFilterSpec opts args t) l -{- | -Generate the register report. Each ledger entry is displayed as two or -more lines like this: - -@ -date (10) description (20) account (22) amount (11) balance (12) -DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA - ... ... ... -@ --} -showRegisterReport :: [Opt] -> [String] -> Ledger -> String -showRegisterReport opts args l - | interval == NoInterval = showps displayedps nullposting startbal - | otherwise = showps summaryps nullposting 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 - interval = intervalFromOpts opts - ps = sortBy (comparing postingDate) $ filterempties $ filterPostings apats $ filterdepth $ ledgerPostings l - filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth) - | otherwise = id - filterempties - | Empty `elem` opts = id - | otherwise = filter (not . isZeroMixedAmount . pamount) - (precedingps, ps') = break (matchdisplayopt dopt) ps - (displayedps, _) = span (matchdisplayopt dopt) ps' startbal = sumPostings precedingps - (apats,_) = parsePatternArgs args - matchdisplayopt Nothing _ = True - matchdisplayopt (Just e) p = (fromparse $ parsewith datedisplayexpr e) p - dopt = displayFromOpts opts - empty = Empty `elem` opts - depth = depthFromOpts opts + (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 (ledgerDateSpan l) + interval = intervalFromOpts opts + empty = Empty `elem` opts + depth = depthFromOpts opts + dispexpr = displayExprFromOpts opts + displayExprMatches p = case dispexpr of + Nothing -> True + Just e -> (fromparse $ parsewith datedisplayexpr e) p -- | Given a date span (representing a reporting interval) and a list of -- postings within it: aggregate the postings so there is only one per @@ -66,7 +55,7 @@ showRegisterReport opts args l -- -- The showempty flag forces the display of a zero-posting span -- and also zero-posting accounts within the span. -summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] +summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting] summarisePostingsInDateSpan (DateSpan b e) depth showempty ps | null ps && showempty = [p] | null ps = [] @@ -82,29 +71,34 @@ summarisePostingsInDateSpan (DateSpan b e) depth showempty ps anames = sort $ nub $ map paccount ps -- aggregate balances by account, like cacheLedger, then do depth-clipping (_,_,exclbalof,inclbalof) = groupPostings ps - clippedanames = clipAccountNames depth anames - isclipped a = accountNameLevel a >= depth + 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) 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 postings one per line, along with transaction info for the first --- posting of each transaction, and a running balance. -showps :: [Posting] -> Posting -> MixedAmount -> String -showps [] _ _ = "" -showps (p:ps) pprev bal = this ++ showps ps p 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 = showp isfirst p bal' + this = showposting isfirst p bal' isfirst = ptransaction p /= ptransaction pprev bal' = bal + pamount p -- | Show one posting and running balance, with or without transaction info. -showp :: Bool -> Posting -> MixedAmount -> String -showp withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n" +showposting :: Bool -> Posting -> MixedAmount -> String +showposting withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n" where ledger3ishlayout = False datedescwidth = if ledger3ishlayout then 34 else 32 diff --git a/Commands/UI.hs b/Commands/UI.hs index c766b548e..008139e26 100644 --- a/Commands/UI.hs +++ b/Commands/UI.hs @@ -52,7 +52,8 @@ ui opts args l = do 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 :: AppState -> IO () 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,30 +210,30 @@ screen :: AppState -> Screen screen a = scr where (Loc scr _ _) = loc a -- | Enter a new screen, saving the old ui location on the stack. -enter :: Screen -> AppState -> AppState -enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a -enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a -enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +enter :: 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 $ showTransactions 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 -> scrollToTransaction e $ enter PrintScreen a + BalanceScreen -> enter t RegisterScreen a{aargs=[currentAccountName a]} + RegisterScreen -> scrollToTransaction e $ enter t PrintScreen a PrintScreen -> a where e = currentTransaction a @@ -278,7 +280,7 @@ currentTransaction a@AppState{aledger=l,abuf=buf} = ptransaction p where p = safehead nullposting $ filter ismatch $ ledgerPostings l ismatch p = postingDate p == parsedate (take 10 datedesc) - && take 70 (showp False p nullmixedamt) == (datedesc ++ acctamt) + && 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 diff --git a/Commands/Web.hs b/Commands/Web.hs index c76ff1344..b35c5b7c3 100644 --- a/Commands/Web.hs +++ b/Commands/Web.hs @@ -47,7 +47,8 @@ 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 @@ -92,7 +93,7 @@ ledgerFileReadTime l = filereadtime $ journal l reload :: Ledger -> IO Ledger reload l = do - l' <- readLedgerWithOpts [] [] (filepath $ journal l) + l' <- readLedger (filepath $ journal l) putValue "hledger" "ledger" l' return l' @@ -115,6 +116,7 @@ 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 @@ -130,14 +132,14 @@ server opts args l = 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 "/transactions" $ ledgerpage [] l'' (showTransactions opts' args') + 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) @@ -284,7 +286,8 @@ handleAddform :: Ledger -> AppUnit 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 Transaction validate env today = @@ -337,10 +340,10 @@ handleAddform l = do False -> Failure errs True -> Success t' - handle :: Failing Transaction -> AppUnit - handle (Failure errs) = hsp errs addform - handle (Success t) = do + 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 [] []) + ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti)) where msg = printf "Added transaction:\n%s" (show t) diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs index 0d36436e5..9e91d122a 100644 --- a/Ledger/AccountName.hs +++ b/Ledger/AccountName.hs @@ -73,6 +73,8 @@ accountNameTreeFrom1 accts = 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 @@ elideAccountName width s = | 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/IO.hs b/Ledger/IO.hs index 33c559ee6..d3167c416 100644 --- a/Ledger/IO.hs +++ b/Ledger/IO.hs @@ -5,11 +5,11 @@ Utilities for doing I/O with ledger files. module Ledger.IO where import Control.Monad.Error -import Ledger.Ledger (cacheLedger) +import Ledger.Ledger (cacheLedger', nullledger) import Ledger.Parse (parseLedger) -import Ledger.Journal (canonicaliseAmounts,filterJournal,journalSelectingDate) -import Ledger.Types (FilterSpec(..),WhichDate(..),DateSpan(..),Journal(..),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 @@ -23,14 +23,16 @@ ledgerdefaultfilename = ".ledger" 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,16 +60,20 @@ myTimelog = myTimelogPath >>= readLedger -- | 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 <- journalFromString s - return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t} + s <- readFile f + j <- journalFromString s + return $ cacheLedger' $ nullledger{journaltext=s,journal=j{filepath=f,filereadtime=t}} + +-- -- | 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. @@ -76,18 +82,16 @@ journalFromString s = do t <- getCurrentLocalTime liftM (either error id) $ runErrorT $ parseLedger t "(string)" s --- | Convert a Journal to a canonicalised, cached and filtered Ledger. -filterAndCacheLedger :: FilterSpec -> String -> Journal -> Ledger -filterAndCacheLedger (FilterSpec{datespan=datespan,cleared=cleared,real=real, - costbasis=costbasis,acctpats=acctpats, - descpats=descpats,whichdate=whichdate}) - rawtext - rl = - (cacheLedger acctpats - $ filterJournal datespan descpats cleared real - $ journalSelectingDate whichdate - $ canonicaliseAmounts costbasis rl - ){journaltext=rawtext} +-- -- | Convert a Journal to a canonicalised, cached and filtered Ledger. +-- filterAndCacheLedger :: FilterSpec -> String -> Journal -> Ledger +-- filterAndCacheLedger _ -- filterspec +-- rawtext +-- j = +-- (cacheLedger $ +-- -- journalSelectingDate whichdate $ +-- j +-- -- filterJournalPostings filterspec $ filterJournalTransactions filterspec j +-- ){journaltext=rawtext} -- -- | Expand ~ in a file path (does not handle ~name). -- tildeExpand :: FilePath -> IO FilePath diff --git a/Ledger/Journal.hs b/Ledger/Journal.hs index 967c01388..81f64bf9a 100644 --- a/Ledger/Journal.hs +++ b/Ledger/Journal.hs @@ -1,6 +1,8 @@ {-| -A 'Journal' is a parsed ledger file. +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'. -} @@ -19,14 +21,14 @@ import Ledger.TimeLog instance Show Journal where - show l = printf "Journal with %d transactions, %d accounts: %s" - (length (jtxns l) + - length (jmodifiertxns l) + - length (jperiodictxns l)) + 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 l + where accounts = flatten $ journalAccountNameTree j nulljournal :: Journal nulljournal = Journal { jmodifiertxns = [] @@ -66,15 +68,51 @@ journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree = accountNameTreeFrom . journalAccountNames --- | 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. -filterJournal :: DateSpan -> [String] -> Maybe Bool -> Bool -> Journal -> Journal -filterJournal span pats clearedonly realonly = - filterJournalPostingsByRealness realonly . - filterJournalPostingsByClearedStatus clearedonly . - filterJournalTransactionsByDate span . - filterJournalTransactionsByDescription pats +-- 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 @@ -93,43 +131,69 @@ filterJournalTransactionsByDate (DateSpan begin end) (Journal ms ps ts tls hs f -- | 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) (Journal ms ps ts tls hs f fp ft) = + Journal ms ps (filter ((==val).tstatus) ts) tls hs f fp ft + +-- | 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 val) (Journal ms ps ts tls hs f fp ft) = - Journal ms ps (filter ((==val).tstatus) ts) tls hs f fp ft +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 (Journal mts pts ts tls hs f fp ft) = - Journal mts pts (map filtertxns ts) tls hs f fp ft - where filtertxns t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps} + Journal mts pts (map filterpostings ts) tls hs f fp ft + 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 (Journal mts pts ts tls hs f fp ft) = + Journal mts pts (map filterpostings ts) tls hs f fp ft + 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 :: Int -> Journal -> Journal -filterJournalPostingsByDepth depth (Journal mts pts ts tls hs f fp ft) = +filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal +filterJournalPostingsByDepth Nothing j = j +filterJournalPostingsByDepth (Just d) (Journal mts pts ts tls hs f fp ft) = Journal mts pts (filter (not . null . tpostings) $ map filtertxns ts) tls hs f fp ft where filtertxns t@Transaction{tpostings=ps} = - t{tpostings=filter ((<= depth) . accountNameLevel . paccount) ps} + t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} --- | Keep only ledger transactions which affect accounts matched by the account patterns. -filterJournalPostingsByAccount :: [String] -> Journal -> Journal -filterJournalPostingsByAccount apats (Journal ms ps ts tls hs f fp ft) = +-- | Keep only transactions which affect accounts matched by the account patterns. +filterJournalTransactionsByAccount :: [String] -> Journal -> Journal +filterJournalTransactionsByAccount apats (Journal ms ps ts tls hs f fp ft) = Journal ms ps (filter (any (matchpats apats . paccount) . tpostings) ts) tls hs f fp ft --- | Convert this ledger's transactions' primary date to either their +-- | 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} --- | 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. +-- | 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 @@ -210,3 +274,52 @@ matchpats pats 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 index f0bec5a59..a7a495ed7 100644 --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -54,7 +54,7 @@ aliases for easier interaction. Here's an example: module Ledger.Ledger where import qualified Data.Map as Map -import Data.Map ((!)) +import Data.Map ((!), fromList) import Ledger.Utils import Ledger.Types import Ledger.Account () @@ -71,56 +71,25 @@ instance Show Ledger where (length $ accountnames l) (showtree $ accountnametree l) --- | Convert a journal to a more efficient cached ledger, described above. -cacheLedger :: [String] -> Journal -> Ledger -cacheLedger apats j = Ledger{journaltext="",journal=j,accountnametree=ant,accountmap=acctmap} - where - (ant,psof,_,inclbalof) = groupPostings $ filterPostings apats $ journalPostings j - acctmap = Map.fromList [(a, mkacct a) | a <- flatten ant] - where mkacct a = Account a (psof a) (inclbalof a) +nullledger :: Ledger +nullledger = Ledger{ + journaltext = "", + journal = nulljournal, + accountnametree = nullaccountnametree, + accountmap = fromList [] + } --- | 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 !) +-- | 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 -> [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 +-- | 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 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] - -filterPostings :: [String] -> [Posting] -> [Posting] -filterPostings apats = filter (matchpats apats . paccount) +type CachedLedger = Ledger -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs index 861df23d3..d59d17499 100644 --- a/Ledger/Posting.hs +++ b/Ledger/Posting.hs @@ -73,9 +73,16 @@ 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 + diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs index 51a313e2f..dc5d67eae 100644 --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -129,13 +129,14 @@ nonzerobalanceerror = "could not balance this transaction, amounts do not add up -- | Convert the primary date to either the actual or effective date. ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction ledgerTransactionWithDate ActualDate t = t -ledgerTransactionWithDate EffectiveDate t = t{tdate=fromMaybe (tdate t) (teffectivedate t)} +ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} --- | Ensure a transaction's postings refer to it as their transaction. +-- | 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 index c6dc84558..7633f379a 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -37,7 +37,7 @@ import Data.Typeable (Typeable) 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) @@ -81,7 +81,7 @@ data Posting = Posting { data Transaction = Transaction { tdate :: Day, teffectivedate :: Maybe Day, - tstatus :: Bool, + tstatus :: Bool, -- XXX tcleared ? tcode :: String, tdescription :: String, tcomment :: String, @@ -138,13 +138,16 @@ data Ledger = Ledger { } 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 index d531dcf46..6df64d6b0 100644 --- a/Options.hs +++ b/Options.hs @@ -197,15 +197,15 @@ intervalFromOpts opts = intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- | Get the value of the (last) depth option, if any, otherwise a large number. -depthFromOpts :: [Opt] -> Int -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 @@ -247,10 +247,17 @@ optsToFilterSpec opts args t = FilterSpec { 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/Tests.hs b/Tests.hs index bc4972f86..2b9aa1440 100644 --- a/Tests.hs +++ b/Tests.hs @@ -155,7 +155,8 @@ tests = [ ,"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 @@ tests = [ ] ,"balance report with cost basis" ~: do - rl <- journalFromString $ unlines + j <- journalFromString $ unlines ["" ,"2008/1/1 test " ," a:b 10h @ $50" ," c:d " ,"" ] - let l = cacheLedger [] $ - filterJournal (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" @@ -331,7 +330,7 @@ tests = [ Left _ -> error "should not happen") ,"cacheLedger" ~: - length (Map.keys $ accountmap $ cacheLedger [] journal7) `is` 15 + length (Map.keys $ accountmap $ cacheLedger journal7) `is` 15 ,"canonicaliseAmounts" ~: "use the greatest precision" ~: @@ -482,8 +481,8 @@ tests = [ 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" @@ -501,7 +500,8 @@ tests = [ do let args = ["expenses"] l <- sampleledgerwithopts [] args - showTransactions [] args l `is` unlines + t <- getCurrentLocalTime + showTransactions (optsToFilterSpec [] args t) l `is` unlines ["2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" @@ -512,7 +512,8 @@ tests = [ , "print report with depth arg" ~: do l <- sampleledger - showTransactions [Depth "2"] [] l `is` unlines + t <- getCurrentLocalTime + showTransactions (optsToFilterSpec [Depth "2"] [] t) l `is` unlines ["2008/01/01 income" ," income:salary $-1" ,"" @@ -546,7 +547,7 @@ tests = [ "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" @@ -560,10 +561,11 @@ tests = [ ," 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" @@ -571,10 +573,11 @@ tests = [ ," 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" @@ -585,7 +588,7 @@ tests = [ ,"register report sorts by date" ~: do - l <- ledgerFromStringWithOpts [] [] sampletime $ unlines + l <- ledgerFromStringWithOpts [] $ unlines ["2008/02/02 a" ," b 1" ," c" @@ -594,19 +597,19 @@ tests = [ ," 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" ] @@ -614,7 +617,8 @@ tests = [ 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"] @@ -625,15 +629,17 @@ tests = [ 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" @@ -642,15 +648,18 @@ tests = [ ," 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" @@ -723,16 +732,16 @@ tests = [ ] "")) ,"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"] @@ -789,7 +798,7 @@ tests = [ [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"] @@ -839,10 +848,11 @@ tests = [ ------------------------------------------------------------------------------ -- 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." @@ -1231,7 +1241,7 @@ journal7 = Journal "" (TOD 0 0) -ledger7 = cacheLedger [] journal7 +ledger7 = cacheLedger journal7 ledger8_str = unlines ["2008/1/1 test " diff --git a/Utils.hs b/Utils.hs index 68250e35a..f0cc60626 100644 --- a/Utils.hs +++ b/Utils.hs @@ -9,14 +9,14 @@ module Utils 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 @@ -30,30 +30,37 @@ withLedgerDo opts args cmdname cmd = do 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 nulljournal 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{journaltext=txt,journal=j'} + where j' = (canonicaliseAmounts costbasis j){filepath=f,filereadtime=tc} + 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) $ journalFromString 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 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 +-- -- | 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