hledger-lib 0.19.3 → 0.20

raw patch · 14 files changed

+1215/−1043 lines, 14 filesdep +pretty-showdep +regex-compatPVP ok

version bump matches the API change (PVP)

Dependencies added: pretty-show, regex-compat

API changes (from Hackage documentation)

Files

• Hledger/Data/Dates.hs +1/−0
• Hledger/Data/Journal.hs +25/−123
• Hledger/Data/Posting.hs +47/−29
• Hledger/Data/TimeLog.hs +4/−3
• Hledger/Data/Transaction.hs +76/−83
• Hledger/Data/Types.hs +7/−39
• Hledger/Query.hs +63/−30
• Hledger/Read.hs +9/−4
• Hledger/Read/CsvReader.hs +561/−425
• Hledger/Read/JournalReader.hs +229/−182
• Hledger/Reports.hs +80/−70
• Hledger/Utils.hs +56/−4
• Hledger/Utils/UTF8IOCompat.hs +53/−49
• hledger-lib.cabal +4/−2

@@ -28,6 +28,7 @@   getCurrentYear,   nulldate,   spanContainsDate,+  parsedateM,   parsedate,   showDate,   elapsedSeconds,

@@ -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=""            }           ]

@@ -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)"   ]-+ 

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

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

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

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

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

@@ -1,25 +1,7 @@+{-# LANGUAGE ScopedTypeVariables #-} {-| -A reader for the CSV data format. Uses an extra rules file-(<http://hledger.org/MANUAL.html#rules-file-directives>) 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,

@@ -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] ""+-} 

@@ -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=""            }           ]

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

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

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