diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -28,6 +28,7 @@ getCurrentYear, nulldate, spanContainsDate, + parsedateM, parsedate, showDate, elapsedSeconds, diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -18,7 +18,6 @@ journalCanonicaliseAmounts, journalConvertAmountsToCost, journalFinalise, - journalSelectingDate, -- * Filtering filterJournalPostings, filterJournalTransactions, @@ -342,13 +341,6 @@ -} --- | 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 (journalTransactionWithDate EffectiveDate) $ jtxns j} - -- | Apply additional account aliases (eg from the command-line) to all postings in a journal. journalApplyAliases :: [(AccountName,AccountName)] -> Journal -> Journal journalApplyAliases aliases j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} @@ -372,7 +364,7 @@ -- depends on display precision. Reports only the first error encountered. journalBalanceTransactions :: Journal -> Either String Journal journalBalanceTransactions j@Journal{jtxns=ts, jcommoditystyles=ss} = - case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'} + case sequence $ map balance ts of Right ts' -> Right j{jtxns=map txnTieKnot ts'} Left e -> Left e where balance = balanceTransaction (Just ss) @@ -518,165 +510,75 @@ {jtxns = [ txnTieKnot $ Transaction { tdate=parsedate "2008/01/01", - teffectivedate=Nothing, + tdate2=Nothing, tstatus=False, tcode="", tdescription="income", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="income:salary", - pamount=(missingmixedamt), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings= + ["assets:bank:checking" `post` usd 1 + ,"income:salary" `post` missingamt + ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/01", - teffectivedate=Nothing, + tdate2=Nothing, tstatus=False, tcode="", tdescription="gift", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="income:gifts", - pamount=(missingmixedamt), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings= + ["assets:bank:checking" `post` usd 1 + ,"income:gifts" `post` missingamt + ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/02", - teffectivedate=Nothing, + tdate2=Nothing, tstatus=False, tcode="", tdescription="save", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="assets:bank:saving", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [usd (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings= + ["assets:bank:saving" `post` usd 1 + ,"assets:bank:checking" `post` usd (-1) + ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/03", - teffectivedate=Nothing, + tdate2=Nothing, tstatus=True, tcode="", tdescription="eat & shop", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="expenses:food", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="expenses:supplies", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:cash", - pamount=(missingmixedamt), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings=["expenses:food" `post` usd 1 + ,"expenses:supplies" `post` usd 1 + ,"assets:cash" `post` missingamt + ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/12/31", - teffectivedate=Nothing, + tdate2=Nothing, tstatus=False, tcode="", tdescription="pay off", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="liabilities:debts", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [usd (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings=["liabilities:debts" `post` usd 1 + ,"assets:bank:checking" `post` usd (-1) + ], tpreceding_comment_lines="" } ] diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -10,6 +10,8 @@ module Hledger.Data.Posting ( -- * Posting nullposting, + posting, + post, -- * operations postingCleared, isReal, @@ -19,8 +21,10 @@ hasAmount, postingAllTags, transactionAllTags, + relatedPostings, -- * date operations postingDate, + postingDate2, isPostingInDateSpan, postingsDateSpan, -- * account name operations @@ -35,15 +39,13 @@ sumPostings, -- * rendering showPosting, - showPostingForRegister, -- * misc. - postingTagsAsLines, - tagsAsLines, showComment, tests_Hledger_Data_Posting ) where import Data.List +import Data.Maybe import Data.Ord import Data.Time.Calendar import Safe @@ -59,12 +61,26 @@ instance Show Posting where show = showPosting -nullposting :: Posting -nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing +nullposting, posting :: Posting +nullposting = Posting + {pdate=Nothing + ,pdate2=Nothing + ,pstatus=False + ,paccount="" + ,pamount=nullmixedamt + ,pcomment="" + ,ptype=RegularPosting + ,ptags=[] + ,ptransaction=Nothing + } +posting = nullposting +post :: AccountName -> Amount -> Posting +post acct amt = posting {paccount=acct, pamount=mixed amt} + showPosting :: Posting -> String showPosting p@Posting{paccount=a,pamount=amt,ptype=t} = - unlines $ [concatTopPadded [showaccountname a ++ " ", showamount amt, showComment (pcomment p)]] ++ postingTagsAsLines p + unlines $ [concatTopPadded [showaccountname a ++ " ", showamount amt, showComment (pcomment p)]] where ledger3ishlayout = False acctnamewidth = if ledger3ishlayout then 25 else 22 @@ -76,28 +92,8 @@ showamount = padleft 12 . showMixedAmount -postingTagsAsLines :: Posting -> [String] -postingTagsAsLines = tagsAsLines . ptags - -tagsAsLines :: [(String, String)] -> [String] -tagsAsLines mds = map (\(k,v) -> " ; " ++ k++": "++v) mds - showComment :: String -> String -showComment s = if null s then "" else " ; " ++ s - --- XXX refactor -showPostingForRegister :: Posting -> String -showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) = - concatTopPadded [showaccountname a ++ " ", showamount amt] - where - ledger3ishlayout = False - acctnamewidth = if ledger3ishlayout then 25 else 22 - showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width - (bracket,width) = case t of - BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) - VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) - _ -> (id,acctnamewidth) - showamount = padleft 12 . showMixedAmountWithoutPrice +showComment s = if null s then "" else " ;" ++ s isReal :: Posting -> Bool isReal p = ptype p == RegularPosting @@ -117,9 +113,26 @@ sumPostings :: [Posting] -> MixedAmount sumPostings = sum . map pamount +-- | Get a posting's (primary) date - it's own primary date if specified, +-- otherwise the parent transaction's primary date, or the null date if +-- there is no parent transaction. postingDate :: Posting -> Day -postingDate p = maybe nulldate tdate $ ptransaction p +postingDate p = fromMaybe txndate $ pdate p + where + txndate = maybe nulldate tdate $ ptransaction p +-- | Get a posting's secondary (secondary) date, which is the first of: +-- posting's secondary date, transaction's secondary date, posting's +-- primary date, transaction's primary date, or the null date if there is +-- no parent transaction. +postingDate2 :: Posting -> Day +postingDate2 p = headDef nulldate $ catMaybes dates + where dates = [pdate2 p + ,maybe Nothing tdate2 $ ptransaction p + ,pdate p + ,maybe Nothing (Just . tdate) $ ptransaction p + ] + -- |Is this posting cleared? If this posting was individually marked -- as cleared, returns True. Otherwise, return the parent -- transaction's cleared status or, if there is no parent @@ -137,6 +150,11 @@ transactionAllTags :: Transaction -> [Tag] transactionAllTags t = ttags t +-- Get the other postings from this posting's transaction. +relatedPostings :: Posting -> [Posting] +relatedPostings p@Posting{ptransaction=Just t} = filter (/= p) $ tpostings t +relatedPostings _ = [] + -- | Does this posting fall within the given date span ? isPostingInDateSpan :: DateSpan -> Posting -> Bool isPostingInDateSpan s = spanContainsDate s . postingDate @@ -216,4 +234,4 @@ concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)" ] - + diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -21,6 +21,7 @@ import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Amount +import Hledger.Data.Posting import Hledger.Data.Transaction instance Show TimeLogEntry where @@ -76,7 +77,7 @@ where t = Transaction { tdate = idate, - teffectivedate = Nothing, + tdate2 = Nothing, tstatus = True, tcode = "", tdescription = showtime itod ++ "-" ++ showtime otod, @@ -94,8 +95,8 @@ idate = localDay itime hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hrs hours] - ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, - pcomment="",ptype=VirtualPosting,ptags=[],ptransaction=Just t}] + ps = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}] + tests_Hledger_Data_TimeLog = TestList [ diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -22,9 +22,7 @@ isTransactionBalanced, -- nonzerobalanceerror, -- * date operations - transactionActualDate, - transactionEffectiveDate, - journalTransactionWithDate, + transactionDate2, -- * arithmetic transactionPostingBalances, balanceTransaction, @@ -59,7 +57,7 @@ nulltransaction :: Transaction nulltransaction = Transaction { tdate=nulldate, - teffectivedate=Nothing, + tdate2=Nothing, tstatus=False, tcode="", tdescription="", @@ -97,7 +95,7 @@ nulltransaction `gives` "0000/01/01\n\n" nulltransaction{ tdate=parsedate "2012/05/14", - teffectivedate=Just $ parsedate "2012/05/15", + tdate2=Just $ parsedate "2012/05/15", tstatus=False, tcode="code", tdescription="desc", @@ -115,14 +113,13 @@ ] } `gives` unlines [ - "2012/05/14=2012/05/15 (code) desc ; tcomment1", - " ; tcomment2", - " ; ttag1: val1", + "2012/05/14=2012/05/15 (code) desc", + " ;tcomment1", + " ;tcomment2", " $1.00", - " * a 2.0h ; pcomment1", - " ; pcomment2", - " ; ptag1: val1", - " ; ptag2: val2", + " * a 2.0h", + " ;pcomment1", + " ;pcomment2", "" ] ] @@ -131,26 +128,29 @@ showTransaction' :: Bool -> Transaction -> String showTransaction' elide t = unlines $ [descriptionline] - ++ commentlines - ++ (tagsAsLines $ ttags t) + ++ multilinecomment ++ (postingsAsLines elide t (tpostings t)) ++ [""] where - descriptionline = rstrip $ concat [date, status, code, desc, firstcomment] - date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) + descriptionline = rstrip $ concat [date, status, code, desc, inlinecomment] + date = showdate (tdate t) ++ maybe "" showedate (tdate2 t) showdate = printf "%-10s" . showDate showedate = printf "=%s" . showdate status = if tstatus t then " *" else "" code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" desc = if null d then "" else " " ++ d where d = tdescription t - (firstcomment, commentlines) = commentLines $ tcomment t + (inlinecomment, multilinecomment) = commentLines $ tcomment t --- Render a transaction or posting's comment as indented & prefixed comment lines. +-- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines - +-- an inline comment (when it's a single line) or multiple lines. commentLines :: String -> (String, [String]) commentLines s | null s = ("", []) - | otherwise = (" ; " ++ first, map (indent . ("; "++)) rest) - where (first:rest) = lines s + | length ls == 1 = (prefix $ head ls, []) + | otherwise = ("", (prefix $ head ls):(map prefix $ tail ls)) + where + ls = lines s + prefix = indent . (";"++) postingsAsLines :: Bool -> Transaction -> [Posting] -> [String] postingsAsLines elide t ps @@ -161,12 +161,11 @@ postingAsLines :: Bool -> [Posting] -> Posting -> [String] postingAsLines elideamount ps p = postinglines - ++ commentlines - ++ tagsAsLines (ptags p) + ++ multilinecomment where - postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, firstcomment] + postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, inlinecomment] amount = if elideamount then "" else showamt (pamount p) - (firstcomment, commentlines) = commentLines $ pcomment p + (inlinecomment, multilinecomment) = commentLines $ pcomment p showacct p = indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) where @@ -178,22 +177,22 @@ tests_postingAsLines = [ "postingAsLines" ~: do let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p) - nullposting `gives` [" 0"] - nullposting{ + posting `gives` [" 0"] + posting{ pstatus=True, paccount="a", pamount=Mixed [usd 1, hrs 2], - pcomment="pcomment1\npcomment2\n", + pcomment="pcomment1\npcomment2\n tag3: val3 \n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")] } `gives` [ " $1.00", - " * a 2.0h ; pcomment1", - " ; pcomment2", - " ; ptag1: val1", - " ; ptag2: val2" - ] + " * a 2.0h", + " ;pcomment1", + " ;pcomment2", + " ; tag3: val3 " + ] ] indent :: String -> String @@ -265,7 +264,7 @@ | length rwithoutamounts > 1 || length bvwithoutamounts > 1 = Left $ printerr "could not balance this transaction (too many missing amounts)" | not $ isTransactionBalanced styles t''' = Left $ printerr $ nonzerobalanceerror t''' - | otherwise = Right t''' + | otherwise = Right t'''' where -- maybe infer missing amounts (rwithamounts, rwithoutamounts) = partition hasAmount $ realPostings t @@ -330,6 +329,9 @@ bvamountsinunpricedcommodity = filter ((==unpricedcommodity).acommodity) bvamountsinorder inferprice p = p + -- tie the knot so eg relatedPostings works right + t'''' = txnTieKnot t''' + printerr s = intercalate "\n" [s, showTransactionUnelided t] nonzerobalanceerror :: Transaction -> String @@ -342,18 +344,9 @@ | otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum) sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String -transactionActualDate :: Transaction -> Day -transactionActualDate = tdate - --- Get a transaction's effective date, defaulting to the actual date. -transactionEffectiveDate :: Transaction -> Day -transactionEffectiveDate t = fromMaybe (tdate t) $ teffectivedate t - --- | Once we no longer need both, set the main transaction date to either --- the actual or effective date. A bit hacky. -journalTransactionWithDate :: WhichDate -> Transaction -> Transaction -journalTransactionWithDate ActualDate t = t -journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=transactionEffectiveDate t} +-- Get a transaction's secondary date, defaulting to the primary date. +transactionDate2 :: Transaction -> Day +transactionDate2 t = fromMaybe (tdate t) $ tdate2 t -- | Ensure a transaction's postings refer back to it. txnTieKnot :: Transaction -> Transaction @@ -376,8 +369,8 @@ ,"" ]) (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] (Just t) - ,Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] (Just t) + [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t} + ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t} ] "" in showTransaction t) @@ -390,8 +383,8 @@ ,"" ]) (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] (Just t) - ,Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] (Just t) + [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t} + ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t} ] "" in showTransactionUnelided t) @@ -406,8 +399,8 @@ ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing - ,Posting False "assets:checking" (Mixed [usd (-47.19)]) "" RegularPosting [] Nothing + [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]} + ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.19)]} ] "")) ,"showTransaction" ~: do @@ -419,7 +412,7 @@ ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing + [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]} ] "")) ,"showTransaction" ~: do @@ -431,7 +424,7 @@ ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" missingmixedamt "" RegularPosting [] Nothing + [posting{paccount="expenses:food:groceries", pamount=missingmixedamt} ] "")) ,"showTransaction" ~: do @@ -444,28 +437,28 @@ ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" [] - [Posting False "a" (Mixed [num 1 `at` (usd 2 `withPrecision` 0)]) "" RegularPosting [] Nothing - ,Posting False "b" missingmixedamt "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]} + ,posting{paccount="b", pamount= missingmixedamt} ] "")) ,"balanceTransaction" ~: do assertBool "detect unbalanced entry, sign error" (isLeft $ balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] - [Posting False "a" (Mixed [usd 1]) "" RegularPosting [] Nothing, - Posting False "b" (Mixed [usd 1]) "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [usd 1]} + ,posting{paccount="b", pamount=Mixed [usd 1]} ] "")) assertBool "detect unbalanced entry, multiple missing amounts" (isLeft $ balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] - [Posting False "a" missingmixedamt "" RegularPosting [] Nothing, - Posting False "b" missingmixedamt "" RegularPosting [] Nothing + [posting{paccount="a", pamount=missingmixedamt} + ,posting{paccount="b", pamount=missingmixedamt} ] "")) let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" [] - [Posting False "a" (Mixed [usd 1]) "" RegularPosting [] Nothing, - Posting False "b" missingmixedamt "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [usd 1]} + ,posting{paccount="b", pamount=missingmixedamt} ] "") assertBool "balanceTransaction allows one missing amount" (isRight e) assertEqual "balancing amount is inferred" @@ -475,8 +468,8 @@ Left _ -> error' "should not happen") let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] - [Posting False "a" (Mixed [usd 1.35]) "" RegularPosting [] Nothing, - Posting False "b" (Mixed [eur (-1)]) "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [usd 1.35]} + ,posting{paccount="b", pamount=Mixed [eur (-1)]} ] "") assertBool "balanceTransaction can infer conversion price" (isRight e) assertEqual "balancing conversion price is inferred" @@ -487,52 +480,52 @@ assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $ balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] - [Posting False "a" (Mixed [usd 1 `at` eur 2]) "" RegularPosting [] Nothing - ,Posting False "a" (Mixed [usd (-2) `at` eur 1]) "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [usd 1 `at` eur 2]} + ,posting{paccount="a", pamount=Mixed [usd (-2) `at` eur 1]} ] "")) assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $ balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] - [Posting False "a" (Mixed [usd 1 @@ eur 1]) "" RegularPosting [] Nothing - ,Posting False "a" (Mixed [usd (-2) @@ eur 1]) "" RegularPosting [] Nothing + [posting{paccount="a", pamount=Mixed [usd 1 @@ eur 1]} + ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]} ] "")) ,"isTransactionBalanced" ~: do let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) - ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} + ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} ] "" assertBool "detect balanced" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) - ,Posting False "c" (Mixed [usd (-1.01)]) "" RegularPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} + ,posting{paccount="c", pamount=Mixed [usd (-1.01)], ptransaction=Just t} ] "" assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ] "" assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 0]) "" RegularPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t} ] "" assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) - ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t) - ,Posting False "d" (Mixed [usd 100]) "" VirtualPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} + ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} + ,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting, ptransaction=Just t} ] "" assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) - ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t) - ,Posting False "d" (Mixed [usd 100]) "" BalancedVirtualPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} + ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} + ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t} ] "" assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] - [Posting False "b" (Mixed [usd 1.00]) "" RegularPosting [] (Just t) - ,Posting False "c" (Mixed [usd (-1.00)]) "" RegularPosting [] (Just t) - ,Posting False "d" (Mixed [usd 100]) "" BalancedVirtualPosting [] (Just t) - ,Posting False "e" (Mixed [usd (-100)]) "" BalancedVirtualPosting [] (Just t) + [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} + ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} + ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t} + ,posting{paccount="3", pamount=Mixed [usd (-100)], ptype=BalancedVirtualPosting, ptransaction=Just t} ] "" assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t) diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -29,7 +29,7 @@ type SmartDate = (String,String,String) -data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) +data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) @@ -76,6 +76,8 @@ type Tag = (String, String) data Posting = Posting { + pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's + pdate2 :: Maybe Day, -- ^ this posting's secondary date, if different from the transaction's pstatus :: Bool, paccount :: AccountName, pamount :: MixedAmount, @@ -89,11 +91,11 @@ -- The equality test for postings ignores the parent transaction's -- identity, to avoid infinite loops. instance Eq Posting where - (==) (Posting a1 b1 c1 d1 e1 f1 _) (Posting a2 b2 c2 d2 e2 f2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 + (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 data Transaction = Transaction { tdate :: Day, - teffectivedate :: Maybe Day, + tdate2 :: Maybe Day, tstatus :: Bool, -- XXX tcleared ? tcode :: String, tdescription :: String, @@ -178,42 +180,6 @@ instance Show Reader where show r = "Reader for "++rFormat r --- data format parse/conversion rules - --- currently the only parse (conversion) rules are those for the CSV format -type ParseRules = CsvRules - --- XXX copied from Convert.hs -{- | -A set of data definitions and account-matching patterns sufficient to -convert a particular CSV data file into meaningful journal transactions. See above. --} -data CsvRules = CsvRules { - dateField :: Maybe FieldPosition, - dateFormat :: Maybe String, - statusField :: Maybe FieldPosition, - codeField :: Maybe FieldPosition, - descriptionField :: [FormatString], - amountField :: Maybe FieldPosition, - amountInField :: Maybe FieldPosition, - amountOutField :: Maybe FieldPosition, - currencyField :: Maybe FieldPosition, - baseCurrency :: Maybe String, - accountField :: Maybe FieldPosition, - account2Field :: Maybe FieldPosition, - effectiveDateField :: Maybe FieldPosition, - baseAccount :: AccountName, - accountRules :: [AccountRule], - skipLines :: Int -} deriving (Show, Eq) - -type FieldPosition = Int - -type AccountRule = ( - [(String, Maybe String)] -- list of regex match patterns with optional replacements - ,AccountName -- account name to use for a transaction matching this rule - ) - -- format strings data HledgerFormatField = @@ -246,6 +212,8 @@ aparent :: Maybe Account, -- ^ parent account aboring :: Bool -- ^ used in the accounts report to label elidable parents } + + -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -43,6 +43,7 @@ import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName +import Hledger.Data.Amount (nullamt) import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction @@ -55,12 +56,14 @@ | Not Query -- ^ negate this match | Or [Query] -- ^ match if any of these match | And [Query] -- ^ match if all of these match + | Code String -- ^ match if code matches this regexp | Desc String -- ^ match if description matches this regexp | Acct String -- ^ match postings whose account matches this regexp - | Date DateSpan -- ^ match if actual date in this date span - | EDate DateSpan -- ^ match if effective date in this date span + | Date DateSpan -- ^ match if primary date in this date span + | Date2 DateSpan -- ^ match if secondary date in this date span | Status Bool -- ^ match if cleared status has this value | Real Bool -- ^ match if "realness" (involves a real non-virtual account ?) has this value + | Amt Ordering Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to some value | Empty Bool -- ^ if true, show zero-amount postings/accounts which are usually not shown -- more of a query option than a query criteria ? | Depth Int -- ^ match if account depth is less than or equal to this value @@ -72,7 +75,7 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible - -- | QueryOptEffectiveDate -- ^ show effective dates instead of actual dates + -- | QueryOptDate2 -- ^ show secondary dates instead of primary dates deriving (Show, Eq) -- parsing @@ -171,6 +174,7 @@ prefixes = map (++":") [ "inacctonly" ,"inacct" + ,"code" ,"desc" ,"acct" ,"date" @@ -201,6 +205,7 @@ parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of Left m -> Left $ Not m Right _ -> Left Any -- not:somequeryoption will be ignored +parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s parseQueryTerm d ('d':'a':'t':'e':':':s) = @@ -208,9 +213,10 @@ Right (_,span) -> Left $ Date span parseQueryTerm d ('e':'d':'a':'t':'e':':':s) = case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn - Right (_,span) -> Left $ EDate span + Right (_,span) -> Left $ Date2 span parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s +parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt op q where (op, q) = parseAmountTest s parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s parseQueryTerm _ ('d':'e':'p':'t':'h':':':s) = Left $ Depth $ readDef 0 s parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s @@ -232,8 +238,30 @@ "inacct:a" `gives` (Right $ QueryOptInAcct "a") "tag:a" `gives` (Left $ Tag "a" Nothing) "tag:a=some value" `gives` (Left $ Tag "a" (Just "some value")) + -- "amt:<0" `gives` (Left $ Amt LT 0) + -- "amt:=.23" `gives` (Left $ Amt EQ 0.23) + -- "amt:>10000.10" `gives` (Left $ Amt GT 10000.1) ] +-- can fail +parseAmountTest :: String -> (Ordering, Quantity) +parseAmountTest s = + case s of + "" -> err + '<':s' -> (LT, readDef err s') + '=':s' -> (EQ, readDef err s') + '>':s' -> (GT, readDef err s') + _ -> err + where err = error' $ "could not parse as operator followed by numeric quantity: "++s + +tests_parseAmountTest = [ + "parseAmountTest" ~: do + let s `gives` r = parseAmountTest s `is` r + "<0" `gives` (LT,0) + "=0.23" `gives` (EQ,0.23) + ">10000.10" `gives` (GT,10000.1) + ] + parseTag :: String -> (String, Maybe String) parseTag s | '=' `elem` s = (n, Just $ tail v) | otherwise = (s, Nothing) @@ -337,40 +365,40 @@ -- | Does this query specify a start date and nothing else (that would -- filter postings prior to the date) ? --- When the flag is true, look for a starting effective date instead. +-- When the flag is true, look for a starting secondary date instead. queryIsStartDateOnly :: Bool -> Query -> Bool queryIsStartDateOnly _ Any = False queryIsStartDateOnly _ None = False -queryIsStartDateOnly effective (Or ms) = and $ map (queryIsStartDateOnly effective) ms -queryIsStartDateOnly effective (And ms) = and $ map (queryIsStartDateOnly effective) ms +queryIsStartDateOnly secondary (Or ms) = and $ map (queryIsStartDateOnly secondary) ms +queryIsStartDateOnly secondary (And ms) = and $ map (queryIsStartDateOnly secondary) ms queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True -queryIsStartDateOnly True (EDate (DateSpan (Just _) _)) = True +queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True queryIsStartDateOnly _ _ = False --- | What start date (or effective date) does this query specify, if any ? +-- | What start date (or secondary date) does this query specify, if any ? -- For OR expressions, use the earliest of the dates. NOT is ignored. queryStartDate :: Bool -> Query -> Maybe Day -queryStartDate effective (Or ms) = earliestMaybeDate $ map (queryStartDate effective) ms -queryStartDate effective (And ms) = latestMaybeDate $ map (queryStartDate effective) ms +queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms +queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms queryStartDate False (Date (DateSpan (Just d) _)) = Just d -queryStartDate True (EDate (DateSpan (Just d) _)) = Just d +queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d queryStartDate _ _ = Nothing queryTermDateSpan (Date span) = Just span queryTermDateSpan _ = Nothing --- | What date span (or effective date span) does this query specify ? +-- | What date span (or secondary date span) does this query specify ? -- For OR expressions, use the widest possible span. NOT is ignored. queryDateSpan :: Bool -> Query -> DateSpan -queryDateSpan effective q = spansUnion $ queryDateSpans effective q +queryDateSpan secondary q = spansUnion $ queryDateSpans secondary q --- | Extract all date (or effective date) spans specified in this query. +-- | Extract all date (or secondary date) spans specified in this query. -- NOT is ignored. queryDateSpans :: Bool -> Query -> [DateSpan] -queryDateSpans effective (Or qs) = concatMap (queryDateSpans effective) qs -queryDateSpans effective (And qs) = concatMap (queryDateSpans effective) qs +queryDateSpans secondary (Or qs) = concatMap (queryDateSpans secondary) qs +queryDateSpans secondary (And qs) = concatMap (queryDateSpans secondary) qs queryDateSpans False (Date span) = [span] -queryDateSpans True (EDate span) = [span] +queryDateSpans True (Date2 span) = [span] queryDateSpans _ _ = [] -- | What is the earliest of these dates, where Nothing is earliest ? @@ -457,7 +485,7 @@ assertBool "" $ Depth 2 `matchesAccount` "a:b" assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ Date nulldatespan `matchesAccount` "a" - assertBool "" $ EDate nulldatespan `matchesAccount` "a" + assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" ] @@ -468,18 +496,15 @@ matchesPosting (None) _ = False matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs +matchesPosting (Code r) p = regexMatchesCI r $ maybe "" tcode $ ptransaction p matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p matchesPosting (Acct r) p = regexMatchesCI r $ paccount p -matchesPosting (Date span) p = - case d of Just d' -> spanContainsDate span d' - Nothing -> False - where d = maybe Nothing (Just . tdate) $ ptransaction p -matchesPosting (EDate span) p = - case postingEffectiveDate p of Just d -> spanContainsDate span d - Nothing -> False +matchesPosting (Date span) p = span `spanContainsDate` postingDate p +matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (Status v) p = v == postingCleared p matchesPosting (Real v) p = v == isReal p matchesPosting (Depth d) Posting{paccount=a} = Depth d `matchesAccount` a +matchesPosting (Amt op n) Posting{pamount=a} = compareMixedAmount op n a -- matchesPosting (Empty v) Posting{pamount=a} = v == isZeroMixedAmount a -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a @@ -488,6 +513,14 @@ matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p -- matchesPosting _ _ = False +-- | Is this simple mixed amount's quantity less than, equal to, or greater than this number ? +-- For complext mixed amounts (with multiple commodities), this is always true. +compareMixedAmount :: Ordering -> Quantity -> MixedAmount -> Bool +compareMixedAmount op q (Mixed []) = compareMixedAmount op q (Mixed [nullamt]) +-- compareMixedAmount op q (Mixed [a]) = strace (compare (strace $ aquantity a) (strace q)) == op +compareMixedAmount op q (Mixed [a]) = compare (aquantity a) q == op +compareMixedAmount _ _ _ = True + tests_matchesPosting = [ "matchesPosting" ~: do -- matching posting status.. @@ -523,12 +556,14 @@ matchesTransaction (None) _ = False matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs +matchesTransaction (Code r) t = regexMatchesCI r $ tcode t matchesTransaction (Desc r) t = regexMatchesCI r $ tdescription t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Date span) t = spanContainsDate span $ tdate t -matchesTransaction (EDate span) t = spanContainsDate span $ transactionEffectiveDate t +matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t matchesTransaction (Status v) t = v == tstatus t matchesTransaction (Real v) t = v == hasRealPostings t +matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Empty _) _ = True matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction (Tag n Nothing) t = isJust $ lookupTagByName n $ transactionAllTags t @@ -560,9 +595,6 @@ matchTagValue :: String -> String -> Bool matchTagValue pat value = regexMatchesCI pat value -postingEffectiveDate :: Posting -> Maybe Day -postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p - -- tests tests_Hledger_Query :: Test @@ -571,6 +603,7 @@ ++ tests_words'' ++ tests_filterQuery ++ tests_parseQueryTerm + ++ tests_parseAmountTest ++ tests_parseQuery ++ tests_matchesAccount ++ tests_matchesPosting diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -22,6 +22,7 @@ amountp, amountp', mamountp', + code, -- * Tests samplejournal, tests_Hledger_Read, @@ -35,7 +36,7 @@ import System.Environment (getEnv) import System.Exit (exitFailure) import System.FilePath (()) -import System.IO (IOMode(..), withFile, stderr) +import System.IO (IOMode(..), withFile, stdin, stderr, hSetNewlineMode, universalNewlineMode) import Test.HUnit import Text.Printf @@ -157,10 +158,14 @@ -- formats. A CSV conversion rules file may be specified for better -- conversion of that format. readJournalFile :: Maybe Format -> Maybe FilePath -> FilePath -> IO (Either String Journal) -readJournalFile format rulesfile "-" = getContents >>= readJournal format rulesfile (Just "(stdin)") +readJournalFile format rulesfile "-" = do + hSetNewlineMode stdin universalNewlineMode + getContents >>= readJournal format rulesfile (Just "(stdin)") readJournalFile format rulesfile f = do requireJournalFileExists f - withFile f ReadMode $ \h -> hGetContents h >>= readJournal format rulesfile (Just f) + withFile f ReadMode $ \h -> do + hSetNewlineMode h universalNewlineMode + hGetContents h >>= readJournal format rulesfile (Just f) -- | If the specified journal file does not exist, give a helpful error and quit. requireJournalFileExists :: FilePath -> IO () @@ -216,7 +221,7 @@ tests_Hledger_Read = TestList $ tests_readJournal' ++ [ - tests_Hledger_Read_JournalReader, + -- tests_Hledger_Read_JournalReader, tests_Hledger_Read_TimelogReader, tests_Hledger_Read_CsvReader, diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -1,25 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-| -A reader for the CSV data format. Uses an extra rules file -() to help interpret -the data. Example: - -@ -\"2012\/3\/22\",\"something\",\"10.00\" -\"2012\/3\/23\",\"another\",\"5.50\" -@ - -and rules file: - -@ -date-field 0 -description-field 1 -amount-field 2 -base-account assets:bank:checking - -SAVINGS -assets:bank:savings -@ +A reader for CSV data, using an extra rules file to help interpret the data. -} @@ -28,21 +10,24 @@ reader, -- * Misc. CsvRecord, - nullrules, + -- rules, rulesFileFor, - parseCsvRulesFile, + parseRulesFile, transactionFromCsvRecord, -- * Tests tests_Hledger_Read_CsvReader ) where +import Control.Applicative ((<$>)) import Control.Exception hiding (try) import Control.Monad import Control.Monad.Error -- import Test.HUnit +import Data.Char (toLower, isDigit) import Data.List import Data.Maybe import Data.Ord +import Data.Time.Calendar (Day) import Data.Time.Format (parseTime) import Safe import System.Directory (doesFileExist) @@ -54,14 +39,13 @@ import Text.ParserCombinators.Parsec hiding (parse) import Text.ParserCombinators.Parsec.Error import Text.ParserCombinators.Parsec.Pos -import Text.Printf (hPrintf) +import Text.Printf (hPrintf,printf) import Hledger.Data import Prelude hiding (getContents) import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils -import Hledger.Data.FormatStrings as FormatStrings -import Hledger.Read.JournalReader (accountname, amountp) +import Hledger.Read.JournalReader (amountp) reader :: Reader @@ -83,28 +67,6 @@ case r of Left e -> throwError e Right j -> return j -nullrules = CsvRules { - dateField=Nothing, - dateFormat=Nothing, - statusField=Nothing, - codeField=Nothing, - descriptionField=[], - amountField=Nothing, - amountInField=Nothing, - amountOutField=Nothing, - currencyField=Nothing, - baseCurrency=Nothing, - accountField=Nothing, - account2Field=Nothing, - effectiveDateField=Nothing, - baseAccount="unknown", - accountRules=[], - skipLines=0 -} - -type CsvRecord = [String] - - -- | Read a Journal from the given CSV data (and filename, used for error -- messages), or return an error. Proceed as follows: -- @ @@ -120,30 +82,83 @@ readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when converting stdin" readJournalFromCsv mrulesfile csvfile csvdata = handle (\e -> return $ Left $ show (e :: IOException)) $ do - csvparse <- parseCsv csvfile csvdata - let rs = case csvparse of - Left e -> throw $ userError $ show e - Right rs -> filter (/= [""]) rs - badrecords = take 1 $ filter ((< 2).length) rs - records = case badrecords of - [] -> rs - (_:_) -> throw $ userError $ "Parse error: at least one CSV record has less than two fields:\n"++(show $ head badrecords) + let throwerr = throw.userError + -- parse csv + records <- (either throwerr id . validateCsv) `fmap` parseCsv csvfile csvdata + dbg 1 $ ppShow $ take 3 records + + -- identify header lines + -- let (headerlines, datalines) = identifyHeaderLines records + -- mfieldnames = lastMay headerlines + + -- parse rules let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile created <- records `seq` ensureRulesFileExists rulesfile if created then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile else hPrintf stderr "using conversion rules file %s\n" rulesfile + rules <- either (throwerr.show) id `fmap` parseRulesFile rulesfile + dbg 1 $ ppShow rules - rules <- liftM (either (throw.userError.show) id) $ parseCsvRulesFile rulesfile + -- apply skip directive + let headerlines = maybe 0 oneorerror $ getDirective "skip" rules + where + oneorerror "" = 1 + oneorerror s = readDef (throwerr $ "could not parse skip value: " ++ show s) s + records' = drop headerlines records - let requiredfields = (maxFieldIndex rules + 1) - realrecords = drop (skipLines rules) records - badrecords = take 1 $ filter ((< requiredfields).length) realrecords - return $ case badrecords of - [] -> Right nulljournal{jtxns=sortBy (comparing tdate) $ map (transactionFromCsvRecord rules) realrecords} - (_:_) -> Left $ "Parse error: at least one CSV record does not contain a field referenced by the conversion rules file:\n"++(show $ head badrecords) + -- convert to transactions and return as a journal + let txns = map (transactionFromCsvRecord rules) records' + return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns} +parseCsv :: FilePath -> String -> IO (Either ParseError CSV) +parseCsv path csvdata = + case path of + "-" -> liftM (parseCSV "(stdin)") getContents + _ -> return $ parseCSV path csvdata + +-- | Return the cleaned up and validated CSV data, or an error. +validateCsv :: Either ParseError CSV -> Either String [CsvRecord] +validateCsv (Left e) = Left $ show e +validateCsv (Right rs) = validate $ filternulls rs + where + filternulls = filter (/=[""]) + validate [] = Left "no CSV records found" + validate rs@(first:_) + | isJust lessthan2 = let r = fromJust lessthan2 in Left $ printf "CSV record %s has less than two fields" (show r) + | isJust different = let r = fromJust different in Left $ printf "the first CSV record %s has %d fields but %s has %d" (show first) length1 (show r) (length r) + | otherwise = Right rs + where + length1 = length first + lessthan2 = headMay $ filter ((<2).length) rs + different = headMay $ filter ((/=length1).length) rs + +-- -- | The highest (0-based) field index referenced in the field +-- -- definitions, or -1 if no fields are defined. +-- maxFieldIndex :: CsvRules -> Int +-- maxFieldIndex r = maximumDef (-1) $ catMaybes [ +-- dateField r +-- ,statusField r +-- ,codeField r +-- ,amountField r +-- ,amountInField r +-- ,amountOutField r +-- ,currencyField r +-- ,accountField r +-- ,account2Field r +-- ,date2Field r +-- ] + +-- rulesFileFor :: CliOpts -> FilePath -> FilePath +-- rulesFileFor CliOpts{rules_file_=Just f} _ = f +-- rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules" +rulesFileFor :: FilePath -> FilePath +rulesFileFor = (++ ".rules") + +csvFileFor :: FilePath -> FilePath +csvFileFor = reverse . drop 6 . reverse + -- | Ensure there is a conversion rules file at the given path, creating a -- default one if needed and returning True in this case. ensureRulesFileExists :: FilePath -> IO Bool @@ -154,67 +169,158 @@ else do -- note Hledger.Utils.UTF8.* do no line ending conversion on windows, -- we currently require unix line endings on all platforms. - writeFile f newRulesFileContent + writeFile f $ newRulesFileContent f return True -parseCsv :: FilePath -> String -> IO (Either ParseError CSV) -parseCsv path csvdata = - case path of - "-" -> liftM (parseCSV "(stdin)") getContents - _ -> return $ parseCSV path csvdata +newRulesFileContent :: FilePath -> String +newRulesFileContent f = unlines + ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName f) + ,"# cf http://hledger.org/MANUAL.html" + ,"" + ,"account1 assets:bank:checking" + ,"" + ,"fields date, description, amount" + ,"" + ,"#skip 1" + ,"" + ,"#date-format %-d/%-m/%Y" + ,"#date-format %-m/%-d/%Y" + ,"#date-format %Y-%h-%d" + ,"" + ,"#currency $" + ,"" + ,"if ITUNES" + ," account2 expenses:entertainment" + ,"" + ,"if (TO|FROM) SAVINGS" + ," account2 assets:bank:savings\n" + ] --- | The highest (0-based) field index referenced in the field --- definitions, or -1 if no fields are defined. -maxFieldIndex :: CsvRules -> Int -maxFieldIndex r = maximumDef (-1) $ catMaybes [ - dateField r - ,statusField r - ,codeField r - ,amountField r - ,amountInField r - ,amountOutField r - ,currencyField r - ,accountField r - ,account2Field r - ,effectiveDateField r - ] --- rulesFileFor :: CliOpts -> FilePath -> FilePath --- rulesFileFor CliOpts{rules_file_=Just f} _ = f --- rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules" -rulesFileFor :: FilePath -> FilePath -rulesFileFor = flip replaceExtension ".rules" +-------------------------------------------------------------------------------- +-- Conversion rules parsing -newRulesFileContent :: String -newRulesFileContent = let prognameandversion = "hledger" in - "# csv conversion rules file generated by " ++ prognameandversion ++ "\n" ++ - "# Add rules to this file for more accurate conversion, see\n"++ - "# http://hledger.org/MANUAL.html#convert\n" ++ - "\n" ++ - "skip-lines 0\n" ++ - "base-account assets:bank:checking\n" ++ - "date-field 0\n" ++ - "description-field 4\n" ++ - "amount-field 1\n" ++ - "base-currency $\n" ++ - "\n" ++ - "# account-assigning rules\n" ++ - "\n" ++ - "SPECTRUM\n" ++ - "expenses:health:gym\n" ++ - "\n" ++ - "ITUNES\n" ++ - "BLKBSTR=BLOCKBUSTER\n" ++ - "expenses:entertainment\n" ++ - "\n" ++ - "(TO|FROM) SAVINGS\n" ++ - "assets:bank:savings\n" +{- +Grammar for the CSV conversion rules, more or less: --- rules file parser +RULES: RULE* -parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules) -parseCsvRulesFile f = do - s <- readFile f +RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | DATE-FORMAT | COMMENT | BLANK ) NEWLINE + +FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )* + +FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME + +QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ " + +BARE-FIELD-NAME: any CHAR except space, tab, #, ; + +FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE + +JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD + +JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency + +ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? ) + +FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs) + +CSV-FIELD-REFERENCE: % CSV-FIELD + +CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field) + +FIELD-NUMBER: DIGIT+ + +CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK + +FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS + +MATCHOP: ~ + +PATTERNS: ( NEWLINE REGEXP )* REGEXP + +INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+ + +REGEXP: ( NONSPACE CHAR* ) SPACE? + +VALUE: SPACE? ( CHAR* ) SPACE? + +COMMENT: SPACE? COMMENT-CHAR VALUE + +COMMENT-CHAR: # | ; + +NONSPACE: any CHAR not a SPACE-CHAR + +BLANK: SPACE? + +SPACE: SPACE-CHAR+ + +SPACE-CHAR: space | tab + +CHAR: any character except newline + +DIGIT: 0-9 + +-} + +{- | +A set of data definitions and account-matching patterns sufficient to +convert a particular CSV data file into meaningful journal transactions. +-} +data CsvRules = CsvRules { + rdirectives :: [(DirectiveName,String)], + rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)], + rassignments :: [(JournalFieldName, FieldTemplate)], + rconditionalblocks :: [ConditionalBlock] +} deriving (Show, Eq) + +type DirectiveName = String +type CsvFieldName = String +type CsvFieldIndex = Int +type JournalFieldName = String +type FieldTemplate = String +type ConditionalBlock = ([RecordMatcher], [(JournalFieldName, FieldTemplate)]) -- block matches if all RecordMatchers match +type RecordMatcher = [Regexp] -- match if any regexps match any of the csv fields +-- type FieldMatcher = (CsvFieldName, [Regexp]) -- match if any regexps match this csv field +type DateFormat = String +type Regexp = String + +rules = CsvRules { + rdirectives=[], + rcsvfieldindexes=[], + rassignments=[], + rconditionalblocks=[] +} + +addDirective :: (DirectiveName, String) -> CsvRules -> CsvRules +addDirective d r = r{rdirectives=d:rdirectives r} + +addAssignment :: (JournalFieldName, FieldTemplate) -> CsvRules -> CsvRules +addAssignment a r = r{rassignments=a:rassignments r} + +setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules +setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r + +setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRules -> CsvRules +setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]} + +addAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules +addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames + where + maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules + where + addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1)) + +addConditionalBlock :: ConditionalBlock -> CsvRules -> CsvRules +addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r} + +getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate +getDirective directivename = lookup directivename . rdirectives + + +parseRulesFile :: FilePath -> IO (Either ParseError CsvRules) +parseRulesFile f = do + s <- readFile' f let rules = parseCsvRules f s return $ case rules of Left e -> Left e @@ -225,365 +331,395 @@ toParseError s = newErrorMessage (Message s) (initialPos "") parseCsvRules :: FilePath -> String -> Either ParseError CsvRules -parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s - -csvrulesfile :: GenParser Char CsvRules CsvRules -csvrulesfile = do - many blankorcommentline - many definitions - r <- getState - ars <- many accountrule - many blankorcommentline - eof - return r{accountRules=ars} +-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s +parseCsvRules rulesfile s = + runParser rulesp rules rulesfile s -definitions :: GenParser Char CsvRules () -definitions = do - choice' [ - datefield - ,dateformat - ,statusfield - ,codefield - ,descriptionfield - ,amountfield - ,amountinfield - ,amountoutfield - ,currencyfield - ,accountfield - ,account2field - ,effectivedatefield - ,basecurrency - ,baseaccount - ,skiplines - ,commentline - ] "definition" - return () +-- | Return the validated rules, or an error. +validateRules :: CsvRules -> Either String CsvRules +validateRules rules = do + unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1\n" + unless ((amount && not (amountin || amountout)) || + (not amount && (amountin && amountout))) + $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" + Right rules + where + amount = isAssigned "amount" + amountin = isAssigned "amount-in" + amountout = isAssigned "amount-out" + isAssigned f = isJust $ getEffectiveAssignment rules [] f -datefield = do - string "date-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{dateField=readMay v}) +-- parsers -effectivedatefield = do - string "effective-date-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{effectiveDateField=readMay v}) +rulesp :: GenParser Char CsvRules CsvRules +rulesp = do + many $ choice' + [blankorcommentline "blank or comment line" + ,(directive >>= updateState . addDirective) "directive" + ,(fieldnamelist >>= updateState . setIndexesAndAssignmentsFromList) "field name list" + ,(fieldassignment >>= updateState . addAssignment) "field assignment" + ,(conditionalblock >>= updateState . addConditionalBlock) "conditional block" + ] + eof + r <- getState + return r{rdirectives=reverse $ rdirectives r + ,rassignments=reverse $ rassignments r + ,rconditionalblocks=reverse $ rconditionalblocks r + } -dateformat = do - string "date-format" - many1 spacenonewline - v <- restofline - updateState (\r -> r{dateFormat=Just v}) +blankorcommentline = pdbg 1 "trying blankorcommentline" >> choice' [blankline, commentline] +blankline = many spacenonewline >> newline >> return () "blank line" +commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line" +commentchar = oneOf ";#" -codefield = do - string "code-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{codeField=readMay v}) +directive = do + pdbg 1 "trying directive" + d <- choice' $ map string directives + v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directiveval) + <|> (optional (char ':') >> many spacenonewline >> eolof >> return "") + return (d,v) + "directive" -statusfield = do - string "status-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{statusField=readMay v}) +directives = + ["date-format" + -- ,"default-account1" + -- ,"default-currency" + -- ,"skip-lines" -- old + ,"skip" + -- ,"base-account" + -- ,"base-currency" + ] -descriptionFieldValue :: GenParser Char st [FormatString] -descriptionFieldValue = do --- try (fieldNo <* spacenonewline) - try fieldNo - <|> formatStrings - where - fieldNo = many1 digit >>= \x -> return [FormatField False Nothing Nothing $ FieldNo $ read x] +directiveval = anyChar `manyTill` eolof -descriptionfield = do - string "description-field" +fieldnamelist = (do + pdbg 1 "trying fieldnamelist" + string "fields" + optional $ char ':' many1 spacenonewline - formatS <- descriptionFieldValue + f <- fieldname + let separator = many spacenonewline >> char ',' >> many spacenonewline + fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldname) restofline - updateState (\x -> x{descriptionField=formatS}) + return $ map (map toLower) $ f:fs + ) "field name list" -amountfield = do - string "amount-field" - many1 spacenonewline - v <- restofline - x <- updateState (\r -> r{amountField=readMay v}) - return x +fieldname = quotedfieldname <|> barefieldname -amountinfield = do - choice [string "amount-in-field", string "in-field"] - many1 spacenonewline - v <- restofline - updateState (\r -> r{amountInField=readMay v}) +quotedfieldname = do + char '"' + f <- many1 $ noneOf "\"\n:;#~" + char '"' + return f -amountoutfield = do - choice [string "amount-out-field", string "out-field"] - many1 spacenonewline - v <- restofline - updateState (\r -> r{amountOutField=readMay v}) +barefieldname = many1 $ noneOf " \t\n,;#~" -currencyfield = do - string "currency-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{currencyField=readMay v}) +fieldassignment = do + pdbg 1 "trying fieldassignment" + f <- journalfieldname + assignmentseparator + v <- fieldval + return (f,v) + "field assignment" -accountfield = do - string "account-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{accountField=readMay v}) +journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames) -account2field = do - string "account2-field" - many1 spacenonewline - v <- restofline - updateState (\r -> r{account2Field=readMay v}) +journalfieldnames = + [-- pseudo fields: + "amount-in" + ,"amount-out" + ,"currency" + -- standard fields: + ,"date2" + ,"date" + ,"status" + ,"code" + ,"description" + ,"amount" + ,"account1" + ,"account2" + ,"comment" + ] -basecurrency = do - choice [string "base-currency", string "currency"] - many1 spacenonewline - v <- restofline - updateState (\r -> r{baseCurrency=Just v}) +assignmentseparator = do + pdbg 3 "trying assignmentseparator" + choice [ + -- try (many spacenonewline >> oneOf ":="), + try (many spacenonewline >> char ':'), + space + ] + many spacenonewline -baseaccount = do - string "base-account" - many1 spacenonewline - v <- accountname - optional newline - updateState (\r -> r{baseAccount=v}) +fieldval = do + pdbg 2 "trying fieldval" + anyChar `manyTill` eolof -skiplines = do - string "skip-lines" - many1 spacenonewline - v <- restofline - updateState (\r -> r{skipLines=read v}) +conditionalblock = do + pdbg 1 "trying conditionalblock" + string "if" >> many spacenonewline >> optional newline + ms <- many1 recordmatcher + as <- many (many1 spacenonewline >> fieldassignment) + when (null as) $ + fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n" + return (ms, as) + "conditional block" -accountrule :: GenParser Char CsvRules AccountRule -accountrule = do - many blankorcommentline - pats <- many1 matchreplacepattern - guard $ length pats >= 2 - let pats' = init pats - acct = either (fail.show) id $ runParser accountname () "" $ fst $ last pats - many blankorcommentline - return (pats',acct) - "account rule" +recordmatcher = do + pdbg 2 "trying recordmatcher" + -- pos <- currentPos + _ <- optional (matchoperator >> many spacenonewline >> optional newline) + ps <- patterns + when (null ps) $ + fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" + return ps + "record matcher" -blankline = many spacenonewline >> newline >> return () "blank line" +matchoperator = choice' $ map string + ["~" + -- ,"!~" + -- ,"=" + -- ,"!=" + ] -commentchar = oneOf ";#" +patterns = do + pdbg 3 "trying patterns" + ps <- many regexp + return ps -commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line" +regexp = do + pdbg 3 "trying regexp" + notFollowedBy matchoperator + c <- nonspace + cs <- anyChar `manyTill` eolof + return $ strip $ c:cs -blankorcommentline = choice' [blankline, commentline] +-- fieldmatcher = do +-- pdbg 2 "trying fieldmatcher" +-- f <- fromMaybe "all" `fmap` (optionMaybe $ do +-- f' <- fieldname +-- many spacenonewline +-- return f') +-- char '~' +-- many spacenonewline +-- ps <- patterns +-- let r = "(" ++ intercalate "|" ps ++ ")" +-- return (f,r) +-- "field matcher" -matchreplacepattern = do - notFollowedBy commentchar - matchpat <- many1 (noneOf "=\n") - replpat <- optionMaybe $ do {char '='; many $ noneOf "\n"} - newline - return (matchpat,replpat) +-------------------------------------------------------------------------------- +-- Converting CSV records to journal transactions -validateRules :: CsvRules -> Either String CsvRules -validateRules rules = - let hasAmount = isJust $ amountField rules - hasIn = isJust $ amountInField rules - hasOut = isJust $ amountOutField rules - in case (hasAmount, hasIn, hasOut) of - (True, True, _) -> Left "Don't specify amount-in-field when specifying amount-field" - (True, _, True) -> Left "Don't specify amount-out-field when specifying amount-field" - (_, False, True) -> Left "Please specify amount-in-field when specifying amount-out-field" - (_, True, False) -> Left "Please specify amount-out-field when specifying amount-in-field" - (False, False, False) -> Left "Please specify either amount-field, or amount-in-field and amount-out-field" - _ -> Right rules +type CsvRecord = [String] --- csv record conversion -formatD :: CsvRecord -> Bool -> Maybe Int -> Maybe Int -> HledgerFormatField -> String -formatD record leftJustified min max f = case f of - FieldNo n -> maybe "" show $ atMay record n - -- Some of these might in theory in read from fields - AccountField -> "" - DepthSpacerField -> "" - TotalField -> "" - DefaultDateField -> "" - DescriptionField -> "" - where - show = formatValue leftJustified min max +-- Convert a CSV record to a transaction using the rules, or raise an +-- error if the data can not be parsed. +transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction +transactionFromCsvRecord rules record = t + where + mdirective = (`getDirective` rules) + mfieldtemplate = getEffectiveAssignment rules record + render = renderTemplate rules record + mskip = mdirective "skip" + mdefaultcurrency = mdirective "default-currency" + mparsedate = parseDateWithFormatOrDefaultFormats (mdirective "date-format") -formatDescription :: CsvRecord -> [FormatString] -> String -formatDescription _ [] = "" -formatDescription record (f:fs) = s ++ (formatDescription record fs) - where s = case f of - FormatLiteral l -> l - FormatField leftJustified min max field -> formatD record leftJustified min max field + -- render each field using its template and the csv record, and + -- in some cases parse the rendered string (eg dates and amounts) + mdateformat = mdirective "date-format" + date = render $ fromMaybe "" $ mfieldtemplate "date" + date' = fromMaybe (error' $ dateerror "date" date mdateformat) $ mparsedate date + mdate2 = maybe Nothing (Just . render) $ mfieldtemplate "date2" + mdate2' = maybe Nothing (maybe (error' $ dateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . mparsedate) mdate2 + dateerror datefield value mdateformat = unlines + ["error: could not parse \""++value++"\" as a date using date format "++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat + ,"the CSV record is: "++intercalate ", " (map show record) + ,"the "++datefield++" rule is: "++(fromMaybe "required, but missing" $ mfieldtemplate datefield) + ,"the date-format is: "++fromMaybe "unspecified" mdateformat + ,"you may need to " + ++"change your "++datefield++" rule, " + ++maybe "add a" (const "change your") mdateformat++" date-format rule, " + ++"or "++maybe "add a" (const "change your") mskip++" skip rule" + ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" + ] + status = maybe False ((=="*") . render) $ mfieldtemplate "status" + code = maybe "" render $ mfieldtemplate "code" + description = maybe "" render $ mfieldtemplate "description" + comment = maybe "" render $ mfieldtemplate "comment" + precomment = maybe "" render $ mfieldtemplate "precomment" + currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" + amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record + amount = either amounterror mixed $ runParser (do {a <- amountp; eof; return a}) nullctx "" amountstr + amounterror err = error' $ unlines + ["error: could not parse \""++amountstr++"\" as an amount" + ,showRecord record + ,"the amount rule is: "++(fromMaybe "" $ mfieldtemplate "amount") + ,"the currency rule is: "++(fromMaybe "unspecified" $ mfieldtemplate "currency") + ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency + ,"the parse error is: "++show err + ,"you may need to " + ++"change your amount, currency or default-currency rules, " + ++"or "++maybe "add a" (const "change your") mskip++" skip rule" + ] + -- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD". + -- Aim is to have "10 GBP @@ 15 USD" applied to account2, but have "-15USD" applied to account1 + amount1 = costOfMixedAmount amount + amount2 = (-amount) + s `or` def = if null s then def else s + defaccount1 = fromMaybe "unknown" $ mdirective "default-account1" + defaccount2 = case isNegativeMixedAmount amount2 of + Just True -> "income:unknown" + _ -> "expenses:unknown" + account1 = maybe "" render (mfieldtemplate "account1") `or` defaccount1 + account2 = maybe "" render (mfieldtemplate "account2") `or` defaccount2 -transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction -transactionFromCsvRecord rules fields = - let - date = parsedate $ normaliseDate (dateFormat rules) $ maybe "1900/1/1" (atDef "" fields) (dateField rules) - effectivedate = do idx <- effectiveDateField rules - return $ parsedate $ normaliseDate (dateFormat rules) $ (atDef "" fields) idx - status = maybe False (null . strip . (atDef "" fields)) (statusField rules) - code = maybe "" (atDef "" fields) (codeField rules) - desc = formatDescription fields (descriptionField rules) - comment = "" - precomment = "" - baseacc = maybe (baseAccount rules) (atDef "" fields) (accountField rules) - amountstr = getAmount rules fields - amountstr' = strnegate amountstr where strnegate ('-':s) = s - strnegate s = '-':s - currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules) - amountstr'' = currency ++ amountstr' - amountparse = runParser amountp nullctx "" amountstr'' - a = either (const nullmixedamt) mixed amountparse - -- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD". - -- Aim is to have "10 GBP @@ 15 USD" applied to account "acct", but have "-15USD" applied to "baseacct" - baseamount = costOfMixedAmount a - unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown" - | otherwise = "expenses:unknown" - (acct',newdesc) = identify (accountRules rules) unknownacct desc - acct = maybe acct' (atDef "" fields) (account2Field rules) - t = Transaction { - tdate=date, - teffectivedate=effectivedate, - tstatus=status, - tcode=code, - tdescription=newdesc, - tcomment=comment, - tpreceding_comment_lines=precomment, - ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount=acct, - pamount=a, - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Just t - }, - Posting { - pstatus=False, - paccount=baseacc, - pamount=(-baseamount), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Just t - } - ] - } - in t + -- build the transaction + t = nulltransaction{ + tdate = date', + tdate2 = mdate2', + tstatus = status, + tcode = code, + tdescription = description, + tcomment = comment, + tpreceding_comment_lines = precomment, + tpostings = + [posting {paccount=account2, pamount=amount2, ptransaction=Just t} + ,posting {paccount=account1, pamount=amount1, ptransaction=Just t} + ] + } --- | Convert some date string with unknown format to YYYY/MM/DD. -normaliseDate :: Maybe String -- ^ User-supplied date format: this should be tried in preference to all others - -> String -> String -normaliseDate mb_user_format s = - let parsewith = flip (parseTime defaultTimeLocale) s in - maybe (error' $ "could not parse \""++s++"\" as a date, consider adding a date-format directive or upgrading") - showDate $ - firstJust $ (map parsewith $ - maybe [] (:[]) mb_user_format - -- the - modifier requires time-1.2.0.5, released - -- in 2011/5, so for now we emulate it for wider - -- compatibility. time < 1.2.0.5 also has a buggy - -- %y which we don't do anything about. - -- ++ [ - -- "%Y/%m/%d" - -- ,"%Y/%-m/%-d" - -- ,"%Y-%m-%d" - -- ,"%Y-%-m-%-d" - -- ,"%m/%d/%Y" - -- ,"%-m/%-d/%Y" - -- ,"%m-%d-%Y" - -- ,"%-m-%-d-%Y" - -- ] - ) - ++ [ - parseTime defaultTimeLocale "%Y/%m/%e" s - ,parseTime defaultTimeLocale "%Y-%m-%e" s - ,parseTime defaultTimeLocale "%m/%e/%Y" s - ,parseTime defaultTimeLocale "%m-%e-%Y" s - ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s) - ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s) - ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s) - ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s) - ] +getAmountStr :: CsvRules -> CsvRecord -> String +getAmountStr rules record = + let + mamount = getEffectiveAssignment rules record "amount" + mamountin = getEffectiveAssignment rules record "amount-in" + mamountout = getEffectiveAssignment rules record "amount-out" + render = fmap (renderTemplate rules record) + in + case (render mamount, render mamountin, render mamountout) of + (Just "", Nothing, Nothing) -> error' $ "amount has no value\n"++showRecord record + (Just a, Nothing, Nothing) -> a + (Nothing, Just "", Just "") -> error' $ "neither amount-in or amount-out has a value\n"++showRecord record + (Nothing, Just i, Just "") -> i + (Nothing, Just "", Just o) -> negateStr o + (Nothing, Just _, Just _) -> error' $ "both amount-in and amount-out have a value\n"++showRecord record + _ -> error' $ "found values for amount and for amount-in/amount-out - please use either amount or amount-in/amount-out\n"++showRecord record --- | Apply account matching rules to a transaction description to obtain --- the most appropriate account and a new description. -identify :: [AccountRule] -> String -> String -> (String,String) -identify rules defacct desc | null matchingrules = (defacct,desc) - | otherwise = (acct,newdesc) - where - matchingrules = filter ismatch rules :: [AccountRule] - where ismatch = any ((`regexMatchesCI` desc) . fst) . fst - (prs,acct) = head matchingrules - p_ms_r = filter (\(_,m,_) -> m) $ map (\(p,r) -> (p, p `regexMatchesCI` desc, r)) prs - (p,_,r) = head p_ms_r - newdesc = case r of Just repl -> regexReplaceCI p repl desc - Nothing -> desc +negateIfParenthesised :: String -> String +negateIfParenthesised ('(':s) | lastMay s == Just ')' = negateStr $ init s +negateIfParenthesised s = s -getAmount :: CsvRules -> CsvRecord -> String -getAmount rules fields = case amountField rules of - Just f -> maybe "" (atDef "" fields) $ Just f - Nothing -> - case (i, o) of - (x, "") -> x - ("", x) -> "-"++x - p -> error' $ "using amount-in-field and amount-out-field, found a value in both fields: "++show p - where - i = maybe "" (atDef "" fields) (amountInField rules) - o = maybe "" (atDef "" fields) (amountOutField rules) +negateStr :: String -> String +negateStr ('-':s) = s +negateStr s = '-':s -tests_Hledger_Read_CsvReader = TestList (test_parser ++ test_description_parsing) +-- | Show a (approximate) recreation of the original CSV record. +showRecord :: CsvRecord -> String +showRecord r = "the CSV record is: "++intercalate ", " (map show r) -test_description_parsing = [ - "description-field 1" ~: assertParseDescription "description-field 1\n" [FormatField False Nothing Nothing (FieldNo 1)] - , "description-field 1 " ~: assertParseDescription "description-field 1 \n" [FormatField False Nothing Nothing (FieldNo 1)] - , "description-field %(1)" ~: assertParseDescription "description-field %(1)\n" [FormatField False Nothing Nothing (FieldNo 1)] - , "description-field %(1)/$(2)" ~: assertParseDescription "description-field %(1)/%(2)\n" [ - FormatField False Nothing Nothing (FieldNo 1) - , FormatLiteral "/" - , FormatField False Nothing Nothing (FieldNo 2) - ] - ] +-- | Given the conversion rules, a CSV record and a journal entry field name, find +-- the template value ultimately assigned to this field, either at top +-- level or in a matching conditional block. Conditional blocks' +-- patterns are matched against an approximation of the original CSV +-- record: all the field values with commas intercalated. +getEffectiveAssignment :: CsvRules -> CsvRecord -> JournalFieldName -> Maybe FieldTemplate +getEffectiveAssignment rules record f = lastMay $ assignmentsFor f where - assertParseDescription string expected = do assertParseEqual (parseDescription string) (nullrules {descriptionField = expected}) - parseDescription :: String -> Either ParseError CsvRules - parseDescription x = runParser descriptionfieldWrapper nullrules "(unknown)" x - descriptionfieldWrapper :: GenParser Char CsvRules CsvRules - descriptionfieldWrapper = do - descriptionfield - r <- getState - return r + assignmentsFor f = map snd $ toplevelassignments ++ conditionalassignments + where + toplevelassignments = filter ((==f).fst) $ rassignments rules + conditionalassignments = concatMap snd $ filter blockMatches $ blocksAssigning f + where + blocksAssigning f = filter (any ((==f).fst) . snd) $ rconditionalblocks rules + blockMatches :: ConditionalBlock -> Bool + blockMatches (matchers,_) = all matcherMatches matchers + where + matcherMatches :: RecordMatcher -> Bool + -- matcherMatches pats = any patternMatches pats + matcherMatches pats = patternMatches $ "(" ++ intercalate "|" pats ++ ")" + where + patternMatches :: Regexp -> Bool + patternMatches pat = regexMatchesCIRegexCompat pat csvline + where + csvline = intercalate "," record +renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String +renderTemplate rules record t = regexReplaceBy "%[A-z0-9]+" replace t + where + replace ('%':pat) = maybe pat (\i -> atDef "" record (i-1)) mi + where + mi | all isDigit pat = readMay pat + | otherwise = lookup pat $ rcsvfieldindexes rules + replace pat = pat + +-- Parse the date string using the specified date-format, or if unspecified try these default formats: +-- YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, MM/DD/YYYY (month and day can be 1 or 2 digits, year must be 4). +parseDateWithFormatOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day +parseDateWithFormatOrDefaultFormats mformat s = firstJust $ map parsewith formats + where + parsewith = flip (parseTime defaultTimeLocale) s + formats = maybe + ["%Y/%-m/%-d" + ,"%Y-%-m-%-d" + ,"%Y.%-m.%-d" + -- ,"%-m/%-d/%Y" + -- ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s) + -- ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s) + -- ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s) + -- ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s) + ] + (:[]) + mformat + +-------------------------------------------------------------------------------- +-- tests + +tests_Hledger_Read_CsvReader = TestList (test_parser) + -- ++ test_description_parsing) + +-- test_description_parsing = [ +-- "description-field 1" ~: assertParseDescription "description-field 1\n" [FormatField False Nothing Nothing (FieldNo 1)] +-- , "description-field 1 " ~: assertParseDescription "description-field 1 \n" [FormatField False Nothing Nothing (FieldNo 1)] +-- , "description-field %(1)" ~: assertParseDescription "description-field %(1)\n" [FormatField False Nothing Nothing (FieldNo 1)] +-- , "description-field %(1)/$(2)" ~: assertParseDescription "description-field %(1)/%(2)\n" [ +-- FormatField False Nothing Nothing (FieldNo 1) +-- , FormatLiteral "/" +-- , FormatField False Nothing Nothing (FieldNo 2) +-- ] +-- ] +-- where +-- assertParseDescription string expected = do assertParseEqual (parseDescription string) (rules {descriptionField = expected}) +-- parseDescription :: String -> Either ParseError CsvRules +-- parseDescription x = runParser descriptionfieldWrapper rules "(unknown)" x +-- descriptionfieldWrapper :: GenParser Char CsvRules CsvRules +-- descriptionfieldWrapper = do +-- descriptionfield +-- r <- getState +-- return r + test_parser = [ "convert rules parsing: empty file" ~: do -- let assertMixedAmountParse parseresult mixedamount = -- (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) - assertParseEqual (parseCsvRules "unknown" "") nullrules + assertParseEqual (parseCsvRules "unknown" "") rules - ,"convert rules parsing: accountrule" ~: do - assertParseEqual (parseWithCtx nullrules accountrule "A\na\n") -- leading blank line required - ([("A",Nothing)], "a") + -- ,"convert rules parsing: accountrule" ~: do + -- assertParseEqual (parseWithCtx rules accountrule "A\na\n") -- leading blank line required + -- ([("A",Nothing)], "a") ,"convert rules parsing: trailing comments" ~: do - assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#\n") + assertParse (parseWithCtx rules rulesp "skip\n# \n#\n") ,"convert rules parsing: trailing blank lines" ~: do - assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n \n") + assertParse (parseWithCtx rules rulesp "skip\n\n \n") -- not supported -- ,"convert rules parsing: no final newline" ~: do - -- assertParse (parseWithCtx nullrules csvrulesfile "A\na") - -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#") - -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n ") + -- assertParse (parseWithCtx rules csvrulesfile "A\na") + -- assertParse (parseWithCtx rules csvrulesfile "A\na\n# \n#") + -- assertParse (parseWithCtx rules csvrulesfile "A\na\n\n ") - -- (nullrules{ + -- (rules{ -- -- dateField=Maybe FieldPosition, -- -- statusField=Maybe FieldPosition, -- -- codeField=Maybe FieldPosition, diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards, NoMonoLocalBinds #-} +-- {-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-} {-| A reader for hledger's journal file format @@ -26,27 +27,34 @@ defaultyeardirective, historicalpricedirective, datetime, + code, accountname, amountp, amountp', mamountp', - emptyline, + emptyline +#ifdef TESTS -- * Tests - tests_Hledger_Read_JournalReader + -- disabled by default, HTF not available on windows + ,htf_thisModulesTests + ,htf_Hledger_Read_JournalReader_importedTests +#endif ) where import qualified Control.Exception as C import Control.Monad import Control.Monad.Error import Data.Char (isNumber) -import Data.Either (partitionEithers) import Data.List import Data.List.Split (wordsBy) import Data.Maybe import Data.Time.Calendar import Data.Time.LocalTime -import Safe (headDef) -import Test.HUnit +import Safe (headDef, lastDef) +#ifdef TESTS +import Test.Framework +import Text.Parsec.Error +#endif import Text.ParserCombinators.Parsec hiding (parse) import Text.Printf import System.FilePath @@ -55,7 +63,6 @@ import Hledger.Data import Hledger.Utils import Prelude hiding (readFile) -import Hledger.Utils.UTF8IOCompat (readFile) -- standard reader exports @@ -188,7 +195,7 @@ Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++)) Left err -> throwError $ inIncluded ++ show err where readFileOrError pos fp = - ErrorT $ liftM Right (readFile fp) `C.catch` + ErrorT $ liftM Right (readFile' fp) `C.catch` \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) journalAddFile :: (FilePath,String) -> Journal -> Journal @@ -311,41 +318,35 @@ -- | Parse a (possibly unbalanced) transaction. transaction :: GenParser Char JournalContext Transaction transaction = do + -- ptrace "transaction" date <- date "transaction" - edate <- optionMaybe (effectivedate date) "effective date" + edate <- optionMaybe (secondarydate date) "secondary date" status <- status "cleared flag" code <- code "transaction code" - -- now there can be whitespace followed by a description and/or comment/tag comment - let pdescription = many (noneOf ";\n") >>= return . strip - (description, inlinecomment, inlinetag) <- - try (do many1 spacenonewline - d <- pdescription - (c, m) <- inlinecomment - return (d,c,m)) - <|> (newline >> return ("", [], [])) - (nextlinecomments, nextlinetags) <- commentlines - let comment = unlines $ inlinecomment ++ nextlinecomments - tags = inlinetag ++ nextlinetags + description <- descriptionp >>= return . strip + comment <- try followingcomment <|> (newline >> return "") + let tags = tagsInComment comment postings <- postings return $ txnTieKnot $ Transaction date edate status code description comment tags postings "" -tests_transaction = [ - "transaction" ~: do - -- let s `gives` t = assertParseEqual (parseWithCtx nullctx transaction s) t +descriptionp = many (noneOf ";\n") + +#ifdef TESTS +test_transaction = do let s `gives` t = do let p = parseWithCtx nullctx transaction s - assertBool "transaction parser failed" $ isRight p + assertBool $ isRight p let Right t2 = p - same f = assertEqual "" (f t) (f t2) - same tdate - same teffectivedate - same tstatus - same tcode - same tdescription - same tcomment - same ttags - same tpreceding_comment_lines - same tpostings + -- same f = assertEqual (f t) (f t2) + assertEqual (tdate t) (tdate t2) + assertEqual (tdate2 t) (tdate2 t2) + assertEqual (tstatus t) (tstatus t2) + assertEqual (tcode t) (tcode t2) + assertEqual (tdescription t) (tdescription t2) + assertEqual (tcomment t) (tcomment t2) + assertEqual (ttags t) (ttags t2) + assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2) + assertEqual (show $ tpostings t) (show $ tpostings t2) -- "0000/01/01\n\n" `gives` nulltransaction unlines [ "2012/05/14=2012/05/15 (code) desc ; tcomment1", @@ -359,18 +360,18 @@ `gives` nulltransaction{ tdate=parsedate "2012/05/14", - teffectivedate=Just $ parsedate "2012/05/15", + tdate2=Just $ parsedate "2012/05/15", tstatus=False, tcode="code", tdescription="desc", - tcomment="tcomment1\ntcomment2\n", + tcomment=" tcomment1\n tcomment2\n ttag1: val1\n", ttags=[("ttag1","val1")], tpostings=[ nullposting{ pstatus=True, paccount="a", pamount=Mixed [usd 1], - pcomment="pcomment1\npcomment2\n", + pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")], ptransaction=Nothing @@ -379,22 +380,42 @@ tpreceding_comment_lines="" } - assertParseEqual (parseWithCtx nullctx transaction entry1_str) entry1 - assertBool "transaction should not parse just a date" - $ isLeft $ parseWithCtx nullctx transaction "2009/1/1\n" - assertBool "transaction should require some postings" - $ isLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n" - let t = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n" - assertBool "transaction should not include a comment in the description" - $ either (const False) ((== "a") . tdescription) t - assertBool "parse transaction with following whitespace line" $ - isRight $ parseWithCtx nullctx transaction $ unlines [ - "2012/1/1" + assertRight $ parseWithCtx nullctx transaction $ unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ] + + -- transaction should not parse just a date + assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n" + + -- transaction should not parse just a date and description + assertLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n" + + -- transaction should not parse a following comment as part of the description + let p = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n" + assertRight p + assertEqual "a" (let Right p' = p in tdescription p') + + -- parse transaction with following whitespace line + assertRight $ parseWithCtx nullctx transaction $ unlines + ["2012/1/1" ," a 1" ," b" ," " ] - ] + + let p = parseWithCtx nullctx transaction $ unlines + ["2009/1/1 x ; transaction comment" + ," a 1 ; posting 1 comment" + ," ; posting 1 comment 2" + ," b" + ," ; posting 2 comment" + ] + assertRight p + assertEqual 2 (let Right t = p in length $ tpostings t) +#endif -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year -- may be omitted if a default year has already been set. @@ -449,28 +470,28 @@ -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -effectivedate :: Day -> GenParser Char JournalContext Day -effectivedate actualdate = do +secondarydate :: Day -> GenParser Char JournalContext Day +secondarydate primarydate = do char '=' - -- kludgy way to use actual date for default year + -- kludgy way to use primary date for default year let withDefaultYear d p = do y <- getYear let (y',_,_) = toGregorian d in setYear y' r <- p when (isJust y) $ setYear $ fromJust y return r - edate <- withDefaultYear actualdate date + edate <- withDefaultYear primarydate date return edate status :: GenParser Char JournalContext Bool -status = try (do { many spacenonewline; char '*' "status"; return True } ) <|> return False +status = try (do { many spacenonewline; (char '*' <|> char '!') "status"; return True } ) <|> return False code :: GenParser Char JournalContext String code = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. postings :: GenParser Char JournalContext [Posting] -postings = many1 (try posting) "postings" +postings = many1 (try postingp) "postings" -- linebeginningwithspaces :: GenParser Char JournalContext String -- linebeginningwithspaces = do @@ -479,8 +500,8 @@ -- cs <- restofline -- return $ sp ++ (c:cs) ++ "\n" -posting :: GenParser Char JournalContext Posting -posting = do +postingp :: GenParser Char JournalContext Posting +postingp = do many1 spacenonewline status <- status many spacenonewline @@ -490,20 +511,23 @@ _ <- balanceassertion _ <- fixedlotprice many spacenonewline - (inlinecomment, inlinetag) <- inlinecomment - (nextlinecomments, nextlinetags) <- commentlines - let comment = unlines $ inlinecomment ++ nextlinecomments - tags = inlinetag ++ nextlinetags - return (Posting status account' amount comment ptype tags Nothing) + ctx <- getState + comment <- try followingcomment <|> (newline >> return "") + let tags = tagsInComment comment + -- oh boy + d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` dateValueFromTags tags) + d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` date2ValueFromTags tags) + return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags} -tests_posting = [ - "posting" ~: do - -- let s `gives` r = assertParseEqual (parseWithCtx nullctx posting s) r - let s `gives` p = do - let parse = parseWithCtx nullctx posting s - assertBool "posting parser" $ isRight parse - let Right p2 = parse - same f = assertEqual "" (f p) (f p2) +#ifdef TESTS +test_postingp = do + let s `gives` ep = do + let parse = parseWithCtx nullctx postingp s + assertBool -- "postingp parser" + $ isRight parse + let Right ap = parse + same f = assertEqual (f ep) (f ap) + same pdate same pstatus same paccount same pamount @@ -511,17 +535,35 @@ same ptype same ptags same ptransaction - " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" - `gives` - (Posting False "expenses:food:dining" (Mixed [usd 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing) + " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" `gives` + posting{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]} - assertBool "posting parses a quoted commodity with numbers" - (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n") + " a 1 ; [2012/11/28]\n" `gives` + ("a" `post` num 1){pcomment=" [2012/11/28]\n" + ,ptags=[("date","2012/11/28")] + ,pdate=parsedateM "2012/11/28"} - ,"posting parses balance assertions and fixed lot prices" ~: do - assertBool "" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\" =$1 { =2.2 EUR} \n") - ] + " a 1 ; a:a, [=2012/11/28]\n" `gives` + ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n" + ,ptags=[("a","a"), ("date2","2012/11/28")] + ,pdate=Nothing} + " a 1 ; a:a\n ; [2012/11/28=2012/11/29],b:b\n" `gives` + ("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n" + ,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")] + ,pdate=parsedateM "2012/11/28"} + + assertBool -- "postingp parses a quoted commodity with numbers" + (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\"\n") + + -- ,"postingp parses balance assertions and fixed lot prices" ~: do + assertBool (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\" =$1 { =2.2 EUR} \n") + + let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n" + assertRight parse + assertEqual "next-line comment\n" (let Right p = parse in pcomment p) +#endif + -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. modifiedaccountname :: GenParser Char JournalContext AccountName modifiedaccountname = do @@ -560,33 +602,39 @@ (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt ) <|> return missingmixedamt -tests_spaceandamountormissing = [ - "spaceandamountormissing" ~: do - assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18]) - assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt - assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt - assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt - ] +#ifdef TESTS +assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion +assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse +is' :: (Eq a, Show a) => a -> a -> Assertion +a `is'` e = assertEqual e a + +test_spaceandamountormissing = do + assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18]) + assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt + assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt + assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt +#endif + -- | Parse a single-commodity amount, with optional symbol on the left or -- right, optional unit or total price, and optional (ignored) -- ledger-style balance assertion or fixed lot price declaration. amountp :: GenParser Char JournalContext Amount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount -tests_amountp = [ - "amountp" ~: do - assertParseEqual (parseWithCtx nullctx amountp "$47.18") (usd 47.18) - assertParseEqual (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0) - ,"amount with unit price" ~: do - assertParseEqual +#ifdef TESTS +test_amountp = do + assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18) + assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0) + -- ,"amount with unit price" ~: do + assertParseEqual' (parseWithCtx nullctx amountp "$10 @ €0.5") (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) - ,"amount with total price" ~: do - assertParseEqual + -- ,"amount with total price" ~: do + assertParseEqual' (parseWithCtx nullctx amountp "$10 @@ €5") (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)) - ] +#endif -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount @@ -732,10 +780,10 @@ return (quantity,precision,decimalpoint,separator,separatorpositions) "number" -tests_number = [ - "number" ~: do - let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n - assertFails = assertBool "" . isLeft . parseWithCtx nullctx number +#ifdef TESTS +test_number = do + let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n + assertFails = assertBool . isLeft . parseWithCtx nullctx number assertFails "" "0" `is` (0, 0, '.', ',', []) "1" `is` (1, 0, '.', ',', []) @@ -754,9 +802,9 @@ assertFails "1..1" assertFails ".1," assertFails ",1." - ] +#endif --- older comment parsers +-- comment parsers emptyline :: GenParser Char JournalContext () emptyline = do many spacenonewline @@ -764,87 +812,97 @@ newline return () -comment :: GenParser Char JournalContext String -comment = do - many1 $ char ';' - many spacenonewline - c <- many (noneOf "\n") - return $ rstrip c - "comment" +followingcomment :: GenParser Char JournalContext String +followingcomment = + -- ptrace "followingcomment" + (do first <- many spacenonewline >> followingcommentline + rest <- many (try (many1 spacenonewline >> followingcommentline)) + return $ unlines $ first:rest + ) <|> + do + many spacenonewline >> newline + rest <- many (try (many1 spacenonewline >> followingcommentline)) + return $ unlines rest -commentline :: GenParser Char JournalContext String -commentline = do - many spacenonewline - c <- comment +followingcommentline :: GenParser Char JournalContext String +followingcommentline = do + -- ptrace "followingcommentline" + char ';' + l <- anyChar `manyTill` eolof optional newline - eof - return c - "comment" + return l --- newer comment parsers +tagsInComment :: String -> [Tag] +tagsInComment c = concatMap tagsInCommentLine $ lines c' + where + c' = ledgerDateSyntaxToTags c + +tagsInCommentLine :: String -> [Tag] +tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ',' + where + maybetag s = case parseWithCtx nullctx tag s of + Right t -> Just t + Left _ -> Nothing -inlinecomment :: GenParser Char JournalContext ([String],[Tag]) -inlinecomment = try (do {tag <- tagcomment; newline; return ([], [tag])}) - <|> (do {c <- comment; newline; return ([rstrip c], [])}) - <|> (newline >> return ([], [])) +tag = do + -- ptrace "tag" + n <- tagname + v <- tagvalue + return (n,v) -tests_inlinecomment = [ - "inlinecomment" ~: do - let s `gives` r = assertParseEqual (parseWithCtx nullctx inlinecomment s) r - "; comment \n" `gives` (["comment"],[]) - ";tag: a value \n" `gives` ([],[("tag","a value")]) - ] +tagname = do + -- ptrace "tagname" + n <- many1 $ noneOf ": \t" + char ':' + return n -commentlines :: GenParser Char JournalContext ([String],[Tag]) -commentlines = do - comortags <- many $ choice' [(liftM Right tagline) - ,(do {many1 spacenonewline; c <- comment; newline; return $ Left c }) -- XXX fix commentnewline - ] - return $ partitionEithers comortags +tagvalue = do + -- ptrace "tagvalue" + v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof) + return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v -tests_commentlines = [ - "commentlines" ~: do - let s `gives` r = assertParseEqual (parseWithCtx nullctx commentlines s) r - " ; comment 1 \n ; tag1: val1 \n ;comment 2\n;unindented comment\n" - `gives` (["comment 1","comment 2"],[("tag1","val1")]) - ] +ledgerDateSyntaxToTags :: String -> String +ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace + where + replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s + replace s = s --- a comment line containing a tag declaration, eg: --- ; name: value -tagline :: GenParser Char JournalContext Tag -tagline = do - many1 spacenonewline - tag <- tagcomment - newline - return tag + replace' s | isdate s = datetag s + replace' ('=':s) | isdate s = date2tag s + replace' s | last s =='=' && isdate (init s) = datetag (init s) + replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2 + where + ds = splitAtElement '=' s + d1 = headDef "" ds + d2 = lastDef "" ds + replace' s = s --- a comment containing a tag, like "; name: some value" -tagcomment :: GenParser Char JournalContext Tag -tagcomment = do - many1 $ char ';' - many spacenonewline - name <- many1 $ noneOf ": \t" - char ':' - many spacenonewline - value <- many (noneOf "\n") - return (name, rstrip value) - "tag comment" + isdate = isJust . parsedateM + datetag s = "date:"++s++", " + date2tag s = "date2:"++s++", " + +#ifdef TESTS +test_ledgerDateSyntaxToTags = do + assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]" +#endif + +dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String +dateValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts +date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts -tests_tagcomment = [ - "tagcomment" ~: do - let s `gives` r = assertParseEqual (parseWithCtx nullctx tagcomment s) r - ";tag: a value \n" `gives` ("tag","a value") - ] + +{- old hunit tests -tests_Hledger_Read_JournalReader = TestList $ concat [ - tests_number, - tests_amountp, - tests_spaceandamountormissing, - tests_tagcomment, - tests_inlinecomment, - tests_commentlines, - tests_posting, - tests_transaction, +test_Hledger_Read_JournalReader = TestList $ concat [ + test_number, + test_amountp, + test_spaceandamountormissing, + test_tagcomment, + test_inlinecomment, + test_commentlines, + test_ledgerDateSyntaxToTags, + test_postingp, + test_transaction, [ "modifiertransaction" ~: do assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings 1\n") @@ -925,16 +983,5 @@ (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0)) ]] - -entry1_str = unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking $-47.18" - ,"" - ] - -entry1 = - txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] - [Posting False "expenses:food:groceries" (Mixed [usd 47.18]) "" RegularPosting [] Nothing, - Posting False "assets:checking" (Mixed [usd (-47.18)]) "" RegularPosting [] Nothing] "" +-} diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -18,7 +18,6 @@ intervalFromOpts, clearedValueFromOpts, whichDateFromOpts, - journalSelectingDateFromOpts, journalSelectingAmountFromOpts, queryFromOpts, queryOptsFromOpts, @@ -42,6 +41,8 @@ AccountsReport, AccountsReportItem, accountsReport, + -- * Other "reports" + accountBalanceHistory, -- * Tests tests_Hledger_Reports ) @@ -77,7 +78,7 @@ ,cost_ :: Bool ,depth_ :: Maybe Int ,display_ :: Maybe DisplayExp - ,effective_ :: Bool + ,date2_ :: Bool ,empty_ :: Bool ,no_elide_ :: Bool ,real_ :: Bool @@ -90,6 +91,7 @@ ,quarterly_ :: Bool ,yearly_ :: Bool ,format_ :: Maybe FormatStr + ,related_ :: Bool ,query_ :: String -- all arguments, as a string } deriving (Show) @@ -119,6 +121,7 @@ def def def + def instance Default ReportOpts where def = defreportopts @@ -153,19 +156,19 @@ -- depthFromOpts :: ReportOpts -> Int -- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) --- | Report which date we will report on based on --effective. +-- | Report which date we will report on based on --date2. whichDateFromOpts :: ReportOpts -> WhichDate -whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate +whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate --- | Select a Transaction date accessor based on --effective. +-- | Select the Transaction date accessor based on --date2. transactionDateFn :: ReportOpts -> (Transaction -> Day) -transactionDateFn ReportOpts{..} = if effective_ then transactionEffectiveDate else transactionActualDate +transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate --- | Convert this journal's transactions' primary date to either the --- actual or effective date, as per options. -journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal -journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts) +-- | Select the Posting date accessor based on --date2. +postingDateFn :: ReportOpts -> (Posting -> Day) +postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate + -- | Convert this journal's postings' amounts to the cost basis amounts if -- specified by options. journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal @@ -178,7 +181,7 @@ queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq] where flagsq = And $ - [Date $ dateSpanFromOpts d opts] + [(if date2_ then Date2 else Date) $ dateSpanFromOpts d opts] ++ (if real_ then [Real True] else []) ++ (if empty_ then [Empty True] else []) -- ? ++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts)) @@ -194,7 +197,7 @@ (queryFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01") ,query_="date:'to 2013'" }) - assertEqual "" (EDate $ mkdatespan "2012/01/01" "2013/01/01") + assertEqual "" (Date2 $ mkdatespan "2012/01/01" "2013/01/01") (queryFromOpts nulldate defreportopts{query_="edate:'in 2012'"}) assertEqual "" (Or [Acct "a a", Acct "'b"]) (queryFromOpts nulldate defreportopts{query_="'a a' 'b"}) @@ -246,28 +249,31 @@ type PostingsReport = (String -- label for the running balance column XXX remove ,[PostingsReportItem] -- line items, one per posting ) -type PostingsReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting - ,Posting -- the posting, possibly with account name depth-clipped - ,MixedAmount -- the running total after this posting +type PostingsReportItem = (Maybe Day -- posting date, if this is the first posting in a transaction or if it's different from the previous posting's date + ,Maybe String -- transaction description, if this is the first posting in a transaction + ,Posting -- the posting, possibly with account name depth-clipped + ,MixedAmount -- the running total after this posting ) -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command. postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport postingsReport opts q j = -- trace ("q: "++show q++"\nq': "++show q') $ - (totallabel, postingsReportItems ps nullposting depth startbal (+)) + (totallabel, postingsReportItems ps nullposting wd depth startbal (+)) where ps | interval == NoInterval = displayableps | otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps - j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j - -- don't do depth filtering until the end + j' = journalSelectingAmountFromOpts opts j + wd = whichDateFromOpts opts + -- delay depth filtering until the end (depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q) - (precedingps, displayableps, _) = dbg "ps3" $ postingsMatchingDisplayExpr (display_ opts) + (precedingps, displayableps, _) = dbg "ps4" $ postingsMatchingDisplayExpr displayexpr opts + $ dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id) $ dbg "ps2" $ filter (q' `matchesPosting`) $ dbg "ps1" $ journalPostings j' dbg :: Show a => String -> a -> a - -- dbg = ltrace dbg = flip const + -- dbg = lstrace empty = queryEmpty q displayexpr = display_ opts -- XXX @@ -277,10 +283,10 @@ -- with period options and any span specified with display option. -- The latter is not easily available, fake it for now. requestedspan = periodspan `spanIntersect` displayspan - periodspan = queryDateSpan effectivedate q - effectivedate = whichDateFromOpts opts == EffectiveDate + periodspan = queryDateSpan secondarydate q + secondarydate = whichDateFromOpts opts == SecondaryDate displayspan = postingsDateSpan ps - where (_,ps,_) = postingsMatchingDisplayExpr displayexpr $ journalPostings j' + where (_,ps,_) = postingsMatchingDisplayExpr displayexpr opts $ journalPostings j' matchedspan = postingsDateSpan displayableps reportspan | empty = requestedspan `orDatesFrom` journalspan | otherwise = requestedspan `spanIntersect` matchedspan @@ -290,30 +296,36 @@ balancelabel = "Balance" -- | Generate postings report line items. -postingsReportItems :: [Posting] -> Posting -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] -postingsReportItems [] _ _ _ _ = [] -postingsReportItems (p:ps) pprev d b sumfn = i:(postingsReportItems ps p d b' sumfn) +postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] +postingsReportItems [] _ _ _ _ _ = [] +postingsReportItems (p:ps) pprev wd d b sumfn = i:(postingsReportItems ps p wd d b' sumfn) where - i = mkpostingsReportItem isfirst p' b' + i = mkpostingsReportItem showdate showdesc wd p' b' + showdate = isfirstintxn || isdifferentdate + showdesc = isfirstintxn + isfirstintxn = ptransaction p /= ptransaction pprev + isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev + SecondaryDate -> postingDate2 p /= postingDate2 pprev p' = p{paccount=clipAccountName d $ paccount p} - isfirst = ptransaction p /= ptransaction pprev b' = b `sumfn` pamount p --- | Generate one postings report line item, given a flag indicating --- whether to include transaction info, the posting, and the current --- running balance. -mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem -mkpostingsReportItem False p b = (Nothing, p, b) -mkpostingsReportItem True p b = (ds, p, b) - where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de) - Nothing -> Just (nulldate,"") +-- | Generate one postings report line item, containing the posting, +-- the current running balance, and optionally the posting date and/or +-- the transaction description. +mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem +mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b) + where + date = case wd of PrimaryDate -> postingDate p + SecondaryDate -> postingDate2 p + desc = maybe "" tdescription $ ptransaction p -- | Date-sort and split a list of postings into three spans - postings matched -- by the given display expression, and the preceding and following postings. -postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting]) -postingsMatchingDisplayExpr d ps = (before, matched, after) +-- XXX always sorts by primary date, should sort by secondary date if expression is about that +postingsMatchingDisplayExpr :: Maybe String -> ReportOpts -> [Posting] -> ([Posting],[Posting],[Posting]) +postingsMatchingDisplayExpr d opts ps = (before, matched, after) where - sorted = sortBy (comparing postingDate) ps + sorted = sortBy (comparing (postingDateFn opts)) ps (before, rest) = break (displayExprMatches d) sorted (matched, after) = span (displayExprMatches d) rest @@ -459,11 +471,11 @@ where -- transactions affecting this account, in date order ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ - journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + journalSelectingAmountFromOpts opts j -- starting balance: if we are filtering by a start date and nothing else, -- the sum of postings to this account before that date; otherwise zero. (startbal,label) | queryIsNull m = (nullmixedamt, balancelabel) - | queryIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel) + | queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel) | otherwise = (nullmixedamt, totallabel) where priorps = -- ltrace "priorps" $ @@ -472,7 +484,7 @@ And [thisacctquery, tostartdatequery])) $ transactionsPostings ts tostartdatequery = Date (DateSpan Nothing startdate) - startdate = queryStartDate (effective_ opts) m + startdate = queryStartDate (date2_ opts) m items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts -- | Generate transactions report items from a list of transactions, @@ -531,7 +543,7 @@ ) type AccountsReportItem = (AccountName -- full account name ,AccountName -- short account name for display (the leaf name, prefixed by any boring parents immediately above) - ,Int -- how many steps to indent this account (0-based account depth excluding boring parents) + ,Int -- how many steps to indent this account (0 with --flat, otherwise the 0-based account depth excluding boring parents) ,MixedAmount) -- account balance, includes subs unless --flat is present -- | Select accounts, and get their balances at the end of the selected @@ -539,7 +551,7 @@ accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport accountsReport opts q j = (items, total) where - l = ledgerFromJournal q $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + l = ledgerFromJournal q $ journalSelectingAmountFromOpts opts j accts = clipAccounts (queryDepth q) $ ledgerRootAccount l accts' | flat_ opts = filterzeros $ tail $ flattenAccounts accts @@ -552,7 +564,7 @@ markboring | no_elide_ opts = id | otherwise = markBoringParentAccounts items = map (accountsReportItem opts) accts' - total = sum [amt | (_,_,depth,amt) <- items, depth==0] + total = sum [amt | (a,_,indent,amt) <- items, if flat_ opts then accountNameLevel a == 1 else indent == 0] -- | In an account tree with zero-balance leaves removed, mark the -- elidable parent accounts (those with one subaccount and no balance @@ -565,16 +577,30 @@ accountsReportItem :: ReportOpts -> Account -> AccountsReportItem accountsReportItem opts a@Account{aname=name, aibalance=ibal} - | flat_ opts = (name, name, 0, ibal) - | otherwise = (name, elidedname, depth, ibal) + | flat_ opts = (name, name, 0, ibal) + | otherwise = (name, elidedname, indent, ibal) where elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents - depth = length $ filter (not.aboring) parents + indent = length $ filter (not.aboring) parents parents = init $ parentAccounts a ------------------------------------------------------------------------------- + +-- | Get the historical running inclusive balance of a particular account, +-- from earliest to latest posting date. +-- XXX Accounts should know the Ledger & Journal they came from +accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)] +accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items] + where + (_,items) = journalTransactionsReport ropts j acctquery + inclusivebal = True + acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a + getdate = if date2_ ropts then transactionDate2 else tdate + + +------------------------------------------------------------------------------- -- TESTS tests_postingsReport = [ @@ -792,7 +818,7 @@ ], Mixed [nullamt]) - ,"accountsReport with a date or effective date span" ~: do + ,"accountsReport with a date or secondary date span" ~: do (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` ([], Mixed [nullamt]) @@ -949,32 +975,16 @@ {jtxns = [ txnTieKnot $ Transaction { tdate=parsedate "2008/01/01", - teffectivedate=Just $ parsedate "2009/01/01", + tdate2=Just $ parsedate "2009/01/01", tstatus=False, tcode="", tdescription="income", tcomment="", ttags=[], - tpostings=[ - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [usd 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="income:salary", - pamount=(missingmixedamt), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ], + tpostings= + [posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]} + ,posting {paccount="income:salary", pamount=missingmixedamt} + ], tpreceding_comment_lines="" } ] diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -22,11 +22,12 @@ module Hledger.Utils, Debug.Trace.trace, -- module Hledger.Utils.UTF8IOCompat - SystemString,fromSystemString,toSystemString,error',userError' + SystemString,fromSystemString,toSystemString,error',userError', + ppShow -- the rest need to be done in each module I think ) where -import Control.Monad (liftM) +import Control.Monad (liftM, when) import Control.Monad.Error (MonadIO) import Control.Monad.IO.Class (liftIO) import Data.Char @@ -39,10 +40,13 @@ import Debug.Trace import System.Directory (getHomeDirectory) import System.FilePath((), isRelative) +import System.IO import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf +import Text.Regex import Text.RegexPR +import Text.Show.Pretty -- import qualified Data.Map as Map -- -- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) @@ -58,6 +62,8 @@ lstrip = dropWhile (`elem` " \t") :: String -> String rstrip = reverse . lstrip . reverse +stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String + elideLeft width s = if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s @@ -85,9 +91,10 @@ escapeQuotes = regexReplace "([\"'])" "\\1" -- | Quote-aware version of words - don't split on spaces which are inside quotes. --- NB correctly handles "a'b" but not "''a''". +-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. words' :: String -> [String] -words' = map stripquotes . fromparse . parsewith p +words' "" = [] +words' s = map stripquotes $ fromparse $ parsewith p s where p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline -- eof @@ -199,6 +206,7 @@ difforzero a b = maximum [(a - b), 0] -- regexps +-- Note many of these will die on malformed regexps. -- regexMatch :: String -> String -> MatchFun Maybe regexMatch r s = matchRegexPR r s @@ -226,6 +234,16 @@ regexToCaseInsensitive :: String -> String regexToCaseInsensitive r = "(?i)"++ r +regexSplit :: String -> String -> [String] +regexSplit = splitRegexPR + +-- regex-compat (regex-posix) functions that perform better than regexpr. +regexMatchesRegexCompat :: String -> String -> Bool +regexMatchesRegexCompat r = isJust . matchRegex (mkRegex r) + +regexMatchesCIRegexCompat :: String -> String -> Bool +regexMatchesCIRegexCompat r = isJust . matchRegex (mkRegexWithOpts r True False) + -- lists splitAtElement :: Eq a => a -> [a] -> [[a]] @@ -338,6 +356,31 @@ tracewith :: (a -> String) -> a -> a tracewith f e = trace (f e) e +-- | Parsec trace - show the current parsec position and next input, +-- and the provided string if it's non-null. +ptrace :: String -> GenParser Char st () +ptrace msg = do + pos <- getPosition + next <- take peeklength `fmap` getInput + let (l,c) = (sourceLine pos, sourceColumn pos) + s = printf "at line %2d col %2d: %s" l c (show next) :: String + s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg + trace s' $ return () + where + peeklength = 30 + +debugLevel = 0 + +-- | Print a message to the console if the global debugLevel is +-- greater than the level we are called with. +dbg :: Monad m => Float -> String -> m () +dbg level msg = when (level <= debugLevel) $ trace msg $ return () + +-- | Print a message and parsec position info to the console if the +-- global debugLevel is greater than the level we are called with. +-- pdbg :: GenParser m => Float -> String -> m () +pdbg level msg = when (level <= debugLevel) $ ptrace msg + -- parsing -- | Backtracking choice, use this when alternatives share a prefix. @@ -372,6 +415,9 @@ restofline :: GenParser Char st String restofline = anyChar `manyTill` newline +eolof :: GenParser Char st () +eolof = (newline >> return ()) <|> eof + -- time getCurrentLocalTime :: IO LocalTime @@ -446,3 +492,9 @@ [] -> Nothing (md:_) -> md +-- | Read a file in universal newline mode, handling whatever newline convention it may contain. +readFile' :: FilePath -> IO String +readFile' name = do + h <- openFile name ReadMode + hSetNewlineMode h universalNewlineMode + hGetContents h diff --git a/Hledger/Utils/UTF8IOCompat.hs b/Hledger/Utils/UTF8IOCompat.hs --- a/Hledger/Utils/UTF8IOCompat.hs +++ b/Hledger/Utils/UTF8IOCompat.hs @@ -11,6 +11,10 @@ import UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') +2013/4/10 update: we now trust that current GHC versions & platforms +do the right thing, so this file is a no-op and on its way to being removed. +Not carefully tested. + -} module Hledger.Utils.UTF8IOCompat ( @@ -32,56 +36,56 @@ ) where -import Control.Monad (liftM) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.Char8 as B8 -import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString) +-- import Control.Monad (liftM) +-- import qualified Data.ByteString.Lazy as B +-- import qualified Data.ByteString.Lazy.Char8 as B8 +-- import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString) import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn) -import System.IO (Handle) -#if __GLASGOW_HASKELL__ < 702 -import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) -import System.Info (os) -#endif +import System.IO -- (Handle) +-- #if __GLASGOW_HASKELL__ < 702 +-- import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) +-- import System.Info (os) +-- #endif -bom :: B.ByteString -bom = B.pack [0xEF, 0xBB, 0xBF] +-- bom :: B.ByteString +-- bom = B.pack [0xEF, 0xBB, 0xBF] -stripBOM :: B.ByteString -> B.ByteString -stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s -stripBOM s = s +-- stripBOM :: B.ByteString -> B.ByteString +-- stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s +-- stripBOM s = s -readFile :: FilePath -> IO String -readFile = liftM (U8.toString . stripBOM) . B.readFile +-- readFile :: FilePath -> IO String +-- readFile = liftM (U8.toString . stripBOM) . B.readFile -writeFile :: FilePath -> String -> IO () -writeFile f = B.writeFile f . U8.fromString +-- writeFile :: FilePath -> String -> IO () +-- writeFile f = B.writeFile f . U8.fromString -appendFile :: FilePath -> String -> IO () -appendFile f = B.appendFile f . U8.fromString +-- appendFile :: FilePath -> String -> IO () +-- appendFile f = B.appendFile f . U8.fromString -getContents :: IO String -getContents = liftM (U8.toString . stripBOM) B.getContents +-- getContents :: IO String +-- getContents = liftM (U8.toString . stripBOM) B.getContents -hGetContents :: Handle -> IO String -hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h) +-- hGetContents :: Handle -> IO String +-- hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h) -putStr :: String -> IO () -putStr = bs_putStr . U8.fromString +-- putStr :: String -> IO () +-- putStr = bs_putStr . U8.fromString -putStrLn :: String -> IO () -putStrLn = bs_putStrLn . U8.fromString +-- putStrLn :: String -> IO () +-- putStrLn = bs_putStrLn . U8.fromString -hPutStr :: Handle -> String -> IO () -hPutStr h = bs_hPutStr h . U8.fromString +-- hPutStr :: Handle -> String -> IO () +-- hPutStr h = bs_hPutStr h . U8.fromString -hPutStrLn :: Handle -> String -> IO () -hPutStrLn h = bs_hPutStrLn h . U8.fromString +-- hPutStrLn :: Handle -> String -> IO () +-- hPutStrLn h = bs_hPutStrLn h . U8.fromString --- span GHC versions including 6.12.3 - 7.4.1: -bs_putStr = B8.putStr -bs_putStrLn = B8.putStrLn -bs_hPutStr = B8.hPut -bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a) +-- -- span GHC versions including 6.12.3 - 7.4.1: +-- bs_putStr = B8.putStr +-- bs_putStrLn = B8.putStrLn +-- bs_hPutStr = B8.hPut +-- bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a) -- | A string received from or being passed to the operating system, such @@ -94,24 +98,24 @@ -- | Convert a system string to an ordinary string, decoding from UTF-8 if -- it appears to be UTF8-encoded and GHC version is less than 7.2. fromSystemString :: SystemString -> String -#if __GLASGOW_HASKELL__ < 702 -fromSystemString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s -#else +-- #if __GLASGOW_HASKELL__ < 702 +-- fromSystemString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s +-- #else fromSystemString = id -#endif +-- #endif -- | Convert a unicode string to a system string, encoding with UTF-8 if -- we are on a posix platform with GHC < 7.2. toSystemString :: String -> SystemString -#if __GLASGOW_HASKELL__ < 702 -toSystemString = case os of - "unix" -> UTF8.encodeString - "linux" -> UTF8.encodeString - "darwin" -> UTF8.encodeString - _ -> id -#else +-- #if __GLASGOW_HASKELL__ < 702 +-- toSystemString = case os of +-- "unix" -> UTF8.encodeString +-- "linux" -> UTF8.encodeString +-- "darwin" -> UTF8.encodeString +-- _ -> id +-- #else toSystemString = id -#endif +-- #endif -- | A SystemString-aware version of error. error' :: String -> a diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.19.3 +version: 0.20 category: Finance synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: @@ -17,7 +17,7 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta -tested-with: GHC==7.0.4, GHC==7.2.2, GHC==7.4.1, GHC==7.6.1 +tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.1 cabal-version: >= 1.8 build-type: Simple -- data-dir: data @@ -66,6 +66,8 @@ ,old-locale ,old-time ,parsec + ,pretty-show + ,regex-compat == 0.95.* ,regexpr >= 0.5.1 ,safe >= 0.2 ,split >= 0.1 && < 0.3