slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

big refactoring, do filtering afresh in each command

Browse Source 
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.
This commit is contained in:
Simon Michael 2009-12-21 05:23:07 +00:00
parent 7bd14a367a
commit a2b8faa4d6
17 changed files with 418 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Commands/Add.hs
View File

@ -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

22
Commands/Balance.hs
View File

@ -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

12
Commands/Histogram.hs
View File

@ -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)

19
Commands/Print.hs
View File

@ -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
showTransactions :: FilterSpec -> Ledger -> String
showTransactions filterspec l =
concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns
where
txns = sortBy (comparing tdate) $
jtxns $
filterJournalPostingsByDepth depth $
filterJournalPostingsByAccount apats $
journal l
depth = depthFromOpts opts
effective = Effective `elem` opts
(apats,_) = parsePatternArgs args
effective = EffectiveDate == whichdate filterspec
txns = jtxns $ filterJournalTransactions filterspec $ journal l

84
Commands/Register.hs
View File

@ -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

52
Commands/UI.hs
View File

@ -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

23
Commands/Web.hs
View File

@ -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 "/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)

4
Ledger/AccountName.hs
View File

@ -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

54
Ledger/IO.hs
View File

@ -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,13 +23,15 @@ ledgerdefaultfilename = ".ledger"
timelogdefaultfilename = ".timelog"
nullfilterspec = FilterSpec {
datespan=DateSpan Nothing Nothing
datespan=nulldatespan
,cleared=Nothing
,real=False
,empty=False
,costbasis=False
,acctpats=[]
,descpats=[]
,whichdate=ActualDate
,depth=Nothing
}
-- | Get the user's default ledger file path.
@ -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

173
Ledger/Journal.hs
View File

@ -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]

65
Ledger/Ledger.hs
View File

@ -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)
nullledger :: Ledger
nullledger = Ledger{
journaltext = "",
journal = nulljournal,
accountnametree = nullaccountnametree,
accountmap = fromList []
}
-- | 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)
cacheLedger :: Journal -> Ledger
cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap}
where (ant, amap) = crunchJournal j
-- | 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 (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
-- | 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]
filterPostings :: [String] -> [Posting] -> [Posting]
filterPostings apats = filter (matchpats apats . paccount)
type CachedLedger = Ledger
-- | List a ledger's account names.
ledgerAccountNames :: Ledger -> [AccountName]

7
Ledger/Posting.hs
View File

@ -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

5
Ledger/Transaction.hs
View File

@ -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}

9
Ledger/Types.hs
View File

@ -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)

15
Options.hs
View File

@ -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

92
Tests.hs
View File

@ -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 "

47
Utils.hs
View File

@ -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