hledger-lib 1.10 → 1.11

raw patch · 59 files changed

+3437/−3065 lines, 59 filesdep +call-stackdep +cassavadep +cassava-megaparsecdep −HUnitdep −csvdep −test-frameworkdep ~Globdep ~doctestPVP ok

version bump matches the API change (PVP)

Dependencies added: call-stack, cassava, cassava-megaparsec

Dependencies removed: HUnit, csv, test-framework, test-framework-hunit

Dependency ranges changed: Glob, doctest

API changes (from Hackage documentation)

Files

• CHANGES +73/−0
• Hledger.hs +11/−11
• Hledger/Data.hs +17/−21
• Hledger/Data/Account.hs +51/−28
• Hledger/Data/AccountName.hs +58/−29
• Hledger/Data/Amount.hs +138/−116
• Hledger/Data/AutoTransaction.hs +0/−333
• Hledger/Data/Commodity.hs +0/−4
• Hledger/Data/Dates.hs +43/−22
• Hledger/Data/Journal.hs +49/−47
• Hledger/Data/Ledger.hs +29/−12
• Hledger/Data/MarketPrice.hs +0/−3
• Hledger/Data/PeriodicTransaction.hs +243/−0
• Hledger/Data/Posting.hs +21/−16
• Hledger/Data/RawOptions.hs +5/−1
• Hledger/Data/StringFormat.hs +43/−44
• Hledger/Data/Timeclock.hs +33/−33
• Hledger/Data/Transaction.hs +201/−203
• Hledger/Data/TransactionModifier.hs +131/−0
• Hledger/Data/Types.hs +60/−21
• Hledger/Query.hs +179/−190
• Hledger/Read.hs +35/−53
• Hledger/Read/Common.hs +140/−120
• Hledger/Read/CsvReader.hs +108/−111
• Hledger/Read/JournalReader.hs +294/−270
• Hledger/Read/TimeclockReader.hs +0/−5
• Hledger/Read/TimedotReader.hs +8/−15
• Hledger/Reports.hs +12/−16
• Hledger/Reports/BalanceHistoryReport.hs +0/−4
• Hledger/Reports/BalanceReport.hs +251/−232
• Hledger/Reports/BudgetReport.hs +59/−68
• Hledger/Reports/EntriesReport.hs +8/−13
• Hledger/Reports/MultiBalanceReports.hs +75/−95
• Hledger/Reports/PostingsReport.hs +208/−210
• Hledger/Reports/ReportOptions.hs +25/−33
• Hledger/Reports/TransactionsReports.hs +9/−8
• Hledger/Utils.hs +9/−8
• Hledger/Utils/Debug.hs +132/−131
• Hledger/Utils/Parse.hs +3/−1
• Hledger/Utils/Test.hs +126/−30
• Hledger/Utils/Text.hs +14/−11
• hledger-lib.cabal +28/−116
• hledger_csv.5 +1/−1
• hledger_csv.info +30/−30
• hledger_csv.txt +1/−1
• hledger_journal.5 +98/−49
• hledger_journal.info +183/−142
• hledger_journal.txt +117/−85
• hledger_timeclock.5 +1/−1
• hledger_timeclock.info +2/−2
• hledger_timeclock.txt +1/−1
• hledger_timedot.5 +1/−1
• hledger_timedot.info +4/−4
• hledger_timedot.txt +1/−1
• test/doctests.hs +63/−0
• test/easytests.hs +5/−0
• tests/doctests.hs +0/−14
• tests/easytests.hs +0/−39
• tests/hunittests.hs +0/−10

@@ -2,6 +2,79 @@ Most user-visible changes are noted in the hledger changelog, instead.  +# 1.11 (2018/9/30)++* compilation now works when locale is unset (#849)++* all unit tests have been converted from HUnit+test-framework to easytest++* doctests now run quicker by default, by skipping reloading between tests. +  This can be disabled by passing --slow to the doctests test suite+  executable.++* doctests test suite executable now supports --verbose, which shows+  progress output as tests are run if doctest 0.16.0+ is installed+  (and hopefully is harmless otherwise).++* doctests now support file pattern arguments, provide more informative output.+  Limiting to just the file(s) you're interested can make doctest start+  much quicker. With one big caveat: you can limit the starting files,+  but it always imports and tests all other local files those import.++* a bunch of custom Show instances have been replaced with defaults,+  for easier troubleshooting.  These were sometimes obscuring+  important details, eg in test failure output. Our new policy is:+  stick with default derived Show instances as far as possible, but+  when necessary adjust them to valid haskell syntax so pretty-show+  can pretty-print them (eg when they contain Day values, cf+  https://github.com/haskell/time/issues/101).  By convention, when+  fields are shown in less than full detail, and/or in double-quoted+  pseudo syntax, we show a double period (..) in the output.++* Amount has a new Show instance.  Amount's show instance hid+  important details by default, and showing more details required+  increasing the debug level, which was inconvenient.  Now it has a+  single show instance which shows more information, is fairly+  compact, and is pretty-printable.++  ghci> usd 1+  OLD:+  Amount {acommodity="$", aquantity=1.00, ..}+  NEW:+  Amount {acommodity = "$", aquantity = 1.00, aprice = NoPrice, astyle = AmountStyle "L False 2 Just '.' Nothing..", amultiplier = False}++  MixedAmount's show instance is unchanged, but showMixedAmountDebug+  is affected by this change:++  ghci> putStrLn $ showMixedAmountDebug $ Mixed [usd 1]+  OLD:+  Mixed [Amount {acommodity="$", aquantity=1.00, aprice=, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}}]+  NEW:+  Mixed [Amount {acommodity="$", aquantity=1.00, aprice=, astyle=AmountStyle "L False 2 Just '.' Nothing.."}]++* Same-line & next-line comments of transactions, postings, etc.+  are now parsed a bit more precisely (followingcommentp). +  Previously, parsing no comment gave the same result as an empty+  comment (a single newline); now it gives an empty string.  +  Also, and perhaps as a consequence of the above, when there's no+  same-line comment but there is a next-line comment, we'll insert an+  empty first line, since otherwise next-line comments would get moved+  up to the same line when rendered.++* Hledger.Utils.Test exports HasCallStack++* queryDateSpan, queryDateSpan' now intersect date AND'ed date spans+  instead of unioning them, and docs are clearer.++* pushAccount -> pushDeclaredAccount++* jaccounts -> jdeclaredaccounts++* AutoTransaction.hs -> PeriodicTransaction.hs & TransactionModifier.hs++* Hledger.Utils.Debug helpers have been renamed/cleaned up++ # 1.10 (2018/6/30)  * build cleanly with all supported GHC versions again (7.10 to 8.4)

@@ -1,21 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+ module Hledger (   module X  ,tests_Hledger ) where-import           Test.HUnit  import           Hledger.Data    as X-import           Hledger.Query   as X-import           Hledger.Read    as X hiding (samplejournal)+import           Hledger.Read    as X import           Hledger.Reports as X+import           Hledger.Query   as X import           Hledger.Utils   as X -tests_Hledger = TestList-    [-     tests_Hledger_Data-    ,tests_Hledger_Query-    ,tests_Hledger_Read-    ,tests_Hledger_Reports-    ,tests_Hledger_Utils-    ]+tests_Hledger = tests "Hledger" [+   tests_Data+  ,tests_Query+  ,tests_Read+  ,tests_Reports+  ,tests_Utils+  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-|  The Hledger.Data library allows parsing and querying of C++ ledger-style@@ -17,17 +18,17 @@                module Hledger.Data.Ledger,                module Hledger.Data.MarketPrice,                module Hledger.Data.Period,+               module Hledger.Data.PeriodicTransaction,                module Hledger.Data.Posting,                module Hledger.Data.RawOptions,                module Hledger.Data.StringFormat,                module Hledger.Data.Timeclock,                module Hledger.Data.Transaction,-               module Hledger.Data.AutoTransaction,+               module Hledger.Data.TransactionModifier,                module Hledger.Data.Types,-               tests_Hledger_Data+               tests_Data               ) where-import Test.HUnit  import Hledger.Data.Account import Hledger.Data.AccountName@@ -38,28 +39,23 @@ import Hledger.Data.Ledger import Hledger.Data.MarketPrice import Hledger.Data.Period+import Hledger.Data.PeriodicTransaction import Hledger.Data.Posting import Hledger.Data.RawOptions import Hledger.Data.StringFormat import Hledger.Data.Timeclock import Hledger.Data.Transaction-import Hledger.Data.AutoTransaction+import Hledger.Data.TransactionModifier import Hledger.Data.Types+import Hledger.Utils.Test -tests_Hledger_Data :: Test-tests_Hledger_Data = TestList-    [-     tests_Hledger_Data_Account-    ,tests_Hledger_Data_AccountName-    ,tests_Hledger_Data_Amount-    ,tests_Hledger_Data_Commodity-    ,tests_Hledger_Data_Journal-    ,tests_Hledger_Data_MarketPrice-    ,tests_Hledger_Data_Ledger-    ,tests_Hledger_Data_Posting-    -- ,tests_Hledger_Data_RawOptions-    -- ,tests_Hledger_Data_StringFormat-    ,tests_Hledger_Data_Timeclock-    ,tests_Hledger_Data_Transaction-    -- ,tests_Hledger_Data_Types-    ]+tests_Data = tests "Data" [+   tests_AccountName+  ,tests_Amount+  ,tests_Journal+  ,tests_Ledger+  ,tests_Posting+  ,tests_StringFormat+  ,tests_Timeclock+  ,tests_Transaction+  ]

@@ -16,7 +16,6 @@ import qualified Data.Map as M import Data.Text (pack,unpack) import Safe (headMay, lookupJustDef)-import Test.HUnit import Text.Printf  import Hledger.Data.AccountName@@ -47,7 +46,7 @@  nullacct = Account   { aname = ""-  , acode = Nothing+  , adeclarationorder = Nothing   , aparent = Nothing   , asubs = []   , anumpostings = 0@@ -68,9 +67,8 @@     grouped = groupSort [(paccount p,pamount p) | p <- ps]     counted = [(aname, length amts) | (aname, amts) <- grouped]     summed =  [(aname, sumStrict amts) | (aname, amts) <- grouped]  -- always non-empty-    nametree = treeFromPaths $ map (expandAccountName . fst) summed-    acctswithnames = nameTreeToAccount "root" nametree-    acctswithnumps = mapAccounts setnumps    acctswithnames where setnumps    a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted}+    acctstree      = accountTree "root" $ map fst summed+    acctswithnumps = mapAccounts setnumps    acctstree      where setnumps    a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted}     acctswithebals = mapAccounts setebalance acctswithnumps where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed}     acctswithibals = sumAccounts acctswithebals     acctswithparents = tieAccountParents acctswithibals@@ -78,10 +76,14 @@   in     acctsflattened --- | Convert an AccountName tree to an Account tree-nameTreeToAccount :: AccountName -> FastTree AccountName -> Account-nameTreeToAccount rootname (T m) =-    nullacct{ aname=rootname, asubs=map (uncurry nameTreeToAccount) $ M.assocs m }+-- | Convert a list of account names to a tree of Account objects, +-- with just the account names filled in. +-- A single root account with the given name is added.+accountTree :: AccountName -> [AccountName] -> Account+accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m }+  where+    T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName+    accountTree' a (T m) = nullacct{aname=a, asubs=map (uncurry accountTree') $ M.assocs m}  -- | Tie the knot so all subaccounts' parents are set correctly. tieAccountParents :: Account -> Account@@ -91,10 +93,6 @@       where         a' = a{aparent=parent, asubs=map (tie (Just a')) asubs} --- | Look up an account's numeric code, if any, from the Journal and set it.-accountSetCodeFrom :: Journal -> Account -> Account-accountSetCodeFrom j a = a{acode=fromMaybe Nothing $ lookup (aname a) (jaccounts j)}- -- | Get this account's parent accounts, from the nearest up to the root. parentAccounts :: Account -> [Account] parentAccounts Account{aparent=Nothing} = []@@ -190,7 +188,7 @@     | p a       = a : concatMap (filterAccounts p) (asubs a)     | otherwise = concatMap (filterAccounts p) (asubs a) --- | Sort each level of an account tree by inclusive amount,+-- | Sort each group of siblings in an account tree by inclusive amount, -- so that the accounts with largest normal balances are listed first.   -- The provided normal balance sign determines whether normal balances -- are negative or positive, affecting the sort order. Ie,@@ -200,24 +198,54 @@ sortAccountTreeByAmount normalsign a   | null $ asubs a = a   | otherwise      = a{asubs=-                        sortBy (maybeflip $ comparing aibalance) $+                        sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . aibalance)) $                         map (sortAccountTreeByAmount normalsign) $ asubs a}   where     maybeflip | normalsign==NormallyNegative = id               | otherwise                  = flip --- | Sort each level of an account tree first by the account code--- if any, with the empty account code sorting last, and then by--- the account name. -sortAccountTreeByAccountCodeAndName :: Account -> Account-sortAccountTreeByAccountCodeAndName a+-- | Look up an account's declaration order, if any, from the Journal and set it.+-- This is the relative position of its account directive +-- among the other account directives.+accountSetDeclarationOrder :: Journal -> Account -> Account+accountSetDeclarationOrder j a@Account{..} = +  a{adeclarationorder = findIndex (==aname) (jdeclaredaccounts j)}++-- | Sort account names by the order in which they were declared in+-- the journal, at each level of the account tree (ie within each+-- group of siblings). Undeclared accounts are sorted last and+-- alphabetically. +-- This is hledger's default sort for reports organised by account.+-- The account list is converted to a tree temporarily, adding any+-- missing parents; these can be kept (suitable for a tree-mode report) +-- or removed (suitable for a flat-mode report).+--+sortAccountNamesByDeclaration :: Journal -> Bool -> [AccountName] -> [AccountName]+sortAccountNamesByDeclaration j keepparents as =+  (if keepparents then id else filter (`elem` as)) $  -- maybe discard missing parents that were added+  map aname $                                         -- keep just the names+  drop 1 $                                            -- drop the root node that was added+  flattenAccounts $                                   -- convert to an account list+  sortAccountTreeByDeclaration $                      -- sort by declaration order (and name)+  mapAccounts (accountSetDeclarationOrder j) $        -- add declaration order info  +  accountTree "root"                                  -- convert to an account tree+  as++-- | Sort each group of siblings in an account tree by declaration order, then account name.+-- So each group will contain first the declared accounts, +-- in the same order as their account directives were parsed, +-- and then the undeclared accounts, sorted by account name. +sortAccountTreeByDeclaration :: Account -> Account+sortAccountTreeByDeclaration a   | null $ asubs a = a   | otherwise      = a{asubs=-      sortBy (comparing accountCodeAndNameForSort) $ map sortAccountTreeByAccountCodeAndName $ asubs a}+      sortBy (comparing accountDeclarationOrderAndName) $ +      map sortAccountTreeByDeclaration $ asubs a+      } -accountCodeAndNameForSort a = (acode', aname a)+accountDeclarationOrderAndName a = (adeclarationorder', aname a)   where-    acode' = fromMaybe maxBound (acode a)+    adeclarationorder' = fromMaybe maxBound (adeclarationorder a)  -- | Search an account list by name. lookupAccount :: AccountName -> [Account] -> Maybe Account@@ -237,8 +265,3 @@                      (showMixedAmount $ aebalance a)                      (showMixedAmount $ aibalance a)                      (if aboring a then "b" else " " :: String)---tests_Hledger_Data_Account = TestList [- ]-

@@ -9,8 +9,37 @@  -} -module Hledger.Data.AccountName+module Hledger.Data.AccountName (+   accountLeafName+  ,accountNameComponents+  ,accountNameDrop+  ,accountNameFromComponents+  ,accountNameLevel+  ,accountNameToAccountOnlyRegex+  ,accountNameToAccountRegex+  ,accountNameTreeFrom+  ,accountRegexToAccountName+  ,accountSummarisedName+  ,acctsep+  ,acctsepchar+  ,clipAccountName+  ,clipOrEllipsifyAccountName+  ,elideAccountName+  ,escapeName+  ,expandAccountName+  ,expandAccountNames+  ,isAccountNamePrefixOf+--  ,isAccountRegex +  ,isSubAccountNameOf+  ,parentAccountName+  ,parentAccountNames+  ,subAccountNamesFrom+  ,topAccountNames+  ,unbudgetedAccountName+  ,tests_AccountName+) where+ import Data.List #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid@@ -18,12 +47,13 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Tree-import Test.HUnit import Text.Printf  import Hledger.Data.Types-import Hledger.Utils+import Hledger.Utils  +-- $setup+-- >>> :set -XOverloadedStrings  acctsepchar :: Char acctsepchar = ':'@@ -122,7 +152,7 @@           accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]           subs = subAccountNamesFrom (expandAccountNames accts) -nullaccountnametree = Node "root" []+--nullaccountnametree = Node "root" []  -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news:@@ -192,33 +222,32 @@ accountRegexToAccountName :: Regexp -> AccountName accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack --- | Does this string look like an exact account-matching regular expression ?-isAccountRegex  :: String -> Bool-isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:("--tests_Hledger_Data_AccountName = TestList- [-  "accountNameTreeFrom" ~: do-    accountNameTreeFrom ["a"]       `is` Node "root" [Node "a" []]-    accountNameTreeFrom ["a","b"]   `is` Node "root" [Node "a" [], Node "b" []]-    accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]]-    accountNameTreeFrom ["a:b:c"]   `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]]+-- -- | Does this string look like an exact account-matching regular expression ?+--isAccountRegex  :: String -> Bool+--isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" -  ,"expandAccountNames" ~:+tests_AccountName = tests "AccountName" [+  tests "accountNameTreeFrom" [+     accountNameTreeFrom ["a"]       `is` Node "root" [Node "a" []]+    ,accountNameTreeFrom ["a","b"]   `is` Node "root" [Node "a" [], Node "b" []]+    ,accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]]+    ,accountNameTreeFrom ["a:b:c"]   `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]]+  ]+  ,tests "expandAccountNames" [     expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`      ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]--  ,"isAccountNamePrefixOf" ~: do-    "assets" `isAccountNamePrefixOf` "assets" `is` False-    "assets" `isAccountNamePrefixOf` "assets:bank" `is` True-    "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True-    "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False--  ,"isSubAccountNameOf" ~: do-    "assets" `isSubAccountNameOf` "assets" `is` False-    "assets:bank" `isSubAccountNameOf` "assets" `is` True-    "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False-    "assets:bank" `isSubAccountNameOf` "my assets" `is` False-+  ]+  ,tests "isAccountNamePrefixOf" [+     "assets" `isAccountNamePrefixOf` "assets" `is` False+    ,"assets" `isAccountNamePrefixOf` "assets:bank" `is` True+    ,"assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True+    ,"my assets" `isAccountNamePrefixOf` "assets:bank" `is` False+  ]+  ,tests "isSubAccountNameOf" [+     "assets" `isSubAccountNameOf` "assets" `is` False+    ,"assets:bank" `isSubAccountNameOf` "assets" `is` True+    ,"assets:bank:checking" `isSubAccountNameOf` "assets" `is` False+    ,"assets:bank" `isSubAccountNameOf` "my assets" `is` False+  ]  ] 

@@ -40,7 +40,7 @@  -} -{-# LANGUAGE CPP, StandaloneDeriving, RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving, RecordWildCards, OverloadedStrings #-}  module Hledger.Data.Amount (   -- * Amount@@ -58,6 +58,7 @@   -- ** arithmetic   costOfAmount,   divideAmount,+  multiplyAmount,   amountValue,   -- ** rendering   amountstyle,@@ -71,6 +72,10 @@   maxprecisionwithpoint,   setAmountPrecision,   withPrecision,+  setAmountInternalPrecision,+  withInternalPrecision,+  setAmountDecimalPoint,+  withDecimalPoint,   canonicaliseAmount,   -- * MixedAmount   nullmixedamt,@@ -84,6 +89,7 @@   -- ** arithmetic   costOfMixedAmount,   divideMixedAmount,+  multiplyMixedAmount,   averageMixedAmounts,   isNegativeAmount,   isNegativeMixedAmount,@@ -108,7 +114,7 @@   canonicaliseMixedAmount,   -- * misc.   ltraceamount,-  tests_Hledger_Data_Amount+  tests_Amount ) where  import Data.Char (isDigit)@@ -122,13 +128,12 @@ -- import Data.Text (Text) import qualified Data.Text as T import Safe (maximumDef)-import Test.HUnit import Text.Printf import qualified Data.Map as M  import Hledger.Data.Types import Hledger.Data.Commodity-import Hledger.Utils+import Hledger.Utils    deriving instance Show MarketPrice@@ -144,15 +149,6 @@ ------------------------------------------------------------------------------- -- Amount -instance Show Amount where-  show _a@Amount{..}-    --  debugLevel < 2 = showAmountWithoutPrice a-    --  debugLevel < 3 = showAmount a-    | debugLevel < 6 =-       printf "Amount {acommodity=%s, aquantity=%s, ..}" (show acommodity) (show aquantity)-    | otherwise      = --showAmountDebug a-       printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle)- instance Num Amount where     abs a@Amount{aquantity=q}    = a{aquantity=abs q}     signum a@Amount{aquantity=q} = a{aquantity=signum q}@@ -217,6 +213,10 @@ divideAmount :: Amount -> Quantity -> Amount divideAmount a@Amount{aquantity=q} d = a{aquantity=q/d} +-- | Multiply an amount's quantity by a constant.+multiplyAmount :: Amount -> Quantity -> Amount+multiplyAmount a@Amount{aquantity=q} d = a{aquantity=q*d}+ -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0@@ -255,6 +255,31 @@ showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice a = showAmount a{aprice=NoPrice} +-- | Set an amount's internal precision, ie rounds the Decimal representing +-- the amount's quantity to some number of decimal places.+-- Rounding is done with Data.Decimal's default roundTo function:+-- "If the value ends in 5 then it is rounded to the nearest even value (Banker's Rounding)".+-- Does not change the amount's display precision.+-- Intended only for internal use, eg when comparing amounts in tests. +setAmountInternalPrecision :: Int -> Amount -> Amount+setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{ +   astyle=s{asprecision=p} +  ,aquantity=roundTo (fromIntegral p) q+  }++-- | Set an amount's internal precision, flipped.+-- Intended only for internal use, eg when comparing amounts in tests. +withInternalPrecision :: Amount -> Int -> Amount+withInternalPrecision = flip setAmountInternalPrecision++-- | Set (or clear) an amount's display decimal point.+setAmountDecimalPoint :: Maybe Char -> Amount -> Amount+setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} }++-- | Set (or clear) an amount's display decimal point, flipped.+withDecimalPoint :: Amount -> Maybe Char -> Amount+withDecimalPoint = flip setAmountDecimalPoint+ -- | Colour version. cshowAmountWithoutPrice :: Amount -> String cshowAmountWithoutPrice a = cshowAmount a{aprice=NoPrice}@@ -375,9 +400,7 @@ amountValue :: Journal -> Day -> Amount -> Amount amountValue j d a =   case commodityValue j d (acommodity a) of-    Just v  -> v{aquantity=aquantity v * aquantity a-                ,aprice=aprice a-                }+    Just v  -> v{aquantity=aquantity v * aquantity a}     Nothing -> a  -- This is here not in Commodity.hs to use the Amount Show instance above for debugging. @@ -403,12 +426,6 @@ ------------------------------------------------------------------------------- -- MixedAmount -instance Show MixedAmount where-  show-    | debugLevel < 3 = intercalate "\\n" . lines . showMixedAmountWithoutPrice-    --  debugLevel < 6 = intercalate "\\n" . lines . showMixedAmount-    | otherwise      = showMixedAmountDebug- instance Num MixedAmount where     fromInteger i = Mixed [fromInteger i]     negate (Mixed as) = Mixed $ map negate as@@ -467,36 +484,12 @@     combinableprices Amount{aprice=UnitPrice p1} Amount{aprice=UnitPrice p2} = p1 == p2     combinableprices _ _ = False -tests_normaliseMixedAmount = [-  "normaliseMixedAmount" ~: do-   -- assertEqual "missing amount is discarded" (Mixed [nullamt]) (normaliseMixedAmount $ Mixed [usd 0, missingamt])-   assertEqual "any missing amount means a missing mixed amount" missingmixedamt (normaliseMixedAmount $ Mixed [usd 0, missingamt])-   assertEqual "unpriced same-commodity amounts are combined" (Mixed [usd 2]) (normaliseMixedAmount $ Mixed [usd 0, usd 2])-   -- amounts with same unit price are combined-   normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1]-   -- amounts with different unit prices are not combined-   normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]-   -- amounts with total prices are not combined-   normaliseMixedAmount (Mixed  [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]- ]- -- | Like normaliseMixedAmount, but combine each commodity's amounts -- into just one by throwing away all prices except the first. This is -- only used as a rendering helper, and could show a misleading price. normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount normaliseMixedAmountSquashPricesForDisplay = normaliseHelper True -tests_normaliseMixedAmountSquashPricesForDisplay = [-  "normaliseMixedAmountSquashPricesForDisplay" ~: do-    normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]-    assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay-      (Mixed [usd 10-             ,usd 10 @@ eur 7-             ,usd (-10)-             ,usd (-10) @@ eur 7-             ])- ]- -- | Sum same-commodity amounts in a lossy way, applying the first -- price to the result and discarding any other prices. Only used as a -- rendering helper.@@ -539,6 +532,10 @@ divideMixedAmount :: MixedAmount -> Quantity -> MixedAmount divideMixedAmount (Mixed as) d = Mixed $ map (`divideAmount` d) as +-- | Multiply a mixed amount's quantities by a constant.+multiplyMixedAmount :: MixedAmount -> Quantity -> MixedAmount+multiplyMixedAmount (Mixed as) d = Mixed $ map (`multiplyAmount` d) as+ -- | Calculate the average of some mixed amounts. averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts [] = 0@@ -670,80 +667,105 @@   ---------------------------------------------------------------------------------- misc--tests_Hledger_Data_Amount = TestList $-     tests_normaliseMixedAmount-  ++ tests_normaliseMixedAmountSquashPricesForDisplay-  ++ [--  -- Amount--   "costOfAmount" ~: do-    costOfAmount (eur 1) `is` eur 1-    costOfAmount (eur 2){aprice=UnitPrice $ usd 2} `is` usd 4-    costOfAmount (eur 1){aprice=TotalPrice $ usd 2} `is` usd 2-    costOfAmount (eur (-1)){aprice=TotalPrice $ usd 2} `is` usd (-2)--  ,"isZeroAmount" ~: do-    assertBool "" $ isZeroAmount amount-    assertBool "" $ isZeroAmount $ usd 0--  ,"negating amounts" ~: do-    let a = usd 1-    negate a `is` a{aquantity= -1}-    let b = (usd 1){aprice=UnitPrice $ eur 2}-    negate b `is` b{aquantity= -1}--  ,"adding amounts without prices" ~: do-    let a1 = usd 1.23-    let a2 = usd (-1.23)-    let a3 = usd (-1.23)-    (a1 + a2) `is` usd 0-    (a1 + a3) `is` usd 0-    (a2 + a3) `is` usd (-2.46)-    (a3 + a3) `is` usd (-2.46)-    sum [a1,a2,a3,-a3] `is` usd 0-    -- highest precision is preserved-    let ap1 = usd 1 `withPrecision` 1-        ap3 = usd 1 `withPrecision` 3-    asprecision (astyle $ sum [ap1,ap3]) `is` 3-    asprecision (astyle $ sum [ap3,ap1]) `is` 3-    -- adding different commodities assumes conversion rate 1-    assertBool "" $ isZeroAmount (a1 - eur 1.23)--  ,"showAmount" ~: do-    showAmount (usd 0 + gbp 0) `is` "0"+-- tests -  -- MixedAmount+tests_Amount = tests "Amount" [+   tests "Amount" [ -  ,"adding mixed amounts to zero, the commodity and amount style are preserved" ~: do-    sum (map (Mixed . (:[]))-             [usd 1.25-             ,usd (-1) `withPrecision` 3-             ,usd (-0.25)-             ])-      `is` Mixed [usd 0 `withPrecision` 3]+     tests "costOfAmount" [+       costOfAmount (eur 1) `is` eur 1+      ,costOfAmount (eur 2){aprice=UnitPrice $ usd 2} `is` usd 4+      ,costOfAmount (eur 1){aprice=TotalPrice $ usd 2} `is` usd 2+      ,costOfAmount (eur (-1)){aprice=TotalPrice $ usd 2} `is` usd (-2)+    ]+  +    ,tests "isZeroAmount" [+       expect $ isZeroAmount amount+      ,expect $ isZeroAmount $ usd 0+    ]+  +    ,tests "negating amounts" [+       negate (usd 1) `is` (usd 1){aquantity= -1}+      ,let b = (usd 1){aprice=UnitPrice $ eur 2} in negate b `is` b{aquantity= -1}+    ]+  +    ,tests "adding amounts without prices" [+       (usd 1.23 + usd (-1.23)) `is` usd 0+      ,(usd 1.23 + usd (-1.23)) `is` usd 0+      ,(usd (-1.23) + usd (-1.23)) `is` usd (-2.46)+      ,sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] `is` usd 0+      -- highest precision is preserved+      ,asprecision (astyle $ sum [usd 1 `withPrecision` 1, usd 1 `withPrecision` 3]) `is` 3+      ,asprecision (astyle $ sum [usd 1 `withPrecision` 3, usd 1 `withPrecision` 1]) `is` 3+      -- adding different commodities assumes conversion rate 1+      ,expect $ isZeroAmount (usd 1.23 - eur 1.23)+    ]+  +    ,tests "showAmount" [+      showAmount (usd 0 + gbp 0) `is` "0"+    ] -  ,"adding mixed amounts with total prices" ~: do-    sum (map (Mixed . (:[]))-     [usd 1 @@ eur 1-     ,usd (-2) @@ eur 1-     ])-      `is` Mixed [usd 1 @@ eur 1-                 ,usd (-2) @@ eur 1-                 ]+  ] -  ,"showMixedAmount" ~: do-    showMixedAmount (Mixed [usd 1]) `is` "$1.00"-    showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00"-    showMixedAmount (Mixed [usd 0]) `is` "0"-    showMixedAmount (Mixed []) `is` "0"-    showMixedAmount missingmixedamt `is` ""+  ,tests "MixedAmount" [ -  ,"showMixedAmountWithoutPrice" ~: do-    let a = usd 1 `at` eur 2-    showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"-    showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"+     tests "adding mixed amounts to zero, the commodity and amount style are preserved" [+      sum (map (Mixed . (:[]))+               [usd 1.25+               ,usd (-1) `withPrecision` 3+               ,usd (-0.25)+               ])+        `is` Mixed [usd 0 `withPrecision` 3]+    ]+  +    ,tests "adding mixed amounts with total prices" [+      sum (map (Mixed . (:[]))+       [usd 1 @@ eur 1+       ,usd (-2) @@ eur 1+       ])+        `is` Mixed [usd 1 @@ eur 1+                   ,usd (-2) @@ eur 1+                   ]+    ]+  +    ,tests "showMixedAmount" [+       showMixedAmount (Mixed [usd 1]) `is` "$1.00"+      ,showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00"+      ,showMixedAmount (Mixed [usd 0]) `is` "0"+      ,showMixedAmount (Mixed []) `is` "0"+      ,showMixedAmount missingmixedamt `is` ""+    ]+  +    ,tests "showMixedAmountWithoutPrice" $+      let a = usd 1 `at` eur 2 in +    [+        showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"+       ,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"+    ]+  +    ,tests "normaliseMixedAmount" [+       test "a missing amount overrides any other amounts" $ +        normaliseMixedAmount (Mixed [usd 1, missingamt]) `is` missingmixedamt+      ,test "unpriced same-commodity amounts are combined" $ +        normaliseMixedAmount (Mixed [usd 0, usd 2]) `is` Mixed [usd 2]+      ,test "amounts with same unit price are combined" $ +        normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1]+      ,test "amounts with different unit prices are not combined" $ +        normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]+      ,test "amounts with total prices are not combined" $+        normaliseMixedAmount (Mixed  [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]+    ]+  +    ,tests "normaliseMixedAmountSquashPricesForDisplay" [+       normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]+      ,expect $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay+        (Mixed [usd 10+               ,usd 10 @@ eur 7+               ,usd (-10)+               ,usd (-10) @@ eur 7+               ])+    ]    ]++ ]

@@ -1,333 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-}-{-|--This module provides utilities for applying automated transactions like-'ModifierTransaction' and 'PeriodicTransaction'.---}-module Hledger.Data.AutoTransaction-    (-    -- * Transaction processors-      runModifierTransaction-    , runPeriodicTransaction--    -- * Accessors-    , mtvaluequery-    , jdatespan-    , periodTransactionInterval--    -- * Misc-    , checkPeriodicTransactionStartDate-    )-where--import Data.Maybe-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import Data.Time.Calendar-import qualified Data.Text as T-import Hledger.Data.Types-import Hledger.Data.Dates-import Hledger.Data.Amount-import Hledger.Data.Posting (post)-import Hledger.Data.Transaction-import Hledger.Utils.UTF8IOCompat (error')-import Hledger.Query--- import Hledger.Utils.Debug---- $setup--- >>> :set -XOverloadedStrings--- >>> import Hledger.Data.Posting--- >>> import Hledger.Data.Journal---- | Builds a 'Transaction' transformer based on 'ModifierTransaction'.------ 'Query' parameter allows injection of additional restriction on posting--- match. Don't forget to call 'txnTieKnot'.------ >>> runModifierTransaction Any (ModifierTransaction "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}--- 0000/01/01---     ping           $1.00---     pong           $2.00--- <BLANKLINE>--- <BLANKLINE>--- >>> runModifierTransaction Any (ModifierTransaction "miss" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}--- 0000/01/01---     ping           $1.00--- <BLANKLINE>--- <BLANKLINE>--- >>> runModifierTransaction None (ModifierTransaction "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}--- 0000/01/01---     ping           $1.00--- <BLANKLINE>--- <BLANKLINE>--- >>> runModifierTransaction Any (ModifierTransaction "ping" ["pong" `post` amount{amultiplier=True, aquantity=3}]) nulltransaction{tpostings=["ping" `post` usd 2]}--- 0000/01/01---     ping           $2.00---     pong           $6.00--- <BLANKLINE>--- <BLANKLINE>-runModifierTransaction :: Query -> ModifierTransaction -> (Transaction -> Transaction)-runModifierTransaction q mt = modifier where-    q' = simplifyQuery $ And [q, mtvaluequery mt (error "query cannot depend on current time")]-    mods = map runModifierPosting $ mtpostings mt-    generatePostings ps = [p' | p <- ps-                              , p' <- if q' `matchesPosting` p then p:[ m p | m <- mods] else [p]]-    modifier t@(tpostings -> ps) = t { tpostings = generatePostings ps }---- | Extract 'Query' equivalent of 'mtvalueexpr' from 'ModifierTransaction'------ >>> mtvaluequery (ModifierTransaction "" []) undefined--- Any--- >>> mtvaluequery (ModifierTransaction "ping" []) undefined--- Acct "ping"--- >>> mtvaluequery (ModifierTransaction "date:2016" []) undefined--- Date (DateSpan 2016)--- >>> mtvaluequery (ModifierTransaction "date:today" []) (read "2017-01-01")--- Date (DateSpan 2017/01/01)-mtvaluequery :: ModifierTransaction -> (Day -> Query)-mtvaluequery mt = fst . flip parseQuery (mtvalueexpr mt)---- | 'DateSpan' of all dates mentioned in 'Journal'------ >>> jdatespan nulljournal--- DateSpan ---- >>> jdatespan nulljournal{jtxns=[nulltransaction{tdate=read "2016-01-01"}] }--- DateSpan 2016/01/01--- >>> jdatespan nulljournal{jtxns=[nulltransaction{tdate=read "2016-01-01", tpostings=[nullposting{pdate=Just $ read "2016-02-01"}]}] }--- DateSpan 2016/01/01-2016/02/01-jdatespan :: Journal -> DateSpan-jdatespan j-        | null dates = nulldatespan-        | otherwise = DateSpan (Just $ minimum dates) (Just $ 1 `addDays` maximum dates)-    where-        dates = concatMap tdates $ jtxns j---- | 'DateSpan' of all dates mentioned in 'Transaction'------ >>> tdates nulltransaction--- [0000-01-01]-tdates :: Transaction -> [Day]-tdates t = tdate t : concatMap pdates (tpostings t) ++ maybeToList (tdate2 t) where-    pdates p = catMaybes [pdate p, pdate2 p]--postingScale :: Posting -> Maybe Quantity-postingScale p =-    case amounts $ pamount p of-        [a] | amultiplier a -> Just $ aquantity a-        _ -> Nothing--runModifierPosting :: Posting -> (Posting -> Posting)-runModifierPosting p' = modifier where-    modifier p = renderPostingCommentDates $ p'-        { pdate = pdate p-        , pdate2 = pdate2 p-        , pamount = amount' p-        }-    amount' = case postingScale p' of-        Nothing -> const $ pamount p'-        Just n -> \p -> withAmountType (head $ amounts $ pamount p') $ pamount p `divideMixedAmount` (1/n)-    withAmountType amount (Mixed as) = case acommodity amount of-        "" -> Mixed as-        c -> Mixed [a{acommodity = c, astyle = astyle amount, aprice = aprice amount} | a <- as]--renderPostingCommentDates :: Posting -> Posting-renderPostingCommentDates p = p { pcomment = comment' }-    where-        datesComment = T.concat $ catMaybes [T.pack . showDate <$> pdate p, ("=" <>) . T.pack . showDate <$> pdate2 p]-        comment'-            | T.null datesComment = pcomment p-            | otherwise = T.intercalate "\n" $ filter (not . T.null) [T.strip $ pcomment p, "[" <> datesComment <> "]"]---- doctest helper, too much hassle to define in the comment--- XXX duplicates some logic in periodictransactionp-_ptgen str = do-  let -    t = T.pack str-    (i,s) = parsePeriodExpr' nulldate t-  case checkPeriodicTransactionStartDate i s t of-    Just e  -> error' e-    Nothing ->-      mapM_ (putStr . show) $-        runPeriodicTransaction-          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } -          nulldatespan---- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'------ Note that new transactions require 'txnTieKnot' post-processing.------ >>> _ptgen "monthly from 2017/1 to 2017/4"--- 2017/01/01---     ; recur: monthly from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/02/01---     ; recur: monthly from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/03/01---     ; recur: monthly from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "monthly from 2017/1 to 2017/5"--- 2017/01/01---     ; recur: monthly from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/02/01---     ; recur: monthly from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/03/01---     ; recur: monthly from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/04/01---     ; recur: monthly from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"--- 2017/01/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04---     a           $1.00--- <BLANKLINE>--- 2017/02/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04---     a           $1.00--- <BLANKLINE>--- 2017/03/02---     ; recur: every 2nd day of month from 2017/02 to 2017/04---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"--- 2016/12/30---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/01/30---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/02/28---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/03/30---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>--- 2017/04/30---     ; recur: every 30th day of month from 2017/1 to 2017/5---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"--- 2016/12/08---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/01/12---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/02/09---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>--- 2017/03/09---     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "every nov 29th from 2017 to 2019"--- 2016/11/29---     ; recur: every nov 29th from 2017 to 2019---     a           $1.00--- <BLANKLINE>--- 2017/11/29---     ; recur: every nov 29th from 2017 to 2019---     a           $1.00--- <BLANKLINE>--- 2018/11/29---     ; recur: every nov 29th from 2017 to 2019---     a           $1.00--- <BLANKLINE>------ >>> _ptgen "2017/1"--- 2017/01/01---     ; recur: 2017/1---     a           $1.00--- <BLANKLINE>------ >>> _ptgen ""--- *** Exception: failed to parse...--- ...------ >>> _ptgen "weekly from 2017"--- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the week------ >>> _ptgen "monthly from 2017/5/4"--- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month        ------ >>> _ptgen "every quarter from 2017/1/2"--- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter        ------ >>> _ptgen "yearly from 2017/1/14"--- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year        ------ >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))--- []----runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]-runPeriodicTransaction PeriodicTransaction{..} requestedspan =-    [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` spantofill ]-  where-    spantofill = spanIntervalIntersect ptinterval ptspan requestedspan-    t = nulltransaction{-           tstatus      = ptstatus-          ,tcode        = ptcode-          ,tdescription = ptdescription -          ,tcomment     = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr-          ,ttags        = ("recur", ptperiodexpr) : pttags -          ,tpostings    = ptpostings-          }---- | Check that this date span begins at a boundary of this interval, --- or return an explanatory error message including the provided period expression--- (from which the span and interval are derived).-checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String -checkPeriodicTransactionStartDate i s periodexpr = -  case (i, spanStart s) of-    (Weeks _,    Just d) -> checkStart d "week"-    (Months _,   Just d) -> checkStart d "month"-    (Quarters _, Just d) -> checkStart d "quarter"-    (Years _,    Just d) -> checkStart d "year"-    _                    -> Nothing -    where-      checkStart d x =-        let firstDate = fixSmartDate d ("","this",x) -        in   -         if d == firstDate -         then Nothing-         else Just $-          "Unable to generate transactions according to "++show (T.unpack periodexpr)-          ++" because "++show d++" is not a first day of the "++x---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?-periodTransactionInterval :: PeriodicTransaction -> Maybe Interval-periodTransactionInterval pt =-  let-    expr = ptperiodexpr pt-    err  = error' $ "Current date cannot be referenced in " ++ show (T.unpack expr)-  in-    case parsePeriodExpr err expr of-      Left _      -> Nothing-      Right (i,_) -> Just i

@@ -19,7 +19,6 @@ import Data.Monoid #endif import qualified Data.Text as T-import Test.HUnit -- import qualified Data.Map as M  import Hledger.Data.Types@@ -79,7 +78,4 @@ --     commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols] --     commoditieswithsymbol s = filter ((s==) . symbol) cs --     symbols = nub $ map symbol cs--tests_Hledger_Data_Commodity = TestList [- ] 

@@ -205,7 +205,7 @@ splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (nthdayofmonth n . nextmonth) s splitSpan (WeekdayOfMonth n wd) s = splitspan (nthweekdayofmonthcontaining n wd) (advancetonthweekday n wd . nextmonth) s splitSpan (DayOfWeek n)  s = splitspan (nthdayofweekcontaining n)  (applyN (n-1) nextday . nextweek)  s-splitSpan (DayOfYear m n) s= splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s+splitSpan (DayOfYear m n) s = splitspan (nthdayofyearcontaining m n) (applyN (n-1) nextday . applyN (m-1) nextmonth . nextyear) s -- splitSpan (WeekOfYear n)    s = splitspan startofweek    (applyN n nextweek)    s -- splitSpan (MonthOfYear n)   s = splitspan startofmonth   (applyN n nextmonth)   s -- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s@@ -526,8 +526,10 @@ nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day --- | For given date d find year-long interval that starts on given MM/DD of year--- and covers it. +-- | For given date d find year-long interval that starts on given+-- MM/DD of year and covers it.+-- The given MM and DD should be basically valid (1-12 & 1-31),+-- or an error is raised. -- -- Examples: lets take 2017-11-22. Year-long intervals covering it that -- starts before Nov 22 will start in 2017. However@@ -545,14 +547,19 @@ -- 2016-12-31           -- >>> nthdayofyearcontaining 1 1 wed22nd -- 2017-01-01          -nthdayofyearcontaining m n d | mmddOfSameYear <= d = mmddOfSameYear-                             | otherwise = mmddOfPrevYear-    where mmddOfSameYear = addDays (fromIntegral n-1) $ applyN (m-1) nextmonth s-          mmddOfPrevYear = addDays (fromIntegral n-1) $ applyN (m-1) nextmonth $ prevyear s-          s = startofyear d+nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day+nthdayofyearcontaining m md date+  | not (validMonth $ show m)  = error' $ "nthdayofyearcontaining: invalid month "++show m+  | not (validDay   $ show md) = error' $ "nthdayofyearcontaining: invalid day "  ++show md+  | mmddOfSameYear <= date = mmddOfSameYear+  | otherwise = mmddOfPrevYear+  where mmddOfSameYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth s+        mmddOfPrevYear = addDays (fromIntegral md-1) $ applyN (m-1) nextmonth $ prevyear s+        s = startofyear date  -- | For given date d find month-long interval that starts on nth day of month -- and covers it. +-- The given day of month should be basically valid (1-31), or an error is raised. -- -- Examples: lets take 2017-11-22. Month-long intervals covering it that -- start on 1st-22nd of month will start in Nov. However@@ -568,11 +575,14 @@ -- 2017-10-23           -- >>> nthdayofmonthcontaining 30 wed22nd -- 2017-10-30          -nthdayofmonthcontaining n d | nthOfSameMonth <= d = nthOfSameMonth-                            | otherwise = nthOfPrevMonth-    where nthOfSameMonth = nthdayofmonth n s-          nthOfPrevMonth = nthdayofmonth n $ prevmonth s-          s = startofmonth d+nthdayofmonthcontaining :: MonthDay -> Day -> Day+nthdayofmonthcontaining md date+  | not (validDay $ show md) = error' $ "nthdayofmonthcontaining: invalid day "  ++show md+  | nthOfSameMonth <= date = nthOfSameMonth+  | otherwise = nthOfPrevMonth+  where nthOfSameMonth = nthdayofmonth md s+        nthOfPrevMonth = nthdayofmonth md $ prevmonth s+        s = startofmonth date  -- | For given date d find week-long interval that starts on nth day of week -- and covers it. @@ -591,6 +601,7 @@ -- 2017-11-16           -- >>> nthdayofweekcontaining 5 wed22nd -- 2017-11-17          +nthdayofweekcontaining :: WeekDay -> Day -> Day nthdayofweekcontaining n d | nthOfSameWeek <= d = nthOfSameWeek                            | otherwise = nthOfPrevWeek     where nthOfSameWeek = addDays (fromIntegral n-1) s@@ -614,16 +625,20 @@ -- 2017-10-26 -- >>> nthweekdayofmonthcontaining 4 5 wed22nd -- 2017-10-27+nthweekdayofmonthcontaining :: Int -> WeekDay -> Day -> Day nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d  = nthWeekdaySameMonth                                    | otherwise = nthWeekdayPrevMonth     where nthWeekdaySameMonth = advancetonthweekday n wd $ startofmonth d           nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth d-          + -- | Advance to nth weekday wd after given start day s-advancetonthweekday n wd s = addWeeks (n-1) . firstMatch (>=s) . iterate (addWeeks 1) $ firstweekday s-  where          +advancetonthweekday :: Int -> WeekDay -> Day -> Day+advancetonthweekday n wd s = +  maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s+  where+    err = error' "advancetonthweekday: should not happen"     addWeeks k = addDays (7 * fromIntegral k)-    firstMatch p = head . dropWhile (not . p)+    firstMatch p = headMay . dropWhile (not . p)      firstweekday = addDays (fromIntegral wd-1) . startofweek  ----------------------------------------------------------------------@@ -822,15 +837,19 @@   failIfInvalidDay d   return ("",m,d) +-- These are compared case insensitively, and should all be kept lower case.  months         = ["january","february","march","april","may","june",                   "july","august","september","october","november","december"] monthabbrevs   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] -monthIndex t = maybe 0 (+1) $ t `elemIndex` months-monIndex t   = maybe 0 (+1) $ t `elemIndex` monthabbrevs+-- | Convert a case insensitive english month name to a month number.+monthIndex name = maybe 0 (+1) $ T.toLower name `elemIndex` months +-- | Convert a case insensitive english three-letter month abbreviation to a month number.+monIndex   name = maybe 0 (+1) $ T.toLower name `elemIndex` monthabbrevs+ month :: TextParser m SmartDate month = do   m <- choice $ map (try . string') months@@ -845,9 +864,11 @@  weekday :: TextParser m Int weekday = do-  wday <- choice . map string' $ weekdays ++ weekdayabbrevs-  let i = head . catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs]-  return (i+1)+  wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)+  case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of+    (i:_) -> return (i+1)+    []    -> fail  $ "weekday: should not happen: attempted to find " <> +                      show wday <> " in " <> show (weekdays ++ weekdayabbrevs)   today,yesterday,tomorrow :: TextParser m SmartDate today     = string' "today"     >> return ("","","today")

@@ -13,7 +13,7 @@ module Hledger.Data.Journal (   -- * Parsing helpers   addMarketPrice,-  addModifierTransaction,+  addTransactionModifier,   addPeriodicTransaction,   addTransaction,   journalBalanceTransactions,@@ -68,7 +68,7 @@   journalUntieTransactions,   -- * Tests   samplejournal,-  tests_Hledger_Data_Journal,+  tests_Journal, ) where import Control.Applicative (Const(..))@@ -82,7 +82,6 @@ import qualified Data.HashTable.ST.Cuckoo as HT import Data.List import Data.List.Extra (groupSort)--- import Data.Map (findWithDefault) import Data.Maybe #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid@@ -95,15 +94,13 @@ import Data.Time.Calendar import Data.Tree import System.Time (ClockTime(TOD))-import Test.HUnit import Text.Printf import qualified Data.Map as M -import Hledger.Utils+import Hledger.Utils  import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount--- import Hledger.Data.Commodity import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.Posting@@ -138,7 +135,7 @@ -- showJournalDebug j = unlines [ --                       show j --                      ,show (jtxns j)---                      ,show (jmodifiertxns j)+--                      ,show (jtxnmodifiers j) --                      ,show (jperiodictxns j) --                      ,show $ jparsetimeclockentries j --                      ,show $ jmarketprices j@@ -166,11 +163,11 @@     ,jparsealiases              = jparsealiases              j2     -- ,jparsetransactioncount     = jparsetransactioncount     j1 +  jparsetransactioncount     j2     ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2-    ,jaccounts                  = jaccounts                  j1 <> jaccounts                  j2+    ,jdeclaredaccounts                  = jdeclaredaccounts                  j1 <> jdeclaredaccounts                  j2     ,jcommodities               = jcommodities               j1 <> jcommodities               j2     ,jinferredcommodities       = jinferredcommodities       j1 <> jinferredcommodities       j2     ,jmarketprices              = jmarketprices              j1 <> jmarketprices              j2-    ,jmodifiertxns              = jmodifiertxns              j1 <> jmodifiertxns              j2+    ,jtxnmodifiers              = jtxnmodifiers              j1 <> jtxnmodifiers              j2     ,jperiodictxns              = jperiodictxns              j1 <> jperiodictxns              j2     ,jtxns                      = jtxns                      j1 <> jtxns                      j2     ,jfinalcommentlines         = jfinalcommentlines         j2@@ -193,11 +190,11 @@   ,jparsealiases              = []   -- ,jparsetransactioncount     = 0   ,jparsetimeclockentries = []-  ,jaccounts                  = []+  ,jdeclaredaccounts                  = []   ,jcommodities               = M.fromList []   ,jinferredcommodities       = M.fromList []   ,jmarketprices              = []-  ,jmodifiertxns              = []+  ,jtxnmodifiers              = []   ,jperiodictxns              = []   ,jtxns                      = []   ,jfinalcommentlines         = ""@@ -217,8 +214,8 @@ addTransaction :: Transaction -> Journal -> Journal addTransaction t j = j { jtxns = t : jtxns j } -addModifierTransaction :: ModifierTransaction -> Journal -> Journal-addModifierTransaction mt j = j { jmodifiertxns = mt : jmodifiertxns j }+addTransactionModifier :: TransactionModifier -> Journal -> Journal+addTransactionModifier mt j = j { jtxnmodifiers = mt : jtxnmodifiers j }  addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j }@@ -259,7 +256,7 @@  -- | Sorted unique account names declared by account directives in this journal. journalAccountNamesDeclared :: Journal -> [AccountName]-journalAccountNamesDeclared = nub . sort . map fst . jaccounts+journalAccountNamesDeclared = nub . sort . jdeclaredaccounts  -- | Sorted unique account names declared by account directives or posted to -- by transactions in this journal.@@ -284,8 +281,8 @@ -- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Profit_.26_Loss_accounts>. journalProfitAndLossAccountQuery  :: Journal -> Query journalProfitAndLossAccountQuery j = Or [journalIncomeAccountQuery j-                                               ,journalExpenseAccountQuery j-                                               ]+                                        ,journalExpenseAccountQuery j+                                        ]  -- | A query for Income (Revenue) accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^(income|revenue)s?(:|$)@.@@ -301,9 +298,9 @@ -- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>. journalBalanceSheetAccountQuery  :: Journal -> Query journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j-                                              ,journalLiabilityAccountQuery j-                                              ,journalEquityAccountQuery j-                                              ]+                                       ,journalLiabilityAccountQuery j+                                       ,journalEquityAccountQuery j+                                       ]  -- | A query for Asset accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^assets?(:|$)@.@@ -496,8 +493,9 @@    journalApplyCommodityStyles $    j {jfiles        = (path,txt) : reverse fs      ,jlastreadtime = t-     ,jtxns         = reverse $ jtxns j -- NOTE: see addTransaction-     ,jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction+     ,jdeclaredaccounts = reverse $ jdeclaredaccounts j+     ,jtxns         = reverse $ jtxns j         -- NOTE: see addTransaction+     ,jtxnmodifiers = reverse $ jtxnmodifiers j -- NOTE: see addTransactionModifier      ,jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction      ,jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice      })@@ -765,8 +763,7 @@     commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]  -- | Given an ordered list of amount styles, choose a canonical style.--- That is: the style of the first, and the--- maximum precision of all.+-- That is: the style of the first, and the maximum precision of all. canonicalStyleFrom :: [AmountStyle] -> AmountStyle canonicalStyleFrom [] = amountstyle canonicalStyleFrom ss@(first:_) =@@ -881,21 +878,6 @@       pdates   = concatMap (catMaybes . map (if secondary then (Just . postingDate2) else pdate) . tpostings) ts       ts       = jtxns j --- #ifdef TESTS-test_journalDateSpan = do- "journalDateSpan" ~: do-  assertEqual "" (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))-                 (journalDateSpan True j)-  where-    j = nulljournal{jtxns = [nulltransaction{tdate = parsedate "2014/02/01"-                                            ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}]-                                            }-                            ,nulltransaction{tdate = parsedate "2014/09/01"-                                            ,tpostings = [posting{pdate2=Just (parsedate "2014/10/10")}]-                                            }-                            ]}--- #endif- -- | Apply the pivot transformation to all postings in a journal, -- replacing their account name by their value for the given field or tag. journalPivot :: Text -> Journal -> Journal@@ -1079,12 +1061,32 @@           ]          } -tests_Hledger_Data_Journal = TestList $- [-  test_journalDateSpan-  -- "query standard account types" ~:-  --  do-  --   let j = journal1-  --   journalBalanceSheetAccountNames j `is` ["assets","assets:a","equity","equity:q","equity:q:qq","liabilities","liabilities:l"]-  --   journalProfitAndLossAccountNames j `is` ["expenses","expenses:e","income","income:i"]- ]+tests_Journal = tests "Journal" [++   test "journalDateSpan" $+    journalDateSpan True nulljournal{+      jtxns = [nulltransaction{tdate = parsedate "2014/02/01"+                              ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}]+                              }+              ,nulltransaction{tdate = parsedate "2014/09/01"+                              ,tpostings = [posting{pdate2=Just (parsedate "2014/10/10")}]+                              }+              ]+      }+    `is` (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))++  ,tests "standard account type queries" $+    let+      j = samplejournal+      journalAccountNamesMatching :: Query -> Journal -> [AccountName]+      journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames+      namesfrom qfunc = journalAccountNamesMatching (qfunc j) j+    in [+       test "assets"      $ expectEq (namesfrom journalAssetAccountQuery)     ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]+      ,test "liabilities" $ expectEq (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"]+      ,test "equity"      $ expectEq (namesfrom journalEquityAccountQuery)    []+      ,test "income"      $ expectEq (namesfrom journalIncomeAccountQuery)    ["income","income:gifts","income:salary"]+      ,test "expenses"    $ expectEq (namesfrom journalExpenseAccountQuery)   ["expenses","expenses:food","expenses:supplies"]+    ]++  ]

@@ -7,15 +7,31 @@  -} -module Hledger.Data.Ledger+{-# LANGUAGE OverloadedStrings #-}++module Hledger.Data.Ledger (+   nullledger+  ,ledgerFromJournal+  ,ledgerAccountNames+  ,ledgerAccount+  ,ledgerRootAccount+  ,ledgerTopAccounts+  ,ledgerLeafAccounts+  ,ledgerAccountsMatching+  ,ledgerPostings+  ,ledgerDateSpan+  ,ledgerCommodities+  ,tests_Ledger+) where+ import qualified Data.Map as M -- import Data.Text (Text) import qualified Data.Text as T import Safe (headDef)-import Test.HUnit import Text.Printf +import Hledger.Utils.Test  import Hledger.Data.Types import Hledger.Data.Account import Hledger.Data.Journal@@ -26,7 +42,7 @@ instance Show Ledger where     show l = printf "Ledger with %d transactions, %d accounts\n" --"%s"              (length (jtxns $ ljournal l) +-              length (jmodifiertxns $ ljournal l) ++              length (jtxnmodifiers $ ljournal l) +               length (jperiodictxns $ ljournal l))              (length $ ledgerAccountNames l)              -- (showtree $ ledgerAccountNameTree l)@@ -47,7 +63,7 @@     (q',depthq)  = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q)     j'  = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude           filterJournalPostings q' j-    as  = map (accountSetCodeFrom j) $ accountsFromPostings $ journalPostings j'+    as  = accountsFromPostings $ journalPostings j'     j'' = filterJournalPostings depthq j'  -- | List a ledger's account names.@@ -89,13 +105,14 @@ ledgerCommodities :: Ledger -> [CommoditySymbol] ledgerCommodities = M.keys . jinferredcommodities . ljournal +-- tests -tests_ledgerFromJournal = [- "ledgerFromJournal" ~: do-  assertEqual "" (0) (length $ ledgerPostings $ ledgerFromJournal Any nulljournal)-  assertEqual "" (13) (length $ ledgerPostings $ ledgerFromJournal Any samplejournal)-  assertEqual "" (7) (length $ ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal)- ]+tests_Ledger = tests "Ledger" [ -tests_Hledger_Data_Ledger = TestList $-    tests_ledgerFromJournal+  tests "ledgerFromJournal" [+     (length $ ledgerPostings $ ledgerFromJournal Any nulljournal) `is` 0+    ,(length $ ledgerPostings $ ledgerFromJournal Any samplejournal) `is` 13+    ,(length $ ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) `is` 7+  ]++ ]

@@ -13,7 +13,6 @@ module Hledger.Data.MarketPrice where import qualified Data.Text as T-import Test.HUnit  import Hledger.Data.Amount import Hledger.Data.Dates@@ -28,5 +27,3 @@     , T.unpack (mpcommodity mp)     , (showAmount . setAmountPrecision maxprecision) (mpamount mp)     ]--tests_Hledger_Data_MarketPrice = TestList []

@@ -0,0 +1,243 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-|++A 'PeriodicTransaction' is a rule describing recurring transactions.++-}+module Hledger.Data.PeriodicTransaction (+    runPeriodicTransaction+  , checkPeriodicTransactionStartDate+)+where++#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+import qualified Data.Text as T+import Text.Printf++import Hledger.Data.Types+import Hledger.Data.Dates+import Hledger.Data.Amount+import Hledger.Data.Posting (post)+import Hledger.Data.Transaction+import Hledger.Utils.UTF8IOCompat (error')+-- import Hledger.Utils.Debug++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Hledger.Data.Posting+-- >>> import Hledger.Data.Journal++-- doctest helper, too much hassle to define in the comment+-- XXX duplicates some logic in periodictransactionp+_ptgen str = do+  let +    t = T.pack str+    (i,s) = parsePeriodExpr' nulldate t+  case checkPeriodicTransactionStartDate i s t of+    Just e  -> error' e+    Nothing ->+      mapM_ (putStr . showTransaction) $+        runPeriodicTransaction+          nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } +          nulldatespan+++--deriving instance Show PeriodicTransaction+-- for better pretty-printing:+instance Show PeriodicTransaction where+  show PeriodicTransaction{..} =+    printf "PeriodicTransactionPP {%s, %s, %s, %s, %s, %s, %s, %s, %s}"+      ("ptperiodexpr=" ++ show ptperiodexpr)+      ("ptinterval=" ++ show ptinterval)+      ("ptspan=" ++ show (show ptspan))+      ("ptstatus=" ++ show (show ptstatus))+      ("ptcode=" ++ show ptcode)+      ("ptdescription=" ++ show ptdescription)+      ("ptcomment=" ++ show ptcomment)+      ("pttags=" ++ show pttags)+      ("ptpostings=" ++ show ptpostings)++-- A basic human-readable rendering.+--showPeriodicTransaction t = "~ " ++ T.unpack (ptperiodexpr t) ++ "\n" ++ unlines (map show (ptpostings t))++--nullperiodictransaction is defined in Types.hs++-- | Generate transactions from 'PeriodicTransaction' within a 'DateSpan'+--+-- Note that new transactions require 'txnTieKnot' post-processing.+--+-- >>> _ptgen "monthly from 2017/1 to 2017/4"+-- 2017/01/01+--     ; recur: monthly from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017/02/01+--     ; recur: monthly from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017/03/01+--     ; recur: monthly from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "monthly from 2017/1 to 2017/5"+-- 2017/01/01+--     ; recur: monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/02/01+--     ; recur: monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/03/01+--     ; recur: monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/04/01+--     ; recur: monthly from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"+-- 2017/01/02+--     ; recur: every 2nd day of month from 2017/02 to 2017/04+--     a           $1.00+-- <BLANKLINE>+-- 2017/02/02+--     ; recur: every 2nd day of month from 2017/02 to 2017/04+--     a           $1.00+-- <BLANKLINE>+-- 2017/03/02+--     ; recur: every 2nd day of month from 2017/02 to 2017/04+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"+-- 2016/12/30+--     ; recur: every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/01/30+--     ; recur: every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/02/28+--     ; recur: every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/03/30+--     ; recur: every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+-- 2017/04/30+--     ; recur: every 30th day of month from 2017/1 to 2017/5+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"+-- 2016/12/08+--     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017/01/12+--     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017/02/09+--     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+-- 2017/03/09+--     ; recur: every 2nd Thursday of month from 2017/1 to 2017/4+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "every nov 29th from 2017 to 2019"+-- 2016/11/29+--     ; recur: every nov 29th from 2017 to 2019+--     a           $1.00+-- <BLANKLINE>+-- 2017/11/29+--     ; recur: every nov 29th from 2017 to 2019+--     a           $1.00+-- <BLANKLINE>+-- 2018/11/29+--     ; recur: every nov 29th from 2017 to 2019+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen "2017/1"+-- 2017/01/01+--     ; recur: 2017/1+--     a           $1.00+-- <BLANKLINE>+--+-- >>> _ptgen ""+-- *** Exception: failed to parse...+-- ...+--+-- >>> _ptgen "weekly from 2017"+-- *** Exception: Unable to generate transactions according to "weekly from 2017" because 2017-01-01 is not a first day of the week+--+-- >>> _ptgen "monthly from 2017/5/4"+-- *** Exception: Unable to generate transactions according to "monthly from 2017/5/4" because 2017-05-04 is not a first day of the month        +--+-- >>> _ptgen "every quarter from 2017/1/2"+-- *** Exception: Unable to generate transactions according to "every quarter from 2017/1/2" because 2017-01-02 is not a first day of the quarter        +--+-- >>> _ptgen "yearly from 2017/1/14"+-- *** Exception: Unable to generate transactions according to "yearly from 2017/1/14" because 2017-01-14 is not a first day of the year        +--+-- >>> let reportperiod="daily from 2018/01/03" in let (i,s) = parsePeriodExpr' nulldate reportperiod in runPeriodicTransaction (nullperiodictransaction{ptperiodexpr=reportperiod, ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1]}) (DateSpan (Just $ parsedate "2018-01-01") (Just $ parsedate "2018-01-03"))+-- []+--+runPeriodicTransaction :: PeriodicTransaction -> DateSpan -> [Transaction]+runPeriodicTransaction PeriodicTransaction{..} requestedspan =+    [ t{tdate=d} | (DateSpan (Just d) _) <- ptinterval `splitSpan` spantofill ]+  where+    spantofill = spanIntervalIntersect ptinterval ptspan requestedspan+    t = nulltransaction{+           tstatus      = ptstatus+          ,tcode        = ptcode+          ,tdescription = ptdescription +          ,tcomment     = (if T.null ptcomment then "\n" else ptcomment) <> "recur: " <> ptperiodexpr+          ,ttags        = ("recur", ptperiodexpr) : pttags +          ,tpostings    = ptpostings+          }++-- | Check that this date span begins at a boundary of this interval, +-- or return an explanatory error message including the provided period expression+-- (from which the span and interval are derived).+checkPeriodicTransactionStartDate :: Interval -> DateSpan -> T.Text -> Maybe String +checkPeriodicTransactionStartDate i s periodexpr = +  case (i, spanStart s) of+    (Weeks _,    Just d) -> checkStart d "week"+    (Months _,   Just d) -> checkStart d "month"+    (Quarters _, Just d) -> checkStart d "quarter"+    (Years _,    Just d) -> checkStart d "year"+    _                    -> Nothing +    where+      checkStart d x =+        let firstDate = fixSmartDate d ("","this",x) +        in   +         if d == firstDate +         then Nothing+         else Just $+          "Unable to generate transactions according to "++show (T.unpack periodexpr)+          ++" because "++show d++" is not a first day of the "++x++---- | What is the interval of this 'PeriodicTransaction's period expression, if it can be parsed ?+--periodTransactionInterval :: PeriodicTransaction -> Maybe Interval+--periodTransactionInterval pt =+--  let+--    expr = ptperiodexpr pt+--    err  = error' $ "Current date cannot be referenced in " ++ show (T.unpack expr)+--  in+--    case parsePeriodExpr err expr of+--      Left _      -> Nothing+--      Right (i,_) -> Just i

@@ -54,7 +54,7 @@   showPosting,   -- * misc.   showComment,-  tests_Hledger_Data_Posting+  tests_Posting ) where import Data.List@@ -68,16 +68,14 @@ import qualified Data.Text as T import Data.Time.Calendar import Safe-import Test.HUnit -import Hledger.Utils+import Hledger.Utils  import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName import Hledger.Data.Dates (nulldate, spanContainsDate)  -instance Show Posting where show = showPosting  nullposting, posting :: Posting nullposting = Posting@@ -293,28 +291,35 @@ aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX  -tests_Hledger_Data_Posting = TestList [+-- tests -  "accountNamePostingType" ~: do+tests_Posting = tests "Posting" [++  tests "accountNamePostingType" [     accountNamePostingType "a" `is` RegularPosting-    accountNamePostingType "(a)" `is` VirtualPosting-    accountNamePostingType "[a]" `is` BalancedVirtualPosting+    ,accountNamePostingType "(a)" `is` VirtualPosting+    ,accountNamePostingType "[a]" `is` BalancedVirtualPosting+  ] - ,"accountNameWithoutPostingType" ~: do+ ,tests "accountNameWithoutPostingType" [     accountNameWithoutPostingType "(a)" `is` "a"+  ] - ,"accountNameWithPostingType" ~: do+ ,tests "accountNameWithPostingType" [     accountNameWithPostingType VirtualPosting "[a]" `is` "(a)"+  ] - ,"joinAccountNames" ~: do+ ,tests "joinAccountNames" [     "a" `joinAccountNames` "b:c" `is` "a:b:c"-    "a" `joinAccountNames` "(b:c)" `is` "(a:b:c)"-    "[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]"-    "" `joinAccountNames` "a" `is` "a"+    ,"a" `joinAccountNames` "(b:c)" `is` "(a:b:c)"+    ,"[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]"+    ,"" `joinAccountNames` "a" `is` "a"+  ] - ,"concatAccountNames" ~: do+ ,tests "concatAccountNames" [     concatAccountNames [] `is` ""-    concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"+    ,concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"+  ]   ] 

@@ -17,7 +17,8 @@   maybestringopt,   listofstringopt,   intopt,-  maybeintopt+  maybeintopt,+  maybecharopt ) where @@ -49,6 +50,9 @@  stringopt :: String -> RawOpts -> String stringopt name = fromMaybe "" . maybestringopt name++maybecharopt :: String -> RawOpts -> Maybe Char+maybecharopt name rawopts = lookup name rawopts >>= headMay  listofstringopt :: String -> RawOpts -> [String] listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name]

@@ -2,7 +2,7 @@ -- hledger's report item fields. The formats are used by -- report-specific renderers like renderBalanceReportItem. -{-# LANGUAGE FlexibleContexts, TypeFamilies, PackageImports #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies, PackageImports #-}  module Hledger.Data.StringFormat (           parseStringFormat@@ -10,7 +10,7 @@         , StringFormat(..)         , StringFormatComponent(..)         , ReportItemField(..)-        , tests_Hledger_Data_StringFormat+        , tests_StringFormat         ) where  import Prelude ()@@ -18,12 +18,13 @@ import Numeric import Data.Char (isPrint) import Data.Maybe-import Test.HUnit+import qualified Data.Text as T import Text.Megaparsec import Text.Megaparsec.Char  import Hledger.Utils.Parse import Hledger.Utils.String (formatString)+import Hledger.Utils.Test  -- | A format specification/template to use when rendering a report line item as text. --@@ -89,7 +90,7 @@  stringformatp :: SimpleStringParser StringFormat stringformatp = do-  alignspec <- optional (try $ char '%' >> oneOf "^_,")+  alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String))   let constructor =         case alignspec of           Just '^' -> TopAligned@@ -136,47 +137,45 @@  ---------------------------------------------------------------------- -testFormat :: StringFormatComponent -> String -> String -> Assertion-testFormat fs value expected = assertEqual name expected actual-    where-        (name, actual) = case fs of-            FormatLiteral l -> ("literal", formatString False Nothing Nothing l)-            FormatField leftJustify min max _ -> ("field", formatString leftJustify min max value)--testParser :: String -> StringFormat -> Assertion-testParser s expected = case (parseStringFormat s) of-    Left  error -> assertFailure $ show error-    Right actual -> assertEqual ("Input: " ++ s) expected actual+formatStringTester fs value expected = actual `is` expected +  where+    actual = case fs of+      FormatLiteral l                   -> formatString False Nothing Nothing l+      FormatField leftJustify min max _ -> formatString leftJustify min max value -tests_Hledger_Data_StringFormat = test [ formattingTests ++ parserTests ]+tests_StringFormat = tests "StringFormat" [ -formattingTests = [-      testFormat (FormatLiteral " ")                                ""            " "-    , testFormat (FormatField False Nothing Nothing DescriptionField)    "description" "description"-    , testFormat (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"-    , testFormat (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"-    , testFormat (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"-    , testFormat (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "-    , testFormat (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "-    , testFormat (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"+   tests "formatStringHelper" [+      formatStringTester (FormatLiteral " ")                                     ""            " "+    , formatStringTester (FormatField False Nothing Nothing DescriptionField)    "description" "description"+    , formatStringTester (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"+    , formatStringTester (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"+    , formatStringTester (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"+    , formatStringTester (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "+    , formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "+    , formatStringTester (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"     ] -parserTests = [-      testParser ""                             (defaultStringFormatStyle [])-    , testParser "D"                            (defaultStringFormatStyle [FormatLiteral "D"])-    , testParser "%(date)"                      (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])-    , testParser "%(total)"                     (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField])-    , testParser "^%(total)"                    (TopAligned [FormatField False Nothing Nothing TotalField])-    , testParser "_%(total)"                    (BottomAligned [FormatField False Nothing Nothing TotalField])-    , testParser ",%(total)"                    (OneLine [FormatField False Nothing Nothing TotalField])-    , testParser "Hello %(date)!"               (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])-    , testParser "%-(date)"                     (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField])-    , testParser "%20(date)"                    (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])-    , testParser "%.10(date)"                   (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField])-    , testParser "%20.10(date)"                 (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])-    , testParser "%20(account) %.10(total)\n"   (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField-                                                , FormatLiteral " "-                                                , FormatField False Nothing (Just 10) TotalField-                                                , FormatLiteral "\n"-                                                ])-  ]+  ,tests "parseStringFormat" $+    let s `gives` expected = test (T.pack s) $ parseStringFormat s `is` Right expected+    in [+      ""                           `gives` (defaultStringFormatStyle [])+    , "D"                          `gives` (defaultStringFormatStyle [FormatLiteral "D"])+    , "%(date)"                    `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])+    , "%(total)"                   `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField])+    -- TODO+    -- , "^%(total)"                  `gives` (TopAligned [FormatField False Nothing Nothing TotalField])+    -- , "_%(total)"                  `gives` (BottomAligned [FormatField False Nothing Nothing TotalField])+    -- , ",%(total)"                  `gives` (OneLine [FormatField False Nothing Nothing TotalField])+    , "Hello %(date)!"             `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])+    , "%-(date)"                   `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField])+    , "%20(date)"                  `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])+    , "%.10(date)"                 `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField])+    , "%20.10(date)"               `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])+    , "%20(account) %.10(total)"   `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField+                                                                     ,FormatLiteral " "+                                                                     ,FormatField False Nothing (Just 10) TotalField+                                                                     ])+    , test "newline not parsed" $ expectLeft $ parseStringFormat "\n"+    ]+ ]

@@ -8,8 +8,12 @@  {-# LANGUAGE CPP, OverloadedStrings #-} -module Hledger.Data.Timeclock+module Hledger.Data.Timeclock (+   timeclockEntriesToTransactions+  ,tests_Timeclock+) where+ import Data.Maybe -- import Data.Text (Text) import qualified Data.Text as T@@ -20,10 +24,9 @@ #if !(MIN_VERSION_time(1,5,0)) import System.Locale (defaultTimeLocale) #endif-import Test.HUnit import Text.Printf -import Hledger.Utils+import Hledger.Utils  import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Amount@@ -108,38 +111,35 @@       ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]  -tests_Hledger_Data_Timeclock = TestList [+-- tests -   "timeclockEntriesToTransactions" ~: do-     today <- getCurrentDay-     now' <- getCurrentTime-     tz <- getCurrentTimeZone-     let now = utcToLocalTime tz now'-         nowstr = showtime now-         yesterday = prevday today-         clockin = TimeclockEntry nullsourcepos In-         mktime d = LocalTime d . fromMaybe midnight .+tests_Timeclock = tests "Timeclock" [+  do+   today <- io getCurrentDay+   now' <- io getCurrentTime+   tz <- io getCurrentTimeZone+   let now = utcToLocalTime tz now'+       nowstr = showtime now+       yesterday = prevday today+       clockin = TimeclockEntry nullsourcepos In+       mktime d = LocalTime d . fromMaybe midnight . #if MIN_VERSION_time(1,5,0)-                    parseTimeM True defaultTimeLocale "%H:%M:%S"+                  parseTimeM True defaultTimeLocale "%H:%M:%S" #else-                    parseTime defaultTimeLocale "%H:%M:%S"+                  parseTime defaultTimeLocale "%H:%M:%S" #endif-         showtime = formatTime defaultTimeLocale "%H:%M"-         assertEntriesGiveStrings name es ss = assertEqual name ss (map (T.unpack . tdescription) $ timeclockEntriesToTransactions now es)--     assertEntriesGiveStrings "started yesterday, split session at midnight"-                                  [clockin (mktime yesterday "23:00:00") "" ""]-                                  ["23:00-23:59","00:00-"++nowstr]-     assertEntriesGiveStrings "split multi-day sessions at each midnight"-                                  [clockin (mktime (addDays (-2) today) "23:00:00") "" ""]-                                  ["23:00-23:59","00:00-23:59","00:00-"++nowstr]-     assertEntriesGiveStrings "auto-clock-out if needed"-                                  [clockin (mktime today "00:00:00") "" ""]-                                  ["00:00-"++nowstr]-     let future = utcToLocalTime tz $ addUTCTime 100 now'-         futurestr = showtime future-     assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future"-                                  [clockin future "" ""]-                                  [printf "%s-%s" futurestr futurestr]-+       showtime = formatTime defaultTimeLocale "%H:%M"+       txndescs = map (T.unpack . tdescription) . timeclockEntriesToTransactions now +       future = utcToLocalTime tz $ addUTCTime 100 now'+       futurestr = showtime future+   tests "timeclockEntriesToTransactions" [ +     test "started yesterday, split session at midnight" $+      txndescs [clockin (mktime yesterday "23:00:00") "" ""] `is` ["23:00-23:59","00:00-"++nowstr]+     ,test "split multi-day sessions at each midnight" $+      txndescs [clockin (mktime (addDays (-2) today) "23:00:00") "" ""] `is `["23:00-23:59","00:00-23:59","00:00-"++nowstr]+     ,test "auto-clock-out if needed" $+      txndescs [clockin (mktime today "00:00:00") "" ""] `is` ["00:00-"++nowstr]+     ,test "use the clockin time for auto-clockout if it's in the future" $+      txndescs [clockin future "" ""] `is` [printf "%s-%s" futurestr futurestr]+     ]  ]

@@ -42,8 +42,8 @@   sourceFilePath,   sourceFirstLine,   showGenericSourcePos,-  -- * misc.-  tests_Hledger_Data_Transaction+  -- * tests+  tests_Transaction ) where import Data.List@@ -53,24 +53,15 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar-import Test.HUnit import Text.Printf import qualified Data.Map as Map -import Hledger.Utils+import Hledger.Utils  import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Amount -instance Show Transaction where show = showTransactionUnelided--instance Show ModifierTransaction where-    show t = "= " ++ T.unpack (mtvalueexpr t) ++ "\n" ++ unlines (map show (mtpostings t))--instance Show PeriodicTransaction where-    show t = "~ " ++ T.unpack (ptperiodexpr t) ++ "\n" ++ unlines (map show (ptpostings t))- sourceFilePath :: GenericSourcePos -> FilePath sourceFilePath = \case     GenericSourcePos fp _ _ -> fp@@ -87,7 +78,7 @@     JournalSourcePos fp (line, line') -> show fp ++ " (lines " ++ show line ++ "-" ++ show line' ++ ")"  nullsourcepos :: GenericSourcePos-nullsourcepos = GenericSourcePos "" 1 1+nullsourcepos = JournalSourcePos "" (1,1)  nulltransaction :: Transaction nulltransaction = Transaction {@@ -126,40 +117,6 @@ showTransactionUnelided :: Transaction -> String showTransactionUnelided = showTransactionHelper False False -tests_showTransactionUnelided = [-   "showTransactionUnelided" ~: do-    let t `gives` s = assertEqual "" s (showTransactionUnelided t)-    nulltransaction `gives` "0000/01/01\n\n"-    nulltransaction{-      tdate=parsedate "2012/05/14",-      tdate2=Just $ parsedate "2012/05/15",-      tstatus=Unmarked,-      tcode="code",-      tdescription="desc",-      tcomment="tcomment1\ntcomment2\n",-      ttags=[("ttag1","val1")],-      tpostings=[-        nullposting{-          pstatus=Cleared,-          paccount="a",-          pamount=Mixed [usd 1, hrs 2],-          pcomment="\npcomment2\n",-          ptype=RegularPosting,-          ptags=[("ptag1","val1"),("ptag2","val2")]-          }-       ]-      }-      `gives` unlines [-      "2012/05/14=2012/05/15 (code) desc    ; tcomment1",-      "    ; tcomment2",-      "    * a         $1.00",-      "    ; pcomment2",-      "    * a         2.00h",-      "    ; pcomment2",-      ""-      ]- ]- showTransactionUnelidedOneLineAmounts :: Transaction -> String showTransactionUnelidedOneLineAmounts = showTransactionHelper False True @@ -252,60 +209,6 @@     ps | Just t <- ptransaction p = tpostings t        | otherwise = [p] -tests_postingAsLines = [-   "postingAsLines" ~: do-    let p `gives` ls = assertEqual (show p) ls (postingAsLines False False [p] p)-    posting `gives` [""]-    posting{-      pstatus=Cleared,-      paccount="a",-      pamount=Mixed [usd 1, hrs 2],-      pcomment="pcomment1\npcomment2\n  tag3: val3  \n",-      ptype=RegularPosting,-      ptags=[("ptag1","val1"),("ptag2","val2")]-      }-     `gives` [-      "    * a         $1.00    ; pcomment1",-      "    ; pcomment2",-      "    ;   tag3: val3  ",-      "    * a         2.00h    ; pcomment1",-      "    ; pcomment2",-      "    ;   tag3: val3  "-      ]- ]--tests_inference = [-    "inferBalancingAmount" ~: do-    let p `gives` p' = assertEqual (show p) (Right p') $ inferTransaction p-        inferTransaction :: Transaction -> Either String Transaction-        inferTransaction = runIdentity . runExceptT . inferBalancingAmount (\_ _ -> return ()) Map.empty-    nulltransaction `gives` nulltransaction-    nulltransaction{-      tpostings=[-        "a" `post` usd (-5),-        "b" `post` missingamt-      ]}-      `gives`-      nulltransaction{-        tpostings=[-          "a" `post` usd (-5),-          "b" `post` usd 5-        ]}-    nulltransaction{-      tpostings=[-        "a" `post` usd (-5),-        "b" `post` (eur 3 @@ usd 4),-        "c" `post` missingamt-      ]}-      `gives`-      nulltransaction{-        tpostings=[-          "a" `post` usd (-5),-          "b" `post` (eur 3 @@ usd 4),-          "c" `post` usd 1-        ]}- ]- indent :: String -> String indent = ("    "++) @@ -537,178 +440,273 @@ postingSetTransaction :: Transaction -> Posting -> Posting postingSetTransaction t p = p{ptransaction=Just t} -tests_Hledger_Data_Transaction = TestList $ concat [-  tests_postingAsLines,-  tests_showTransactionUnelided,-  tests_inference,-  [-  "showTransaction" ~: do-     assertEqual "show a balanced transaction, eliding last amount"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries          $47.18"-        ,"    assets:checking"-        ,""-        ])-       (let t = Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []+-- tests++tests_Transaction = tests "Transaction" [++  tests "showTransactionUnelided" [+    showTransactionUnelided nulltransaction `is` "0000/01/01\n\n"+    ,showTransactionUnelided nulltransaction{+      tdate=parsedate "2012/05/14",+      tdate2=Just $ parsedate "2012/05/15",+      tstatus=Unmarked,+      tcode="code",+      tdescription="desc",+      tcomment="tcomment1\ntcomment2\n",+      ttags=[("ttag1","val1")],+      tpostings=[+        nullposting{+          pstatus=Cleared,+          paccount="a",+          pamount=Mixed [usd 1, hrs 2],+          pcomment="\npcomment2\n",+          ptype=RegularPosting,+          ptags=[("ptag1","val1"),("ptag2","val2")]+          }+       ]+      }+      `is` unlines [+      "2012/05/14=2012/05/15 (code) desc    ; tcomment1",+      "    ; tcomment2",+      "    * a         $1.00",+      "    ; pcomment2",+      "    * a         2.00h",+      "    ; pcomment2",+      ""+      ]+    ]++  ,tests "postingAsLines" [+    postingAsLines False False [posting] posting `is` [""]+    ,let p = posting{+      pstatus=Cleared,+      paccount="a",+      pamount=Mixed [usd 1, hrs 2],+      pcomment="pcomment1\npcomment2\n  tag3: val3  \n",+      ptype=RegularPosting,+      ptags=[("ptag1","val1"),("ptag2","val2")]+      }+     in postingAsLines False False [p] p `is`+      [+      "    * a         $1.00    ; pcomment1",+      "    ; pcomment2",+      "    ;   tag3: val3  ",+      "    * a         2.00h    ; pcomment1",+      "    ; pcomment2",+      "    ;   tag3: val3  "+      ]+    ]++  ,do+    let inferTransaction :: Transaction -> Either String Transaction+        inferTransaction = runIdentity . runExceptT . inferBalancingAmount (\_ _ -> return ()) Map.empty+    tests "inferBalancingAmount" [ +       inferTransaction nulltransaction `is` Right nulltransaction+      ,inferTransaction nulltransaction{+        tpostings=[+          "a" `post` usd (-5),+          "b" `post` missingamt+        ]}+      `is` Right+        nulltransaction{+          tpostings=[+            "a" `post` usd (-5),+            "b" `post` usd 5+          ]}+      ,inferTransaction nulltransaction{+        tpostings=[+          "a" `post` usd (-5),+          "b" `post` (eur 3 @@ usd 4),+          "c" `post` missingamt+        ]}+      `is` Right+        nulltransaction{+          tpostings=[+            "a" `post` usd (-5),+            "b" `post` (eur 3 @@ usd 4),+            "c" `post` usd 1+          ]}+      ]++  ,tests "showTransaction" [+     test "show a balanced transaction, eliding last amount" $+       let t = Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []                 [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)+       in +        showTransaction t+         `is`+         unlines+          ["2007/01/28 coopportunity"+          ,"    expenses:food:groceries          $47.18"+          ,"    assets:checking"+          ,""+          ]+    ] -  ,"showTransaction" ~: do-     assertEqual "show a balanced transaction, no eliding"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries          $47.18"-        ,"    assets:checking                 $-47.18"-        ,""-        ])+  ,tests "showTransaction" [+     test "show a balanced transaction, no eliding" $        (let t = Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []                 [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)--     -- document some cases that arise in debug/testing:-  ,"showTransaction" ~: do-     assertEqual "show an unbalanced transaction, should not elide"+       `is`        (unlines         ["2007/01/28 coopportunity"         ,"    expenses:food:groceries          $47.18"-        ,"    assets:checking                 $-47.19"+        ,"    assets:checking                 $-47.18"         ,""         ])++     -- document some cases that arise in debug/testing:+    ,test "show an unbalanced transaction, should not elide" $        (showTransaction         (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.19)]}          ] ""))--  ,"showTransaction" ~: do-     assertEqual "show an unbalanced transaction with one posting, should not elide"+       `is`        (unlines         ["2007/01/28 coopportunity"         ,"    expenses:food:groceries          $47.18"+        ,"    assets:checking                 $-47.19"         ,""         ])++    ,test "show an unbalanced transaction with one posting, should not elide" $        (showTransaction         (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ] ""))--  ,"showTransaction" ~: do-     assertEqual "show a transaction with one posting and a missing amount"+       `is`        (unlines         ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries"+        ,"    expenses:food:groceries          $47.18"         ,""         ])++    ,test "show a transaction with one posting and a missing amount" $        (showTransaction         (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=missingmixedamt}          ] ""))--  ,"showTransaction" ~: do-     assertEqual "show a transaction with a priced commodityless amount"+       `is`        (unlines-        ["2010/01/01 x"-        ,"    a          1 @ $2"-        ,"    b"+        ["2007/01/28 coopportunity"+        ,"    expenses:food:groceries"         ,""         ])++    ,test "show a transaction with a priced commodityless amount" $        (showTransaction         (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2010/01/01") Nothing Unmarked "" "x" "" []          [posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}          ,posting{paccount="b", pamount= missingmixedamt}          ] ""))+       `is`+       (unlines+        ["2010/01/01 x"+        ,"    a          1 @ $2"+        ,"    b"+        ,""+        ])+    ] -  ,"balanceTransaction" ~: do-     assertBool "detect unbalanced entry, sign error"-                    (isLeft $ balanceTransaction Nothing+  ,tests "balanceTransaction" [+     test "detect unbalanced entry, sign error" $+                    (expectLeft $ balanceTransaction Nothing                            (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "test" "" []                             [posting{paccount="a", pamount=Mixed [usd 1]}                             ,posting{paccount="b", pamount=Mixed [usd 1]}                             ] "")) -     assertBool "detect unbalanced entry, multiple missing amounts"-                    (isLeft $ balanceTransaction Nothing+    ,test "detect unbalanced entry, multiple missing amounts" $+                    (expectLeft $ balanceTransaction Nothing                            (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "test" "" []                             [posting{paccount="a", pamount=missingmixedamt}                             ,posting{paccount="b", pamount=missingmixedamt}                             ] "")) -     let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "" "" []-                           [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"-                     (Mixed [usd (-1)])-                     (case e of-                        Right e' -> (pamount $ last $ tpostings e')-                        Left _ -> error' "should not happen")+    ,test "one missing amount is inferred" $+         (pamount . last . tpostings <$> balanceTransaction+           Nothing+           (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "" "" []+             [posting{paccount="a", pamount=Mixed [usd 1]}+             ,posting{paccount="b", pamount=missingmixedamt}+             ] ""))+         `is` Right (Mixed [usd (-1)]) -     let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Unmarked "" "" "" []-                           [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"-                     (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)])-                     (case e of-                        Right e' -> (pamount $ head $ tpostings e')-                        Left _ -> error' "should not happen")+    ,test "conversion price is inferred" $+         (pamount . head . tpostings <$> balanceTransaction+           Nothing+           (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Unmarked "" "" "" []+             [posting{paccount="a", pamount=Mixed [usd 1.35]}+             ,posting{paccount="b", pamount=Mixed [eur (-1)]}+             ] ""))+         `is` Right (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)]) -     assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $+    ,test "balanceTransaction balances based on cost if there are unit prices" $+       expectRight $        balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Unmarked "" "" "" []                            [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 $+    ,test "balanceTransaction balances based on cost if there are total prices" $+       expectRight $        balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Unmarked "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1    @@ eur 1]}                            ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]}-                           ] ""))+                           ] "")+  ] -  ,"isTransactionBalanced" ~: do-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}-             ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}+  ,tests "isTransactionBalanced" [+     test "detect balanced" $ expect $+       isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}+             ,posting{paccount="c", pamount=Mixed [usd (-1.00)]}              ] ""-     assertBool "detect balanced" (isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}-             ,posting{paccount="c", pamount=Mixed [usd (-1.01)], ptransaction=Just t}+     +    ,test "detect unbalanced" $ expect $+       not $ isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}+             ,posting{paccount="c", pamount=Mixed [usd (-1.01)]}              ] ""-     assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}+     +    ,test "detect unbalanced, one posting" $ expect $+       not $ isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}              ] ""-     assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t}+     +    ,test "one zero posting is considered balanced for now" $ expect $+       isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 0]}              ] ""-     assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [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}+     +    ,test "virtual postings don't need to balance" $ expect $+       isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}+             ,posting{paccount="c", pamount=Mixed [usd (-1.00)]}+             ,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting}              ] ""-     assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [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}+     +    ,test "balanced virtual postings need to balance among themselves" $ expect $+       not $ isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}+             ,posting{paccount="c", pamount=Mixed [usd (-1.00)]}+             ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting}              ] ""-     assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)-     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []-             [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}+     +    ,test "balanced virtual postings need to balance among themselves (2)" $ expect $+       isTransactionBalanced Nothing $ Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Unmarked "" "a" "" []+             [posting{paccount="b", pamount=Mixed [usd 1.00]}+             ,posting{paccount="c", pamount=Mixed [usd (-1.00)]}+             ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting}+             ,posting{paccount="3", pamount=Mixed [usd (-100)], ptype=BalancedVirtualPosting}              ] ""-     assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)+     +  ] -  ]]+ ]

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-|++A 'TransactionModifier' is a rule that modifies certain 'Transaction's,+typically adding automated postings to them. ++-}+module Hledger.Data.TransactionModifier (+    transactionModifierToFunction+)+where++import Data.Maybe+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+import qualified Data.Text as T+import Data.Time.Calendar+import Hledger.Data.Types+import Hledger.Data.Dates+import Hledger.Data.Amount+import Hledger.Data.Transaction+import Hledger.Query+import Hledger.Utils.UTF8IOCompat (error')+-- import Hledger.Utils.Debug++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Hledger.Data.Posting+-- >>> import Hledger.Data.Transaction+-- >>> import Hledger.Data.Journal++-- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,+-- which applies the modification(s) specified by the TransactionModifier.+-- Currently this means adding automated postings when certain other postings are present.+-- The postings of the transformed transaction will reference it in the usual +-- way (ie, 'txnTieKnot' is called).+--+-- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}+-- 0000/01/01+--     ping           $1.00+--     pong           $2.00+-- <BLANKLINE>+-- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "miss" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}+-- 0000/01/01+--     ping           $1.00+-- <BLANKLINE>+-- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "ping" ["pong" `post` amount{amultiplier=True, aquantity=3}]) nulltransaction{tpostings=["ping" `post` usd 2]}+-- 0000/01/01+--     ping           $2.00+--     pong           $6.00+-- <BLANKLINE>+--+transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction)+transactionModifierToFunction mt = +  \t@(tpostings -> ps) -> txnTieKnot t{ tpostings=generatePostings ps } -- TODO add modifier txn comment/tags ?+  where+    q = simplifyQuery $ tmParseQuery mt (error' "a transaction modifier's query cannot depend on current date")+    mods = map tmPostingToFunction $ tmpostings mt+    generatePostings ps = [p' | p <- ps+                              , p' <- if q `matchesPosting` p then p:[ m p | m <- mods] else [p]]+    +-- | Parse the 'Query' from a 'TransactionModifier's 'tmquerytxt', +-- and return it as a function requiring the current date. +--+-- >>> tmParseQuery (TransactionModifier "" []) undefined+-- Any+-- >>> tmParseQuery (TransactionModifier "ping" []) undefined+-- Acct "ping"+-- >>> tmParseQuery (TransactionModifier "date:2016" []) undefined+-- Date (DateSpan 2016)+-- >>> tmParseQuery (TransactionModifier "date:today" []) (read "2017-01-01")+-- Date (DateSpan 2017/01/01)+tmParseQuery :: TransactionModifier -> (Day -> Query)+tmParseQuery mt = fst . flip parseQuery (tmquerytxt mt)++---- | 'DateSpan' of all dates mentioned in 'Journal'+----+---- >>> jdatespan nulljournal+---- DateSpan -+---- >>> jdatespan nulljournal{jtxns=[nulltransaction{tdate=read "2016-01-01"}] }+---- DateSpan 2016/01/01+---- >>> jdatespan nulljournal{jtxns=[nulltransaction{tdate=read "2016-01-01", tpostings=[nullposting{pdate=Just $ read "2016-02-01"}]}] }+---- DateSpan 2016/01/01-2016/02/01+--jdatespan :: Journal -> DateSpan+--jdatespan j+--        | null dates = nulldatespan+--        | otherwise = DateSpan (Just $ minimum dates) (Just $ 1 `addDays` maximum dates)+--    where+--        dates = concatMap tdates $ jtxns j++---- | 'DateSpan' of all dates mentioned in 'Transaction'+----+---- >>> tdates nulltransaction+---- [0000-01-01]+--tdates :: Transaction -> [Day]+--tdates t = tdate t : concatMap pdates (tpostings t) ++ maybeToList (tdate2 t) where+--    pdates p = catMaybes [pdate p, pdate2 p]++postingScale :: Posting -> Maybe Quantity+postingScale p =+    case amounts $ pamount p of+        [a] | amultiplier a -> Just $ aquantity a+        _ -> Nothing++-- | Converts a 'TransactionModifier''s posting to a 'Posting'-generating function,+-- which will be used to make a new posting based on the old one (an "automated posting").+tmPostingToFunction :: Posting -> (Posting -> Posting)+tmPostingToFunction p' = +  \p -> renderPostingCommentDates $ p'+      { pdate = pdate p+      , pdate2 = pdate2 p+      , pamount = amount' p+      }+  where+    amount' = case postingScale p' of+        Nothing -> const $ pamount p'+        Just n -> \p -> withAmountType (head $ amounts $ pamount p') $ pamount p `divideMixedAmount` (1/n)+    withAmountType amount (Mixed as) = case acommodity amount of+        "" -> Mixed as+        c -> Mixed [a{acommodity = c, astyle = astyle amount, aprice = aprice amount} | a <- as]++renderPostingCommentDates :: Posting -> Posting+renderPostingCommentDates p = p { pcomment = comment' }+    where+        datesComment = T.concat $ catMaybes [T.pack . showDate <$> pdate p, ("=" <>) . T.pack . showDate <$> pdate2 p]+        comment'+            | T.null datesComment = pcomment p+            | otherwise = T.intercalate "\n" $ filter (not . T.null) [T.strip $ pcomment p, "[" <> datesComment <> "]"]

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-|  Most data types are defined here to avoid import cycles.@@ -25,13 +26,19 @@ import Data.Data import Data.Decimal import Data.Default+import Data.List (intercalate) import Text.Blaze (ToMarkup(..))+--XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html +--Note: You should use Data.Map.Strict instead of this module if:+--You will eventually need all the values stored.+--The stored values don't represent large virtual data structures to be lazily computed. import qualified Data.Map as M import Data.Text (Text) -- import qualified Data.Text as T import Data.Time.Calendar import Data.Time.LocalTime import System.Time (ClockTime(..))+import Text.Printf  import Hledger.Utils.Regex @@ -126,7 +133,8 @@  -- | An amount's price (none, per unit, or total) in another commodity. -- Note the price should be a positive number, although this is not enforced.-data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data,Generic)+data Price = NoPrice | UnitPrice Amount | TotalPrice Amount +  deriving (Eq,Ord,Typeable,Data,Generic,Show)  instance NFData Price @@ -137,10 +145,19 @@       asprecision       :: !Int,                 -- ^ number of digits displayed after the decimal point       asdecimalpoint    :: Maybe Char,           -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default"       asdigitgroups     :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any-} deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)+} deriving (Eq,Ord,Read,Typeable,Data,Generic)  instance NFData AmountStyle +instance Show AmountStyle where+  show AmountStyle{..} =+    printf "AmountStylePP \"%s %s %s %s %s..\""+    (show ascommodityside)+    (show ascommodityspaced)+    (show asprecision)+    (show asdecimalpoint)+    (show asdigitgroups)+ -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to -- separate groups (comma or period, whichever is not used as decimal@@ -166,12 +183,12 @@       aquantity   :: Quantity,       aprice      :: Price,           -- ^ the (fixed) price for this amount, if any       astyle      :: AmountStyle,-      amultiplier :: Bool             -- ^ amount is a multipier for AutoTransactions-    } deriving (Eq,Ord,Typeable,Data,Generic)+      amultiplier :: Bool             -- ^ amount is a multipier used in TransactionModifier postings+    } deriving (Eq,Ord,Typeable,Data,Generic,Show)  instance NFData Amount -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic)+newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic,Show)  instance NFData MixedAmount @@ -217,10 +234,27 @@ instance NFData Posting  -- The equality test for postings ignores the parent transaction's--- identity, to avoid infinite loops.+-- identity, to avoid recuring ad infinitum.+-- XXX could check that it's Just or Nothing. instance Eq Posting where     (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _ _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _ _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2 +-- | Posting's show instance elides the parent transaction so as not to recurse forever.+instance Show Posting where+  show Posting{..} = "PostingPP {" ++ intercalate ", " [+     ("pdate="             ++ show (show pdate))+    ,("pdate2="            ++ show (show pdate2))+    ,("pstatus="           ++ show (show pstatus))+    ,("paccount="          ++ show paccount)+    ,("pamount="           ++ show pamount)+    ,("pcomment="          ++ show pcomment)+    ,("ptype="             ++ show ptype)+    ,("ptags="             ++ show ptags)+    ,("pbalanceassertion=" ++ show pbalanceassertion)+    ,("ptransaction="      ++ show (const "<txn>" <$> ptransaction))+    ,("porigin="           ++ show porigin)+    ] ++ "}"+ -- TODO: needs renaming, or removal if no longer needed. See also TextPosition in Hledger.UI.Editor -- | The position of parse errors (eg), like parsec's SourcePos but generic. data GenericSourcePos = GenericSourcePos FilePath Int Int    -- ^ file path, 1-based line number and 1-based column number.@@ -245,18 +279,23 @@       ttags                    :: [Tag],     -- ^ tag names and values, extracted from the comment       tpostings                :: [Posting], -- ^ this transaction's postings       tpreceding_comment_lines :: Text       -- ^ any comment lines immediately preceding this transaction-    } deriving (Eq,Typeable,Data,Generic)+    } deriving (Eq,Typeable,Data,Generic,Show)  instance NFData Transaction -data ModifierTransaction = ModifierTransaction {-      mtvalueexpr :: Text,-      mtpostings  :: [Posting]-    } deriving (Eq,Typeable,Data,Generic)+data TransactionModifier = TransactionModifier {+      tmquerytxt :: Text,+      tmpostings :: [Posting]+    } deriving (Eq,Typeable,Data,Generic,Show) -instance NFData ModifierTransaction+instance NFData TransactionModifier --- ^ A periodic transaction rule, describing a transaction that recurs.+nulltransactionmodifier = TransactionModifier{+  tmquerytxt = ""+ ,tmpostings = []+}++-- | A periodic transaction rule, describing a transaction that recurs. data PeriodicTransaction = PeriodicTransaction {       ptperiodexpr   :: Text,     -- ^ the period expression as written       ptinterval     :: Interval, -- ^ the interval at which this transaction recurs @@ -268,7 +307,7 @@       ptcomment      :: Text,       pttags         :: [Tag],       ptpostings     :: [Posting]-    } deriving (Eq,Typeable,Data,Generic)+    } deriving (Eq,Typeable,Data,Generic) -- , Show in PeriodicTransaction.hs  nullperiodictransaction = PeriodicTransaction{       ptperiodexpr   = ""@@ -302,7 +341,7 @@       mpdate      :: Day,       mpcommodity :: CommoditySymbol,       mpamount    :: Amount-    } deriving (Eq,Ord,Typeable,Data,Generic) -- & Show (in Amount.hs)+    } deriving (Eq,Ord,Typeable,Data,Generic) -- , Show in Amount.hs  instance NFData MarketPrice @@ -323,13 +362,13 @@   ,jparseparentaccounts   :: [AccountName]                         -- ^ the current stack of parent account names, specified by apply account directives   ,jparsealiases          :: [AccountAlias]                        -- ^ the current account name aliases in effect, specified by alias directives (& options ?)   -- ,jparsetransactioncount :: Integer                               -- ^ the current count of transactions parsed so far (only journal format txns, currently)-  ,jparsetimeclockentries :: [TimeclockEntry]                   -- ^ timeclock sessions which have not been clocked out+  ,jparsetimeclockentries :: [TimeclockEntry]                       -- ^ timeclock sessions which have not been clocked out   -- principal data-  ,jaccounts              :: [(AccountName, Maybe AccountCode)]     -- ^ accounts that have been declared by account directives+  ,jdeclaredaccounts      :: [AccountName]                          -- ^ Accounts declared by account directives, in parse order (after journal finalisation)    ,jcommodities           :: M.Map CommoditySymbol Commodity        -- ^ commodities and formats declared by commodity directives-  ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle      -- ^ commodities and formats inferred from journal amounts  XXX misnamed+  ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle      -- ^ commodities and formats inferred from journal amounts  TODO misnamed - jusedstyles   ,jmarketprices          :: [MarketPrice]-  ,jmodifiertxns          :: [ModifierTransaction]+  ,jtxnmodifiers          :: [TransactionModifier]   ,jperiodictxns          :: [PeriodicTransaction]   ,jtxns                  :: [Transaction]   ,jfinalcommentlines     :: Text                                   -- ^ any final trailing comments in the (main) journal file@@ -357,7 +396,7 @@ -- which let you walk up or down the account tree. data Account = Account {   aname                     :: AccountName,   -- ^ this account's full name-  acode                     :: Maybe AccountCode,   -- ^ this account's numeric code, if any (not always set) +  adeclarationorder         :: Maybe Int  ,   -- ^ the relative position of this account's account directive, if any. Normally a natural number.    aebalance                 :: MixedAmount,   -- ^ this account's balance, excluding subaccounts   asubs                     :: [Account],     -- ^ sub-accounts   anumpostings              :: Int,           -- ^ number of postings to this account

@@ -19,6 +19,7 @@   -- * accessors   queryIsNull,   queryIsAcct,+  queryIsAmt,   queryIsDepth,   queryIsDate,   queryIsDate2,@@ -41,11 +42,14 @@   matchesAccount,   matchesMixedAmount,   matchesAmount,+  matchesCommodity,+  matchesMarketPrice,   words'',   -- * tests-  tests_Hledger_Query+  tests_Query ) where+ import Data.Data import Data.Either import Data.List@@ -53,18 +57,16 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif--- import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar import Safe (readDef, headDef)-import Test.HUnit import Text.Megaparsec import Text.Megaparsec.Char  import Hledger.Utils hiding (words') import Hledger.Data.Types import Hledger.Data.AccountName-import Hledger.Data.Amount (amount, nullamt, usd)+import Hledger.Data.Amount (nullamt, usd) import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction@@ -115,6 +117,11 @@   show (Depth n)     = "Depth "  ++ show n   show (Tag s ms)    = "Tag "    ++ show s ++ " (" ++ show ms ++ ")" +-- | A more expressive Ord, used for amt: queries. The Abs* variants+-- compare with the absolute value of a number, ignoring sign.+data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq+ deriving (Show,Eq,Data,Typeable)+ -- | A query option changes a query's/report's behaviour and output in some way. data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account               | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register@@ -170,17 +177,6 @@     (statuspats, otherpats) = partition queryIsStatus pats''     q = simplifyQuery $ And $ [Or acctpats, Or descpats, Or statuspats] ++ otherpats -tests_parseQuery = [-  "parseQuery" ~: do-    let d = nulldate -- parsedate "2011/1/1"-    parseQuery d "acct:'expenses:autres d\233penses' desc:b" `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])-    parseQuery d "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"])-    parseQuery d "inacct:a inacct:b" `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])-    parseQuery d "desc:'x x'" `is` (Desc "x x", [])-    parseQuery d "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], [])-    parseQuery d "\"" `is` (Acct "\"", [])- ]- -- XXX -- | Quote-and-prefix-aware version of words - don't split on spaces which -- are inside quotes, including quotes which may have one of the specified@@ -207,19 +203,6 @@       pattern :: SimpleTextParser T.Text       pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char])) -tests_words'' = [-   "words''" ~: do-    assertEqual "1" ["a","b"]        (words'' [] "a b")-    assertEqual "2" ["a b"]          (words'' [] "'a b'")-    assertEqual "3" ["not:a","b"]    (words'' [] "not:a b")-    assertEqual "4" ["not:a b"]    (words'' [] "not:'a b'")-    assertEqual "5" ["not:a b"]    (words'' [] "'not:a b'")-    assertEqual "6" ["not:desc:a b"]    (words'' ["desc:"] "not:desc:'a b'")-    let s `gives` r = assertEqual "" r (words'' prefixes s)-    "\"acct:expenses:autres d\233penses\"" `gives` ["acct:expenses:autres d\233penses"]-    "\"" `gives` ["\""]- ]- -- XXX -- keep synced with patterns below, excluding "not" prefixes :: [T.Text]@@ -291,36 +274,7 @@ parseQueryTerm _ "" = Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s -tests_parseQueryTerm = [-  "parseQueryTerm" ~: do-    let s `gives` r = parseQueryTerm nulldate s `is` r-    "a" `gives` (Left $ Acct "a")-    "acct:expenses:autres d\233penses" `gives` (Left $ Acct "expenses:autres d\233penses")-    "not:desc:a b" `gives` (Left $ Not $ Desc "a b")-    "status:1" `gives` (Left $ StatusQ Cleared)-    "status:*" `gives` (Left $ StatusQ Cleared)-    "status:!" `gives` (Left $ StatusQ Pending)-    "status:0" `gives` (Left $ StatusQ Unmarked)-    "status:" `gives` (Left $ StatusQ Unmarked)-    "payee:x" `gives` (Left $ Tag "payee" (Just "x"))-    "note:x" `gives` (Left $ Tag "note" (Just "x"))-    "real:1" `gives` (Left $ Real True)-    "date:2008" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))-    "date:from 2012/5/17" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)-    "date:20180101-201804" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2018/01/01") (Just $ parsedate "2018/04/01"))-    "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)- ]---data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq- deriving (Show,Eq,Data,Typeable)---- can fail+-- | Parse what comes after amt: . parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity) parseAmountQueryTerm s' =   case s' of@@ -356,18 +310,6 @@   where     err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s' -tests_parseAmountQueryTerm = [-  "parseAmountQueryTerm" ~: do-    let s `gives` r = parseAmountQueryTerm s `is` r-    "<0" `gives` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false-    ">0" `gives` (Gt,0) -- special case for convenience and consistency with above-    ">10000.10" `gives` (AbsGt,10000.1)-    "=0.23" `gives` (AbsEq,0.23)-    "0.23" `gives` (AbsEq,0.23)-    "<=+0.23" `gives` (LtEq,0.23)-    "-0.23" `gives` (Eq,(-0.23))-  ]- parseTag :: T.Text -> (Regexp, Maybe Regexp) parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)            | otherwise    = (T.unpack s, Nothing)@@ -410,20 +352,6 @@     simplify (Date2 (DateSpan Nothing Nothing)) = Any     simplify q = q -tests_simplifyQuery = [- "simplifyQuery" ~: do-  let q `gives` r = assertEqual "" r (simplifyQuery q)-  Or [Acct "a"] `gives` Acct "a"-  Or [Any,None] `gives` Any-  And [Any,None] `gives` None-  And [Any,Any] `gives` Any-  And [Acct "b",Any] `gives` Acct "b"-  And [Any,And [Date (DateSpan Nothing Nothing)]] `gives` Any-  And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)]-      `gives` Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01"))-  And [Or [],Or [Desc "b b"]] `gives` Desc "b b"- ]- same [] = True same (a:as) = all (a==) as @@ -438,15 +366,6 @@ -- filterQuery' p (Not q) = Not $ filterQuery p q filterQuery' p q = if p q then q else Any -tests_filterQuery = [- "filterQuery" ~: do-  let (q,p) `gives` r = assertEqual "" r (filterQuery p q)-  (Any, queryIsDepth) `gives` Any-  (Depth 1, queryIsDepth) `gives` Depth 1-  (And [And [StatusQ Cleared,Depth 1]], not . queryIsDepth) `gives` StatusQ Cleared-  -- (And [Date nulldatespan, Not (Or [Any, Depth 1])], queryIsDepth) `gives` And [Not (Or [Depth 1])]- ]- -- * accessors  -- | Does this query match everything ?@@ -481,6 +400,10 @@ queryIsAcct (Acct _) = True queryIsAcct _ = False +queryIsAmt :: Query -> Bool+queryIsAmt (Amt _ _) = True+queryIsAmt _         = False+ queryIsSym :: Query -> Bool queryIsSym (Sym _) = True queryIsSym _ = False@@ -530,33 +453,27 @@ queryTermDateSpan (Date span) = Just span queryTermDateSpan _ = Nothing --- | What date span (or secondary date span) does this query specify ?--- For OR expressions, use the widest possible span. NOT is ignored.+-- | What date span (or with a true argument, what secondary date span) does this query specify ?+-- OR clauses specifying multiple spans return their union (the span enclosing all of them).+-- AND clauses specifying multiple spans return their intersection.+-- NOT clauses are ignored. queryDateSpan :: Bool -> Query -> DateSpan-queryDateSpan secondary q = spansUnion $ queryDateSpans secondary q---- | Extract all date (or secondary date) spans specified in this query.--- NOT is ignored.-queryDateSpans :: Bool -> Query -> [DateSpan]-queryDateSpans secondary (Or qs) = concatMap (queryDateSpans secondary) qs-queryDateSpans secondary (And qs) = concatMap (queryDateSpans secondary) qs-queryDateSpans False (Date span) = [span]-queryDateSpans True (Date2 span) = [span]-queryDateSpans _ _ = []+queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs+queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs+queryDateSpan False (Date span)  = span+queryDateSpan True (Date2 span)  = span+queryDateSpan _ _                = nulldatespan --- | What date span (or secondary date span) does this query specify ?--- For OR expressions, use the widest possible span. NOT is ignored.+-- | What date span does this query specify, treating primary and secondary dates as equivalent ?+-- OR clauses specifying multiple spans return their union (the span enclosing all of them).+-- AND clauses specifying multiple spans return their intersection.+-- NOT clauses are ignored. queryDateSpan' :: Query -> DateSpan-queryDateSpan' q = spansUnion $ queryDateSpans' q---- | Extract all date (or secondary date) spans specified in this query.--- NOT is ignored.-queryDateSpans' :: Query -> [DateSpan]-queryDateSpans' (Or qs) = concatMap queryDateSpans' qs-queryDateSpans' (And qs) = concatMap queryDateSpans' qs-queryDateSpans' (Date span) = [span]-queryDateSpans' (Date2 span) = [span]-queryDateSpans' _ = []+queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs+queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs+queryDateSpan' (Date span)  = span+queryDateSpan' (Date2 span) = span+queryDateSpan' _            = nulldatespan  -- | What is the earliest of these dates, where Nothing is latest ? earliestMaybeDate :: [Maybe Day] -> Maybe Day@@ -623,24 +540,14 @@ matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True -tests_matchesAccount = [-   "matchesAccount" ~: do-    assertBool "positive acct match" $ matchesAccount (Acct "b:c") "a:bb:c:d"-    -- assertBool "acct should match at beginning" $ not $ matchesAccount (Acct True "a:b") "c:a:b"-    let q `matches` a = assertBool "" $ q `matchesAccount` a-    Depth 2 `matches` "a:b"-    assertBool "" $ Depth 2 `matchesAccount` "a"-    assertBool "" $ Depth 2 `matchesAccount` "a:b"-    assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"-    assertBool "" $ Date nulldatespan `matchesAccount` "a"-    assertBool "" $ Date2 nulldatespan `matchesAccount` "a"-    assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a"- ]- matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as +matchesCommodity :: Query -> CommoditySymbol -> Bool+matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s)+matchesCommodity _ _ = True+ -- | Does the match expression match this (simple) amount ? matchesAmount :: Query -> Amount -> Bool matchesAmount (Not q) a = not $ q `matchesAmount` a@@ -650,7 +557,7 @@ matchesAmount (And qs) a = all (`matchesAmount` a) qs -- matchesAmount (Amt ord n) a = compareAmount ord n a-matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ T.unpack $ acommodity a+matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) -- matchesAmount _ _ = True @@ -694,44 +601,12 @@ -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a matchesPosting (Empty _) _ = True-matchesPosting (Sym r) Posting{pamount=Mixed as} = any (regexMatchesCI $ "^" ++ r ++ "$") $ map (T.unpack . acommodity) as+matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as matchesPosting (Tag n v) p = case (n, v) of   ("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p   ("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p   (n, v) -> matchesTags n v $ postingAllTags p -tests_matchesPosting = [-   "matchesPosting" ~: do-    -- matching posting status..-    assertBool "positive match on cleared posting status"  $-                   (StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}-    assertBool "negative match on cleared posting status"  $-               not $ (Not $ StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}-    assertBool "positive match on unmarked posting status" $-                   (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}-    assertBool "negative match on unmarked posting status" $-               not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}-    assertBool "positive match on true posting status acquired from transaction" $-                   (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}}-    assertBool "real:1 on real posting" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}-    assertBool "real:1 on virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}-    assertBool "real:1 on balanced virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}-    assertBool "a" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}-    assertBool "b" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting-    assertBool "c" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}-    assertBool "d" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}-    assertBool "e" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    assertBool "f" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    assertBool "g" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}-    assertBool "h" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}-    -- a tag match on a posting also sees inherited tags-    assertBool "i" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}-    assertBool "j" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol-    assertBool "k" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr-    assertBool "l" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]}-    assertBool "m" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]}- ]- -- | Does the match expression match this transaction ? matchesTransaction :: Query -> Transaction -> Bool matchesTransaction (Not q) t = not $ q `matchesTransaction` t@@ -755,20 +630,6 @@   ("note", Just v) -> regexMatchesCI v . T.unpack . transactionNote $ t   (n, v) -> matchesTags n v $ transactionAllTags t -tests_matchesTransaction = [-  "matchesTransaction" ~: do-   let q `matches` t = assertBool "" $ q `matchesTransaction` t-   Any `matches` nulltransaction-   assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}-   assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}-   -- see posting for more tag tests-   assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}-   assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}-   assertBool "" $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}-   -- a tag match on a transaction also matches posting tags-   assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}- ]- -- | Filter a list of tags by matching against their names and -- optionally also their values. matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool@@ -777,17 +638,145 @@     match npat Nothing     (n,_) = regexMatchesCI npat (T.unpack n) -- XXX     match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v) +-- | Does the query match this market price ?+matchesMarketPrice :: Query -> MarketPrice -> Bool+matchesMarketPrice (None) _      = False+matchesMarketPrice (Not q) p     = not $ matchesMarketPrice q p+matchesMarketPrice (Or qs) p     = any (`matchesMarketPrice` p) qs+matchesMarketPrice (And qs) p    = all (`matchesMarketPrice` p) qs+matchesMarketPrice q@(Amt _ _) p = matchesAmount q (mpamount p)+matchesMarketPrice q@(Sym _) p   = matchesCommodity q (mpcommodity p)+matchesMarketPrice (Date span) p = spanContainsDate span (mpdate p)+matchesMarketPrice _ _           = True++ -- tests -tests_Hledger_Query :: Test-tests_Hledger_Query = TestList $-    tests_simplifyQuery- ++ tests_words''- ++ tests_filterQuery- ++ tests_parseQueryTerm- ++ tests_parseAmountQueryTerm- ++ tests_parseQuery- ++ tests_matchesAccount- ++ tests_matchesPosting- ++ tests_matchesTransaction+tests_Query = tests "Query" [+   tests "simplifyQuery" [+    +     (simplifyQuery $ Or [Acct "a"])      `is` (Acct "a")+    ,(simplifyQuery $ Or [Any,None])      `is` (Any)+    ,(simplifyQuery $ And [Any,None])     `is` (None)+    ,(simplifyQuery $ And [Any,Any])      `is` (Any)+    ,(simplifyQuery $ And [Acct "b",Any]) `is` (Acct "b")+    ,(simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) `is` (Any)+    ,(simplifyQuery $ And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)])+      `is` (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))+    ,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b")+   ]+  +  ,tests "parseQuery" [+     (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])+    ,parseQuery nulldate "inacct:a desc:\"b b\""                     `is` (Desc "b b", [QueryOptInAcct "a"])+    ,parseQuery nulldate "inacct:a inacct:b"                         `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])+    ,parseQuery nulldate "desc:'x x'"                                `is` (Desc "x x", [])+    ,parseQuery nulldate "'a a' 'b"                                  `is` (Or [Acct "a a",Acct "'b"], [])+    ,parseQuery nulldate "\""                                        `is` (Acct "\"", [])+   ]+  +  ,tests "words''" [+      (words'' [] "a b")                   `is` ["a","b"]        +    , (words'' [] "'a b'")                 `is` ["a b"]          +    , (words'' [] "not:a b")               `is` ["not:a","b"]    +    , (words'' [] "not:'a b'")             `is` ["not:a b"]      +    , (words'' [] "'not:a b'")             `is` ["not:a b"]      +    , (words'' ["desc:"] "not:desc:'a b'") `is` ["not:desc:a b"] +    , (words'' prefixes "\"acct:expenses:autres d\233penses\"") `is` ["acct:expenses:autres d\233penses"]+    , (words'' prefixes "\"")              `is` ["\""]+    ]+  +  ,tests "filterQuery" [+     filterQuery queryIsDepth Any       `is` Any+    ,filterQuery queryIsDepth (Depth 1) `is` Depth 1+    ,filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) `is` StatusQ Cleared+    ,filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) `is` Any   -- XXX unclear+   ] +  ,tests "parseQueryTerm" [+     parseQueryTerm nulldate "a"                                `is` (Left $ Acct "a")+    ,parseQueryTerm nulldate "acct:expenses:autres d\233penses" `is` (Left $ Acct "expenses:autres d\233penses")+    ,parseQueryTerm nulldate "not:desc:a b"                     `is` (Left $ Not $ Desc "a b")+    ,parseQueryTerm nulldate "status:1"                         `is` (Left $ StatusQ Cleared)+    ,parseQueryTerm nulldate "status:*"                         `is` (Left $ StatusQ Cleared)+    ,parseQueryTerm nulldate "status:!"                         `is` (Left $ StatusQ Pending)+    ,parseQueryTerm nulldate "status:0"                         `is` (Left $ StatusQ Unmarked)+    ,parseQueryTerm nulldate "status:"                          `is` (Left $ StatusQ Unmarked)+    ,parseQueryTerm nulldate "payee:x"                          `is` (Left $ Tag "payee" (Just "x"))+    ,parseQueryTerm nulldate "note:x"                           `is` (Left $ Tag "note" (Just "x"))+    ,parseQueryTerm nulldate "real:1"                           `is` (Left $ Real True)+    ,parseQueryTerm nulldate "date:2008"                        `is` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))+    ,parseQueryTerm nulldate "date:from 2012/5/17"              `is` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)+    ,parseQueryTerm nulldate "date:20180101-201804"             `is` (Left $ Date $ DateSpan (Just $ parsedate "2018/01/01") (Just $ parsedate "2018/04/01"))+    ,parseQueryTerm nulldate "inacct:a"                         `is` (Right $ QueryOptInAcct "a")+    ,parseQueryTerm nulldate "tag:a"                            `is` (Left $ Tag "a" Nothing)+    ,parseQueryTerm nulldate "tag:a=some value"                 `is` (Left $ Tag "a" (Just "some value"))+    ,parseQueryTerm nulldate "amt:<0"                           `is` (Left $ Amt Lt 0)+    ,parseQueryTerm nulldate "amt:>10000.10"                    `is` (Left $ Amt AbsGt 10000.1)+   ]+  +  ,tests "parseAmountQueryTerm" [+     parseAmountQueryTerm "<0"        `is` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false+    ,parseAmountQueryTerm ">0"        `is` (Gt,0) -- special case for convenience and consistency with above+    ,parseAmountQueryTerm ">10000.10" `is` (AbsGt,10000.1)+    ,parseAmountQueryTerm "=0.23"     `is` (AbsEq,0.23)+    ,parseAmountQueryTerm "0.23"      `is` (AbsEq,0.23)+    ,parseAmountQueryTerm "<=+0.23"   `is` (LtEq,0.23)+    ,parseAmountQueryTerm "-0.23"     `is` (Eq,(-0.23))+    ,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23)  -- XXX+    ]+  +  ,tests "matchesAccount" [+     expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d"+    ,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"+    ,expect $ Depth 2 `matchesAccount` "a"+    ,expect $ Depth 2 `matchesAccount` "a:b"+    ,expect $ not $ Depth 2 `matchesAccount` "a:b:c"+    ,expect $ Date nulldatespan `matchesAccount` "a"+    ,expect $ Date2 nulldatespan `matchesAccount` "a"+    ,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a"+  ]+  +  ,tests "matchesPosting" [+     test "positive match on cleared posting status"  $+      expect $ (StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}+    ,test "negative match on cleared posting status"  $+      expect $ not $ (Not $ StatusQ Cleared)  `matchesPosting` nullposting{pstatus=Cleared}+    ,test "positive match on unmarked posting status" $+      expect $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}+    ,test "negative match on unmarked posting status" $+      expect $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}+    ,test "positive match on true posting status acquired from transaction" $+      expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}}+    ,test "real:1 on real posting" $ expect $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}+    ,test "real:1 on virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}+    ,test "real:1 on balanced virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}+    ,test "a" $ expect $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}+    ,test "b" $ expect $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting+    ,test "c" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}+    ,test "d" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}+    ,test "e" $ expect $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    ,test "f" $ expect $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    ,test "g" $ expect $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    ,test "h" $ expect $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}+     -- a tag match on a posting also sees inherited tags+    ,test "i" $ expect $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}+    ,test "j" $ expect $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol+    ,test "k" $ expect $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr+    ,test "l" $ expect $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}+    ,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}+  ]+  +  ,tests "matchesTransaction" [+     expect $ Any `matchesTransaction` nulltransaction+    ,expect $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}+    ,expect $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}+     -- see posting for more tag tests+    ,expect $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}+    ,expect $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}+    ,expect $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}+     -- a tag match on a transaction also matches posting tags+    ,expect $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}+  ]++ ]

@@ -29,8 +29,7 @@   module Hledger.Read.Common,    -- * Tests-  samplejournal,-  tests_Hledger_Read,+  tests_Read,  ) where @@ -50,17 +49,16 @@ import System.Exit (exitFailure) import System.FilePath import System.IO-import Test.HUnit import Text.Printf  import Hledger.Data.Dates (getCurrentDay, parsedate, showDate) import Hledger.Data.Types import Hledger.Read.Common-import qualified Hledger.Read.JournalReader   as JournalReader+import Hledger.Read.JournalReader   as JournalReader -- import qualified Hledger.Read.LedgerReader    as LedgerReader import qualified Hledger.Read.TimedotReader   as TimedotReader import qualified Hledger.Read.TimeclockReader as TimeclockReader-import qualified Hledger.Read.CsvReader       as CsvReader+import Hledger.Read.CsvReader as CsvReader import Hledger.Utils import Prelude hiding (getContents, writeFile) @@ -149,12 +147,6 @@ readJournal' :: Text -> IO Journal readJournal' t = readJournal def Nothing t >>= either error' return -tests_readJournal' = [-  "readJournal' parses sample journal" ~: do-     _ <- samplejournal-     assertBool "" True- ]- -- | @findReader mformat mpath@ -- -- Find the reader named by @mformat@, if provided.@@ -315,47 +307,37 @@  -- tests -samplejournal = readJournal' $ T.unlines- ["2008/01/01 income"- ,"    assets:bank:checking  $1"- ,"    income:salary"- ,""- ,"comment"- ,"multi line comment here"- ,"for testing purposes"- ,"end comment"- ,""- ,"2008/06/01 gift"- ,"    assets:bank:checking  $1"- ,"    income:gifts"- ,""- ,"2008/06/02 save"- ,"    assets:bank:saving  $1"- ,"    assets:bank:checking"- ,""- ,"2008/06/03 * eat & shop"- ,"    expenses:food      $1"- ,"    expenses:supplies  $1"- ,"    assets:cash"- ,""- ,"2008/12/31 * pay off"- ,"    liabilities:debts  $1"- ,"    assets:bank:checking"- ]--tests_Hledger_Read = TestList $-  tests_readJournal'-  ++ [-   JournalReader.tests_Hledger_Read_JournalReader,---    LedgerReader.tests_Hledger_Read_LedgerReader,-   TimeclockReader.tests_Hledger_Read_TimeclockReader,-   TimedotReader.tests_Hledger_Read_TimedotReader,-   CsvReader.tests_Hledger_Read_CsvReader,+tests_Read = tests "Read" [+   tests_Common+  ,tests_CsvReader+  ,tests_JournalReader+  ] -   "journal" ~: do-    r <- runExceptT $ parseWithState mempty JournalReader.journalp ""-    assertBool "journalp should parse an empty file" (isRight $ r)-    jE <- readJournal def Nothing "" -- don't know how to get it from journal-    either error' (assertBool "journalp parsing an empty file should give an empty journal" . null . jtxns) jE+--samplejournal = readJournal' $ T.unlines+-- ["2008/01/01 income"+-- ,"    assets:bank:checking  $1"+-- ,"    income:salary"+-- ,""+-- ,"comment"+-- ,"multi line comment here"+-- ,"for testing purposes"+-- ,"end comment"+-- ,""+-- ,"2008/06/01 gift"+-- ,"    assets:bank:checking  $1"+-- ,"    income:gifts"+-- ,""+-- ,"2008/06/02 save"+-- ,"    assets:bank:saving  $1"+-- ,"    assets:bank:checking"+-- ,""+-- ,"2008/06/03 * eat & shop"+-- ,"    expenses:food      $1"+-- ,"    expenses:supplies  $1"+-- ,"    assets:cash"+-- ,""+-- ,"2008/12/31 * pay off"+-- ,"    liabilities:debts  $1"+-- ,"    assets:bank:checking"+-- ] -  ]

@@ -31,16 +31,15 @@   rjp,   genericSourcePos,   journalSourcePos,-  generateAutomaticPostings,+  applyTransactionModifiers,   parseAndFinaliseJournal,-  parseAndFinaliseJournal',  -- TODO unused ? check addons   setYear,   getYear,   setDefaultCommodityAndStyle,   getDefaultCommodityAndStyle,   getDefaultAmountStyle,   getAmountStyle,-  pushAccount,+  pushDeclaredAccount,   pushParentAccount,   popParentAccount,   getParentAccount,@@ -90,7 +89,10 @@    -- ** misc   singlespacedtextp,-  singlespacep+  singlespacep,++  -- * tests+  tests_Common, ) where --- * imports@@ -122,8 +124,10 @@  import Hledger.Data import Hledger.Utils-import qualified Hledger.Query as Q (Query(Any)) +-- $setup+-- >>> :set -XOverloadedStrings+ -- | A hledger journal reader is a triple of storage format name, a -- detector of that format, and a parser from that format to Journal. data Reader = Reader {@@ -154,6 +158,7 @@      mformat_           :: Maybe StorageFormat  -- ^ a file/storage format to try, unless overridden                                                 --   by a filename prefix. Nothing means try all.     ,mrules_file_       :: Maybe FilePath       -- ^ a conversion rules file to use (when reading CSV)+    ,separator_         :: Char                 -- ^ the separator to use (when reading CSV)     ,aliases_           :: [String]             -- ^ account name aliases to apply     ,anon_              :: Bool                 -- ^ do light anonymisation/obfuscation of the data      ,ignore_assertions_ :: Bool                 -- ^ don't check balance assertions@@ -166,13 +171,14 @@ instance Default InputOpts where def = definputopts  definputopts :: InputOpts-definputopts = InputOpts def def def def def def True def def+definputopts = InputOpts def def ',' def def def def True def def  rawOptsToInputOpts :: RawOpts -> InputOpts rawOptsToInputOpts rawopts = InputOpts{    -- files_             = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts    mformat_           = Nothing   ,mrules_file_       = maybestringopt "rules-file" rawopts+  ,separator_         = fromMaybe ',' (maybecharopt "separator" rawopts)   ,aliases_           = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts   ,anon_              = boolopt "anon" rawopts   ,ignore_assertions_ = boolopt "ignore-assertions" rawopts@@ -184,12 +190,12 @@  --- * parsing utilities --- | Run a string parser with no state in the identity monad.+-- | Run a text parser in the identity monad. See also: parseWithState. runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char CustomErr) a runTextParser p t =  runParser p "" t rtp = runTextParser --- | Run a journal parser with a null journal-parsing state.+-- | Run a journal parser in some monad. See also: parseWithState. runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either (ParseError Char CustomErr) a) runJournalParser p t = runParserT (evalStateT p mempty) "" t rjp = runJournalParser@@ -205,13 +211,13 @@             | otherwise = unPos $ sourceLine p' -- might be at end of file withat last new-line  --- | Generate Automatic postings and add them to the current journal.-generateAutomaticPostings :: Journal -> Journal-generateAutomaticPostings j = j { jtxns = map modifier $ jtxns j }+-- | Apply any transaction modifier rules in the journal +-- (adding automated postings to transactions, eg).+applyTransactionModifiers :: Journal -> Journal+applyTransactionModifiers j = j { jtxns = map applyallmodifiers $ jtxns j }   where-    modifier = foldr (flip (.) . runModifierTransaction') id mtxns-    runModifierTransaction' = fmap txnTieKnot . runModifierTransaction Q.Any-    mtxns = jmodifiertxns j+    applyallmodifiers = +      foldr (flip (.) . transactionModifierToFunction) id (jtxnmodifiers j)  -- | Given a megaparsec ParsedJournal parser, input options, file -- path and file content: parse and post-process a Journal, or give an error.@@ -223,26 +229,12 @@   ep <- liftIO $ runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt   case ep of     Right pj -> -      let pj' = if auto_ iopts then generateAutomaticPostings pj else pj in+      let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in       case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of                         Right j -> return j                         Left e  -> throwError e     Left e   -> throwError $ customParseErrorPretty txt e -parseAndFinaliseJournal' :: JournalParser Identity ParsedJournal -> InputOpts -                            -> FilePath -> Text -> ExceptT String IO Journal-parseAndFinaliseJournal' parser iopts f txt = do-  t <- liftIO getClockTime-  y <- liftIO getCurrentYear-  let ep = runParser (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt-  case ep of-    Right pj -> -      let pj' = if auto_ iopts then generateAutomaticPostings pj else pj in      -      case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of-                        Right j -> return j-                        Left e  -> throwError e-    Left e   -> throwError $ parseErrorPretty e- setYear :: Year -> JournalParser m () setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) @@ -273,8 +265,8 @@     let effectiveStyle = listToMaybe $ catMaybes [specificStyle, defaultStyle]     return effectiveStyle -pushAccount :: AccountName -> JournalParser m ()-pushAccount acct = modify' (\j -> j{jaccounts = (acct, Nothing) : jaccounts j})+pushDeclaredAccount :: AccountName -> JournalParser m ()+pushDeclaredAccount acct = modify' (\j -> j{jdeclaredaccounts = acct : jdeclaredaccounts j})  pushParentAccount :: AccountName -> JournalParser m () pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})@@ -474,10 +466,14 @@     a  -- | Parse an account name, plus one following space if present. --- Account names start with a non-space, may have single spaces inside them, +-- Account names have one or more parts separated by the account separator character, -- and are terminated by two or more spaces (or end of input). --- (Also they have one or more components of at least one character, --- separated by the account separator character, but we don't check that here.) +-- Each part is at least one character long, may have single spaces inside it,+-- and starts with a non-whitespace.+-- Note, this means "{account}", "%^!" and ";comment" are all accepted+-- (parent parsers usually prevent/consume the last).+-- It should have required parts to start with an alphanumeric;+-- for now it remains as-is for backwards compatibility. accountnamep :: TextParser m AccountName accountnamep = singlespacedtextp @@ -505,20 +501,6 @@     lift $ skipSome spacenonewline     Mixed . (:[]) <$> amountp -#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_spaceandamountormissingp = do-    assertParseEqual' (parseWithState mempty spaceandamountormissingp " $47.18") (Mixed [usd 47.18])-    assertParseEqual' (parseWithState mempty spaceandamountormissingp "$47.18") missingmixedamt-    assertParseEqual' (parseWithState mempty spaceandamountormissingp " ") missingmixedamt-    assertParseEqual' (parseWithState mempty spaceandamountormissingp "") 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.@@ -540,52 +522,42 @@   leftsymbolamountp mult sign = label "amount" $ do     c <- lift commoditysymbolp     suggestedStyle <- getAmountStyle c-     commodityspaced <- lift $ skipMany' spacenonewline-     sign2 <- lift $ signp     posBeforeNum <- getPosition     ambiguousRawNum <- lift rawnumberp     mExponent <- lift $ optional $ try exponentp     posAfterNum <- getPosition     let numRegion = (posBeforeNum, posAfterNum)--    (q,prec,mdec,mgrps) <- lift $-      interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent+    (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent     let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}     return $ Amount c (sign (sign2 q)) NoPrice s mult -  rightornosymbolamountp-    :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount+  rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount   rightornosymbolamountp mult sign = label "amount" $ do     posBeforeNum <- getPosition     ambiguousRawNum <- lift rawnumberp     mExponent <- lift $ optional $ try exponentp     posAfterNum <- getPosition     let numRegion = (posBeforeNum, posAfterNum)--    mSpaceAndCommodity <- lift $ optional $ try $-      (,) <$> skipMany' spacenonewline <*> commoditysymbolp-+    mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp     case mSpaceAndCommodity of+      -- right symbol amount       Just (commodityspaced, c) -> do         suggestedStyle <- getAmountStyle c-        (q,prec,mdec,mgrps) <- lift $-          interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent-+        (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent         let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}         return $ Amount c (sign q) NoPrice s mult-+      -- no symbol amount       Nothing -> do         suggestedStyle <- getDefaultAmountStyle-        (q,prec,mdec,mgrps) <- lift $-          interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent--        -- apply the most recently seen default commodity and style to this commodityless amount+        (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent+        -- if a default commodity has been set, apply it and its style to this amount+        -- (unless it's a multiplier in an automated posting)         defcs <- getDefaultCommodityAndStyle-        let (c,s) = case defcs of-              Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})-              Nothing          -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})+        let (c,s) = case (mult, defcs) of+              (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) prec})+              _ -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})         return $ Amount c (sign q) NoPrice s mult    -- For reducing code duplication. Doesn't parse anything. Has the type@@ -602,21 +574,6 @@           Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg           Right res -> pure res --#ifdef TESTS-test_amountp = do-    assertParseEqual' (parseWithState mempty amountp "$47.18") (usd 47.18)-    assertParseEqual' (parseWithState mempty amountp "$1.") (usd 1 `withPrecision` 0)-  -- ,"amount with unit price" ~: do-    assertParseEqual'-     (parseWithState mempty amountp "$10 @ €0.5")-     (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))-  -- ,"amount with total price" ~: do-    assertParseEqual'-     (parseWithState mempty 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 amountp' s =@@ -719,7 +676,7 @@ numberp suggestedStyle = label "number" $ do     -- a number is an optional sign followed by a sequence of digits possibly     -- interspersed with periods, commas, or both-    -- ptrace "numberp"+    -- dbgparse 0 "numberp"     sign <- signp     rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp     mExp <- optional $ try $ exponentp@@ -917,7 +874,6 @@     makeGroup = uncurry DigitGrp . foldl' step (0, 0) . T.unpack     step (!l, !a) c = (l+1, a*10 + fromIntegral (digitToInt c)) - data RawNumber   = NoSeparators   DigitGrp (Maybe (Char, DigitGrp))        -- 100 or 100. or .100 or 100.50   | WithSeparators Char [DigitGrp] (Maybe (Char, DigitGrp)) -- 1,000,000 or 1,000.50@@ -926,28 +882,6 @@ data AmbiguousNumber = AmbiguousNumber DigitGrp Char DigitGrp  -- 1,000   deriving (Show, Eq) --- test_numberp = do---       let s `is` n = assertParseEqual (parseWithState mempty numberp s) n---           assertFails = assertBool . isLeft . parseWithState mempty numberp---       assertFails ""---       "0"          `is` (0, 0, '.', ',', [])---       "1"          `is` (1, 0, '.', ',', [])---       "1.1"        `is` (1.1, 1, '.', ',', [])---       "1,000.1"    `is` (1000.1, 1, '.', ',', [3])---       "1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])---       "1,000,000"  `is` (1000000, 0, '.', ',', [3,3])---       "1."         `is` (1,   0, '.', ',', [])---       "1,"         `is` (1,   0, ',', '.', [])---       ".1"         `is` (0.1, 1, '.', ',', [])---       ",1"         `is` (0.1, 1, ',', '.', [])---       assertFails "1,000.000,1"---       assertFails "1.000,000.1"---       assertFails "1,000.000.1"---       assertFails "1,,1"---       assertFails "1..1"---       assertFails ".1,"---       assertFails ",1."- --- ** comments  multilinecommentp :: TextParser m ()@@ -989,26 +923,46 @@ -- until the next newline. This parser should extract the "content" from -- comments. The resulting parser returns this content plus the raw text -- of the comment itself.-followingcommentp' :: (Monoid a) => TextParser m a -> TextParser m (Text, a)+--+-- See followingcommentp for tests.+--+followingcommentp' :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a) followingcommentp' contentp = do   skipMany spacenonewline-  sameLine <- try headerp *> match' contentp <|> pure ("", mempty)+  -- there can be 0 or 1 sameLine+  sameLine <- try headerp *> ((:[]) <$> match' contentp) <|> pure []   _ <- eolof-  lowerLines <- many $+  -- there can be 0 or more nextLines+  nextLines <- many $     try (skipSome spacenonewline *> headerp) *> match' contentp <* eolof--  let (textLines, results) = unzip $ sameLine : lowerLines-      strippedCommentText = T.unlines $ map T.strip textLines-      result = mconcat results-  pure (strippedCommentText, result)+  let+    -- if there's just a next-line comment, insert an empty same-line comment+    -- so the next-line comment doesn't get rendered as a same-line comment.+    sameLine' | null sameLine && not (null nextLines) = [("",mempty)]+              | otherwise = sameLine +    (texts, contents) = unzip $ sameLine' ++ nextLines+    strippedCommentText = T.unlines $ map T.strip texts+    commentContent = mconcat contents+  pure (strippedCommentText, commentContent)    where     headerp = char ';' *> skipMany spacenonewline  {-# INLINABLE followingcommentp' #-} --- | Parse the text of a (possibly multiline) comment following a journal--- item.+-- | Parse the text of a (possibly multiline) comment following a journal item.+--+-- >>> rtp followingcommentp ""   -- no comment+-- Right ""+-- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added+-- Right "\n"+-- >>> rtp followingcommentp ";  \n"+-- Right "\n"+-- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment+-- Right "\n\n"+-- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.+-- Right "\n\n"+-- followingcommentp :: TextParser m Text followingcommentp =   fst <$> followingcommentp' (void $ takeWhileP Nothing (/= '\n'))@@ -1214,7 +1168,7 @@ bracketeddatetagsp   :: Maybe Year -> TextParser m [(TagName, Day)] bracketeddatetagsp mYear1 = do-  -- pdbg 0 "bracketeddatetagsp"+  -- dbgparse 0 "bracketeddatetagsp"   try $ do     s <- lookAhead        $ between (char '[') (char ']')@@ -1245,3 +1199,69 @@ match' p = do   (!txt, p) <- match p   pure (txt, p)++--- * tests++tests_Common = tests "Common" [++  tests "amountp" [+    test "basic"                  $ expectParseEq amountp "$47.18"     (usd 47.18)+   ,test "ends with decimal mark" $ expectParseEq amountp "$1."        (usd 1  `withPrecision` 0)+   ,test "unit price"             $ expectParseEq amountp "$10 @ €0.5" +      -- not precise enough:+      -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'+      amount{+         acommodity="$"+        ,aquantity=10 -- need to test internal precision with roundTo ? I think not +        ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}+        ,aprice=UnitPrice $+          amount{+             acommodity="€"+            ,aquantity=0.5+            ,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'}+            } +        } +   ,test "total price"            $ expectParseEq amountp "$10 @@ €5"+      amount{+         acommodity="$"+        ,aquantity=10 +        ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}+        ,aprice=TotalPrice $+          amount{+             acommodity="€"+            ,aquantity=5+            ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}+            } +        } +    ]++  ,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in+   tests "numberp" [+     test "." $ expectParseEq p "0"          (0, 0, Nothing, Nothing)+    ,test "." $ expectParseEq p "1"          (1, 0, Nothing, Nothing)+    ,test "." $ expectParseEq p "1.1"        (1.1, 1, Just '.', Nothing)+    ,test "." $ expectParseEq p "1,000.1"    (1000.1, 1, Just '.', Just $ DigitGroups ',' [3])+    ,test "." $ expectParseEq p "1.00.000,1" (100000.1, 1, Just ',', Just $ DigitGroups '.' [3,2])+    ,test "." $ expectParseEq p "1,000,000"  (1000000, 0, Nothing, Just $ DigitGroups ',' [3,3])  -- could be simplified to [3]+    ,test "." $ expectParseEq p "1."         (1, 0, Just '.', Nothing)+    ,test "." $ expectParseEq p "1,"         (1, 0, Just ',', Nothing)+    ,test "." $ expectParseEq p ".1"         (0.1, 1, Just '.', Nothing)+    ,test "." $ expectParseEq p ",1"         (0.1, 1, Just ',', Nothing)+    ,test "." $ expectParseError p "" ""+    ,test "." $ expectParseError p "1,000.000,1" ""+    ,test "." $ expectParseError p "1.000,000.1" ""+    ,test "." $ expectParseError p "1,000.000.1" ""+    ,test "." $ expectParseError p "1,,1" ""+    ,test "." $ expectParseError p "1..1" ""+    ,test "." $ expectParseError p ".1," ""+    ,test "." $ expectParseError p ",1." ""+    ]+  +  ,tests "spaceandamountormissingp" [+     test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18])+    ,test "empty string" $ expectParseEq spaceandamountormissingp "" missingmixedamt+    ,_test "just space" $ expectParseEq spaceandamountormissingp " " missingmixedamt  -- XXX should it ?+    -- ,test "just amount" $ expectParseError spaceandamountormissingp "$47.18" ""  -- succeeds, consuming nothing+    ]++  ]

@@ -18,24 +18,25 @@   reader,   -- * Misc.   CsvRecord,+  CSV, Record, Field,   -- rules,   rulesFileFor,   parseRulesFile,   parseAndValidateCsvRules,   expandIncludes,   transactionFromCsvRecord,+  printCSV,   -- * Tests-  tests_Hledger_Read_CsvReader+  tests_CsvReader, ) where import Prelude ()-import "base-compat-batteries" Prelude.Compat hiding (getContents)+import "base-compat-batteries" Prelude.Compat import Control.Exception hiding (try) import Control.Monad import Control.Monad.Except import Control.Monad.State.Strict (StateT, get, modify', evalStateT)--- import Test.HUnit-import Data.Char (toLower, isDigit, isSpace)+import Data.Char (toLower, isDigit, isSpace, ord) import "base-compat-batteries" Data.List.Compat import Data.List.NonEmpty (fromList) import Data.Maybe@@ -43,6 +44,7 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time.Calendar (Day) #if MIN_VERSION_time(1,5,0)@@ -54,19 +56,29 @@ import Safe import System.Directory (doesFileExist) import System.FilePath-import Test.HUnit hiding (State)-import Text.CSV (parseCSV, CSV)+import qualified Data.Csv as Cassava+import qualified Data.Csv.Parser.Megaparsec as CassavaMP+import qualified Data.ByteString as B+import Data.ByteString.Lazy (fromStrict)+import Data.Foldable import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char-import qualified Text.Parsec as Parsec import Text.Printf (printf)+import Data.Word  import Hledger.Data-import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils import Hledger.Read.Common (Reader(..),InputOpts(..),amountp, statusp, genericSourcePos) +type CSV = [Record] +type Record = [Field]++type Field = String++data CSVError = CSVError (ParseError Word8 CassavaMP.ConversionError)+    deriving Show+ reader :: Reader reader = Reader   {rFormat     = "csv"@@ -80,7 +92,8 @@ parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal parse iopts f t = do   let rulesfile = mrules_file_ iopts-  r <- liftIO $ readJournalFromCsv rulesfile f t+  let separator = separator_ iopts+  r <- liftIO $ readJournalFromCsv separator rulesfile f t   case r of Left e -> throwError e             Right j -> return $ journalNumberAndTieTransactions j -- XXX does not use parseAndFinaliseJournal like the other readers@@ -94,11 +107,11 @@ -- 2. parse the CSV data, or throw a parse error -- 3. convert the CSV records to transactions using the rules -- 4. if the rules file didn't exist, create it with the default rules and filename--- 5. return the transactions as a Journal +-- 5. return the transactions as a Journal -- @-readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> IO (Either String Journal)-readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin"-readJournalFromCsv mrulesfile csvfile csvdata =+readJournalFromCsv :: Char -> Maybe FilePath -> FilePath -> Text -> IO (Either String Journal)+readJournalFromCsv _ Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin"+readJournalFromCsv separator mrulesfile csvfile csvdata =  handle (\e -> return $ Left $ show (e :: IOException)) $ do   let throwerr = throw.userError @@ -111,7 +124,7 @@       dbg1IO "using conversion rules file" rulesfile       liftIO $ (readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile))     else return $ defaultRulesText rulesfile-  rules <- liftIO (runExceptT $ parseAndValidateCsvRules rulesfile rulestext) >>= either throwerr return +  rules <- liftIO (runExceptT $ parseAndValidateCsvRules rulesfile rulestext) >>= either throwerr return   dbg2IO "rules" rules    -- apply skip directive@@ -126,17 +139,17 @@   records <- (either throwerr id .               dbg2 "validateCsv" . validateCsv skip .               dbg2 "parseCsv")-             `fmap` parseCsv parsecfilename (T.unpack csvdata)+             `fmap` parseCsv separator parsecfilename csvdata   dbg1IO "first 3 csv records" $ take 3 records    -- identify header lines   -- let (headerlines, datalines) = identifyHeaderLines records   --     mfieldnames = lastMay headerlines -  let +  let     -- convert CSV records to transactions     txns = snd $ mapAccumL-                   (\pos r -> +                   (\pos r ->                       let                         SourcePos name line col = pos                         line' = (mkPos . (+1) . unPos) line@@ -148,16 +161,16 @@      -- Ensure transactions are ordered chronologically.     -- First, reverse them to get same-date transactions ordered chronologically,-    -- if the CSV records seem to be most-recent-first, ie if there's an explicit +    -- if the CSV records seem to be most-recent-first, ie if there's an explicit     -- "newest-first" directive, or if there's more than one date and the first date     -- is more recent than the last.-    txns' = +    txns' =       (if newestfirst || mseemsnewestfirst == Just True then reverse else id) txns       where         newestfirst = dbg3 "newestfirst" $ isJust $ getDirective "newest-first" rules-        mseemsnewestfirst = dbg3 "mseemsnewestfirst" $  -          case nub $ map tdate txns of -            ds | length ds > 1 -> Just $ head ds > last ds +        mseemsnewestfirst = dbg3 "mseemsnewestfirst" $+          case nub $ map tdate txns of+            ds | length ds > 1 -> Just $ head ds > last ds             _                  -> Nothing     -- Second, sort by date.     txns'' = sortBy (comparing tdate) txns'@@ -168,14 +181,41 @@    return $ Right nulljournal{jtxns=txns''} -parseCsv :: FilePath -> String -> IO (Either Parsec.ParseError CSV)-parseCsv path csvdata =-  case path of-    "-" -> liftM (parseCSV "(stdin)") getContents-    _   -> return $ parseCSV path csvdata+parseCsv :: Char -> FilePath -> Text -> IO (Either CSVError CSV)+parseCsv separator filePath csvdata =+  case filePath of+    "-" -> liftM (parseCassava separator "(stdin)") T.getContents+    _   -> return $ parseCassava separator filePath csvdata +parseCassava :: Char -> FilePath -> Text -> Either CSVError CSV+parseCassava separator path content =+    case parseResult of+        Left  msg -> Left $ CSVError msg+        Right a   -> Right a+    where parseResult = fmap parseResultToCsv $ CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path lazyContent+          lazyContent = fromStrict $ T.encodeUtf8 content++decodeOptions :: Char -> Cassava.DecodeOptions+decodeOptions separator = Cassava.defaultDecodeOptions {+                      Cassava.decDelimiter = fromIntegral (ord separator)+                    }++parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV+parseResultToCsv = toListList . unpackFields+    where+        toListList = toList . fmap toList+        unpackFields  = (fmap . fmap) (T.unpack . T.decodeUtf8)++printCSV :: CSV -> String+printCSV records = unlined (printRecord `map` records)+    where printRecord = concat . intersperse "," . map printField+          printField f = "\"" ++ concatMap escape f ++ "\""+          escape '"' = "\"\""+          escape x = [x]+          unlined = concat . intersperse "\n"+ -- | Return the cleaned up and validated CSV data (can be empty), or an error.-validateCsv :: Int -> Either Parsec.ParseError CSV -> Either String [CsvRecord]+validateCsv :: Int -> Either CSVError CSV -> Either String [CsvRecord] validateCsv _ (Left e) = Left $ show e validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs   where@@ -365,11 +405,11 @@ instance ShowErrorComponent String where   showErrorComponent = id --- | An error-throwing action that parses this file's content --- as CSV conversion rules, interpolating any included files first, +-- | An error-throwing action that parses this file's content+-- as CSV conversion rules, interpolating any included files first, -- and runs some extra validation checks. parseRulesFile :: FilePath -> ExceptT String IO CsvRules-parseRulesFile f = +parseRulesFile f =   liftIO (readFilePortably f >>= expandIncludes (takeDirectory f)) >>= parseAndValidateCsvRules f  -- | Inline all files referenced by include directives in this hledger CSV rules text, recursively.@@ -383,9 +423,9 @@           where             f' = dir </> dropWhile isSpace (T.unpack f)             dir' = takeDirectory f'-        _ -> return line +        _ -> return line --- | An error-throwing action that parses this text as CSV conversion rules +-- | An error-throwing action that parses this text as CSV conversion rules -- and runs some extra validation checks. The file path is for error messages. parseAndValidateCsvRules :: FilePath -> T.Text -> ExceptT String IO CsvRules parseAndValidateCsvRules rulesfile s = do@@ -441,7 +481,7 @@           }  blankorcommentlinep :: CsvRulesParser ()-blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]+blankorcommentlinep = lift (dbgparse 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]  blanklinep :: CsvRulesParser () blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"@@ -454,7 +494,7 @@  directivep :: CsvRulesParser (DirectiveName, String) directivep = (do-  lift $ pdbg 3 "trying directive"+  lift $ dbgparse 3 "trying directive"   d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives   v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)        <|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")@@ -477,7 +517,7 @@  fieldnamelistp :: CsvRulesParser [CsvFieldName] fieldnamelistp = (do-  lift $ pdbg 3 "trying fieldnamelist"+  lift $ dbgparse 3 "trying fieldnamelist"   string "fields"   optional $ char ':'   lift (skipSome spacenonewline)@@ -503,7 +543,7 @@  fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate) fieldassignmentp = do-  lift $ pdbg 3 "trying fieldassignmentp"+  lift $ dbgparse 3 "trying fieldassignmentp"   f <- journalfieldnamep   assignmentseparatorp   v <- fieldvalp@@ -512,11 +552,11 @@  journalfieldnamep :: CsvRulesParser String journalfieldnamep = do-  lift (pdbg 2 "trying journalfieldnamep")+  lift (dbgparse 2 "trying journalfieldnamep")   T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames) --- Transaction fields and pseudo fields for CSV conversion. --- Names must precede any other name they contain, for the parser +-- Transaction fields and pseudo fields for CSV conversion.+-- Names must precede any other name they contain, for the parser -- (amount-in before amount; date2 before date). TODO: fix journalfieldnames = [    "account1"@@ -536,7 +576,7 @@  assignmentseparatorp :: CsvRulesParser () assignmentseparatorp = do-  lift $ pdbg 3 "trying assignmentseparatorp"+  lift $ dbgparse 3 "trying assignmentseparatorp"   choice [     -- try (lift (skipMany spacenonewline) >> oneOf ":="),     try (lift (skipMany spacenonewline) >> char ':'),@@ -547,12 +587,12 @@  fieldvalp :: CsvRulesParser String fieldvalp = do-  lift $ pdbg 2 "trying fieldvalp"+  lift $ dbgparse 2 "trying fieldvalp"   anyChar `manyTill` lift eolof  conditionalblockp :: CsvRulesParser ConditionalBlock conditionalblockp = do-  lift $ pdbg 3 "trying conditionalblockp"+  lift $ dbgparse 3 "trying conditionalblockp"   string "if" >> lift (skipMany spacenonewline) >> optional newline   ms <- some recordmatcherp   as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)@@ -563,7 +603,7 @@  recordmatcherp :: CsvRulesParser [String] recordmatcherp = do-  lift $ pdbg 2 "trying recordmatcherp"+  lift $ dbgparse 2 "trying recordmatcherp"   -- pos <- currentPos   _  <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)   ps <- patternsp@@ -582,20 +622,20 @@  patternsp :: CsvRulesParser [String] patternsp = do-  lift $ pdbg 3 "trying patternsp"+  lift $ dbgparse 3 "trying patternsp"   ps <- many regexp   return ps  regexp :: CsvRulesParser String regexp = do-  lift $ pdbg 3 "trying regexp"+  lift $ dbgparse 3 "trying regexp"   notFollowedBy matchoperatorp   c <- lift nonspace   cs <- anyChar `manyTill` lift eolof   return $ strip $ c:cs  -- fieldmatcher = do---   pdbg 2 "trying fieldmatcher"+--   dbgparse 2 "trying fieldmatcher" --   f <- fromMaybe "all" `fmap` (optional $ do --          f' <- fieldname --          lift (skipMany spacenonewline)@@ -686,7 +726,7 @@     account1    = T.pack $ maybe "" render (mfieldtemplate "account1") `or` defaccount1     account2    = T.pack $ maybe "" render (mfieldtemplate "account2") `or` defaccount2     balance     = maybe Nothing (parsebalance.render) $ mfieldtemplate "balance"-    parsebalance str +    parsebalance str       | all isSpace str  = Nothing       | otherwise = Just $ (either (balanceerror str) id $ runParser (evalStateT (amountp <* eof) mempty) "" $ T.pack $ (currency++) $ simplifySign str, nullsourcepos)     balanceerror str err = error' $ unlines@@ -740,7 +780,7 @@ type CsvAmountString = String  -- | Canonicalise the sign in a CSV amount string.--- Such strings can have a minus sign, negating parentheses, +-- Such strings can have a minus sign, negating parentheses, -- or any two of these (which cancels out). -- -- >>> simplifySign "1"@@ -800,10 +840,10 @@ 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+    replace ('%':pat) = maybe pat (\i -> atDef "" record (i-1)) mindex       where-        mi | all isDigit pat = readMay pat-           | otherwise       = lookup pat $ rcsvfieldindexes rules+        mindex | all isDigit pat = readMay pat+               | otherwise       = lookup (map toLower pat) $ rcsvfieldindexes rules     replace pat       = pat  -- Parse the date string using the specified date-format, or if unspecified try these default formats:@@ -834,67 +874,24 @@ -------------------------------------------------------------------------------- -- 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" "") rules--  -- ,"convert rules parsing: accountrule" ~: do-  --    assertParseEqual (parseWithState rules accountrule "A\na\n") -- leading blank line required-  --                ([("A",Nothing)], "a")--  ,"convert rules parsing: trailing comments" ~: do-     assertParse (parseWithState' rules rulesp "skip\n# \n#\n")--  ,"convert rules parsing: trailing blank lines" ~: do-     assertParse (parseWithState' rules rulesp "skip\n\n  \n")+tests_CsvReader = tests "CsvReader" [+   tests "parseCsvRules" [+     test "empty file" $+      parseCsvRules "unknown" "" `is` Right rules+    ]+  ,tests "rulesp" [+     test "trailing comments" $+      parseWithState' rules rulesp "skip\n# \n#\n" `is` Right rules{rdirectives = [("skip","")]} -  ,"convert rules parsing: empty field value" ~: do-     assertParse (parseWithState' rules rulesp "account1 \nif foo\n  account2 foo\n")+    ,test "trailing blank lines" $+      parseWithState' rules rulesp "skip\n\n  \n" `is` (Right rules{rdirectives = [("skip","")]}) -  -- not supported-  -- ,"convert rules parsing: no final newline" ~: do-  --    assertParse (parseWithState rules csvrulesfile "A\na")-  --    assertParse (parseWithState rules csvrulesfile "A\na\n# \n#")-  --    assertParse (parseWithState rules csvrulesfile "A\na\n\n  ")+    ,test "no final newline" $+      parseWithState' rules rulesp "skip" `is` (Right rules{rdirectives=[("skip","")]}) -                 -- (rules{-                 --   -- dateField=Maybe FieldPosition,-                 --   -- statusField=Maybe FieldPosition,-                 --   -- codeField=Maybe FieldPosition,-                 --   -- descriptionField=Maybe FieldPosition,-                 --   -- amountField=Maybe FieldPosition,-                 --   -- currencyField=Maybe FieldPosition,-                 --   -- baseCurrency=Maybe String,-                 --   -- baseAccount=AccountName,-                 --   accountRules=[-                 --        ([("A",Nothing)], "a")-                 --       ]-                 --  })+    ,test "assignment with empty value" $+      parseWithState' rules rulesp "account1 \nif foo\n  account2 foo\n" `is`+        (Right rules{rassignments = [("account1","")], rconditionalblocks = [([["foo"]],[("account2","foo")])]}) +    ]   ]

@@ -51,21 +51,14 @@   marketpricedirectivep,   datetimep,   datep,-  -- codep,-  -- accountnamep,   modifiedaccountnamep,   postingp,-  -- amountp,-  -- amountp',-  -- mamountp',-  -- numberp,   statusp,   emptyorcommentlinep,   followingcommentp    -- * Tests-  ,tests_Hledger_Read_JournalReader-+  ,tests_JournalReader ) where --- * imports@@ -84,16 +77,12 @@ import Data.Time.Calendar import Data.Time.LocalTime import Safe-import Test.HUnit-#ifdef TESTS-import Test.Framework-import Text.Megaparsec.Error-#endif import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char import Text.Megaparsec.Custom import Text.Printf import System.FilePath+import "Glob" System.FilePath.Glob hiding (match)  import Hledger.Data import Hledger.Read.Common@@ -153,7 +142,7 @@   choice [       directivep     , transactionp          >>= modify' . addTransaction-    , modifiertransactionp  >>= modify' . addModifierTransaction+    , transactionmodifierp  >>= modify' . addTransactionModifier     , periodictransactionp  >>= modify' . addPeriodicTransaction     , marketpricedirectivep >>= modify' . addMarketPrice     , void (lift emptyorcommentlinep)@@ -191,39 +180,62 @@   lift (skipSome spacenonewline)   filename <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet -  -- save parent state-  parentParserState <- getParserState-  parentj <- get--  let childj = newJournalWithParseStateFrom parentj   parentpos <- getPosition -  -- read child input-  let curdir = takeDirectory (sourceName parentpos)-  filepath <- lift $ expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)-  childInput <- lift $ readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)+  filepaths <- getFilePaths parentpos filename -  -- set child state-  setInput childInput-  pushPosition $ initialPos filepath-  put childj+  forM_ filepaths $ parseChild parentpos -  -- parse include file-  let parsers = [ journalp-                , timeclockfilep-                , timedotfilep-                ] -- can't include a csv file yet, that reader is special-  updatedChildj <- journalAddFile (filepath, childInput) <$>-                   region (withSource childInput) (choiceInState parsers)+  void newline -  -- restore parent state, prepending the child's parse info-  setParserState parentParserState-  put $ updatedChildj <> parentj-  -- discard child's parse info, prepend its (reversed) list data, combine other fields+  where+    getFilePaths parserpos filename = do+        curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) ""+                         `orRethrowIOError` (show parserpos ++ " locating " ++ filename)+        -- Compiling filename as a glob pattern works even if it is a literal+        fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of+            Right x -> pure x+            Left e -> parseErrorAt parserpos $ "Invalid glob pattern: " ++ e+        -- Get all matching files in the current working directory, sorting in+        -- lexicographic order to simulate the output of 'ls'.+        filepaths <- liftIO $ sort <$> globDir1 fileglob curdir+        if (not . null) filepaths+            then pure filepaths+            else parseErrorAt parserpos $ "No existing files match pattern: " ++ filename -  void newline+    parseChild parentpos filepath = do+        parentfilestack <- fmap sourceName . statePos <$> getParserState+        when (filepath `elem` parentfilestack)+            $ parseErrorAt parentpos ("Cyclic include: " ++ filepath) +        childInput <- lift $ readFilePortably filepath+                             `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) +        -- save parent state+        parentParserState <- getParserState+        parentj <- get++        let childj = newJournalWithParseStateFrom parentj++        -- set child state+        setInput childInput+        pushPosition $ initialPos filepath+        put childj++        -- parse include file+        let parsers = [ journalp+                      , timeclockfilep+                      , timedotfilep+                      ] -- can't include a csv file yet, that reader is special+        updatedChildj <- journalAddFile (filepath, childInput) <$>+                        region (withSource childInput) (choiceInState parsers)++        -- restore parent state, prepending the child's parse info+        setParserState parentParserState+        put $ updatedChildj <> parentj+        -- discard child's parse info, prepend its (reversed) list data, combine other fields++ newJournalWithParseStateFrom :: Journal -> Journal newJournalWithParseStateFrom j = mempty{    jparsedefaultyear      = jparsedefaultyear j@@ -249,12 +261,10 @@   string "account"   lift (skipSome spacenonewline)   acct <- modifiedaccountnamep  -- account directives can be modified by alias/apply account-  macode' :: Maybe String <- (optional $ lift $ skipSome spacenonewline >> some digitChar)-  let macode :: Maybe AccountCode = read <$> macode'+  _ :: Maybe String <- (optional $ lift $ skipSome spacenonewline >> some digitChar)  -- compatibility: ignore account codes supported in 1.9/1.10   newline   skipMany indentedlinep-    -  modify' (\j -> j{jaccounts = (acct, macode) : jaccounts j})+  pushDeclaredAccount acct  indentedlinep :: JournalParser m String indentedlinep = lift (skipSome spacenonewline) >> (rstrip <$> lift restofline)@@ -288,7 +298,7 @@   else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})  pleaseincludedecimalpoint :: String-pleaseincludedecimalpoint = "to avoid ambiguity, please include a decimal point in commodity directives"+pleaseincludedecimalpoint = "to avoid ambiguity, please include a decimal separator in commodity directives"  -- | Parse a multi-line commodity directive, containing 0 or more format subdirectives. --@@ -357,7 +367,7 @@  basicaliasp :: TextParser m AccountAlias basicaliasp = do-  -- pdbg 0 "basicaliasp"+  -- dbgparse 0 "basicaliasp"   old <- rstrip <$> (some $ noneOf ("=" :: [Char]))   char '='   skipMany spacenonewline@@ -366,7 +376,7 @@  regexaliasp :: TextParser m AccountAlias regexaliasp = do-  -- pdbg 0 "regexaliasp"+  -- dbgparse 0 "regexaliasp"   char '/'   re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end   char '/'@@ -449,13 +459,14 @@  --- ** transactions -modifiertransactionp :: JournalParser m ModifierTransaction-modifiertransactionp = do+transactionmodifierp :: JournalParser m TransactionModifier+transactionmodifierp = do   char '=' <?> "modifier transaction"   lift (skipMany spacenonewline)-  valueexpr <- T.pack <$> lift restofline+  querytxt <- lift $ T.strip <$> descriptionp+  (_comment, _tags) <- lift transactioncommentp   -- TODO apply these to modified txns ?   postings <- postingsp Nothing-  return $ ModifierTransaction valueexpr postings+  return $ TransactionModifier querytxt postings  -- | Parse a periodic transaction periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction@@ -504,7 +515,7 @@ -- | Parse a (possibly unbalanced) transaction. transactionp :: JournalParser m Transaction transactionp = do-  -- ptrace "transactionp"+  -- dbgparse 0 "transactionp"   startpos <- getPosition   date <- datep <?> "transaction"   edate <- optional (lift $ secondarydatep date) <?> "secondary date"@@ -519,99 +530,6 @@   let sourcepos = journalSourcePos startpos endpos   return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings "" -#ifdef TESTS-test_transactionp = do-    let s `gives` t = do-                        let p = parseWithState mempty transactionp s-                        assertBool $ isRight p-                        let Right t2 = p-                            -- 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",-      "    ; tcomment2",-      "    ; ttag1: val1",-      "    * a         $1.00  ; pcomment1",-      "    ; pcomment2",-      "    ; ptag1: val1",-      "    ; ptag2: val2"-      ]-     `gives`-     nulltransaction{-      tdate=parsedate "2012/05/14",-      tdate2=Just $ parsedate "2012/05/15",-      tstatus=Unmarked,-      tcode="code",-      tdescription="desc",-      tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",-      ttags=[("ttag1","val1")],-      tpostings=[-        nullposting{-          pstatus=Cleared,-          paccount="a",-          pamount=Mixed [usd 1],-          pcomment=" pcomment1\n pcomment2\n ptag1: val1\n  ptag2: val2\n",-          ptype=RegularPosting,-          ptags=[("ptag1","val1"),("ptag2","val2")],-          ptransaction=Nothing-          }-        ],-      tpreceding_comment_lines=""-      }-    unlines [-      "2015/1/1",-      ]-     `gives`-     nulltransaction{-      tdate=parsedate "2015/01/01",-      }--    assertRight $ parseWithState mempty transactionp $ unlines-      ["2007/01/28 coopportunity"-      ,"    expenses:food:groceries                   $47.18"-      ,"    assets:checking                          $-47.18"-      ,""-      ]--    -- transactionp should not parse just a date-    assertLeft $ parseWithState mempty transactionp "2009/1/1\n"--    -- transactionp should not parse just a date and description-    assertLeft $ parseWithState mempty transactionp "2009/1/1 a\n"--    -- transactionp should not parse a following comment as part of the description-    let p = parseWithState mempty transactionp "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 $ parseWithState mempty transactionp $ unlines-        ["2012/1/1"-        ,"  a  1"-        ,"  b"-        ," "-        ]--    let p = parseWithState mempty transactionp $ 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- --- ** postings  -- Parse the following whitespace-beginning lines as postings, posting@@ -628,7 +546,7 @@  postingp :: Maybe Year -> JournalParser m Posting postingp mTransactionYear = do-  -- pdbg 0 "postingp"+  -- lift $ dbgparse 0 "postingp"   (status, account) <- try $ do     lift (skipSome spacenonewline)     status <- lift statusp@@ -654,155 +572,261 @@    , pbalanceassertion=massertion    } -#ifdef TESTS-test_postingp = do-    let s `gives` ep = do-                         let parse = parseWithState mempty (postingp Nothing) 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-                         same pcomment-                         same ptype-                         same ptags-                         same ptransaction-    "  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")]}+--- * tests -    " 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"}+tests_JournalReader = tests "JournalReader" [ -    " 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}+   let p = lift accountnamep :: JournalParser IO AccountName in+   tests "accountnamep" [+     test "basic" $ expectParse p "a:b:c"+    ,_test "empty inner component" $ expectParseError p "a::c" ""  -- TODO+    ,_test "empty leading component" $ expectParseError p ":b:c" "x"+    ,_test "empty trailing component" $ expectParseError p "a:b:" "x"+    ] -    " 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"}+  -- "Parse a date in YYYY/MM/DD format.+  -- Hyphen (-) and period (.) are also allowed as separators.+  -- The year may be omitted if a default year has been set.+  -- Leading zeroes may be omitted."+  ,test "datep" $ do+    test "YYYY/MM/DD" $ expectParseEq datep "2018/01/01" (fromGregorian 2018 1 1)+    test "YYYY-MM-DD" $ expectParse datep "2018-01-01"+    test "YYYY.MM.DD" $ expectParse datep "2018.01.01"+    test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown"+    test "yearless date with default year" $ do +      ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep "1/1"+      either (fail.("parse error at "++).parseErrorPretty) (const ok) ep+    test "no leading zero" $ expectParse datep "2018/1/1" -    assertBool -- "postingp parses a quoted commodity with numbers"-      (isRight $ parseWithState mempty (postingp Nothing) "  a  1 \"DE123\"\n")+  ,test "datetimep" $ do+      let+        good = expectParse datetimep+        bad = (\t -> expectParseError datetimep t "")+      good "2011/1/1 00:00"+      good "2011/1/1 23:59:59"+      bad "2011/1/1"+      bad "2011/1/1 24:00:00"+      bad "2011/1/1 00:60:00"+      bad "2011/1/1 00:00:60"+      bad "2011/1/1 3:5:7"+      test "timezone is parsed but ignored" $ do+        let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 (fromIntegral 0))+        expectParseEq datetimep "2018/1/1 00:00-0800" t+        expectParseEq datetimep "2018/1/1 00:00+1234" t -  -- ,"postingp parses balance assertions and fixed lot prices" ~: do-    assertBool (isRight $ parseWithState mempty (postingp Nothing) "  a  1 \"DE123\" =$1 { =2.2 EUR} \n")+  ,tests "periodictransactionp" [ -    -- let parse = parseWithState mempty postingp " a\n ;next-line comment\n"-    -- assertRight parse-    -- let Right p = parse-    -- assertEqual "next-line comment\n" (pcomment p)-    -- assertEqual (Just nullmixedamt) (pbalanceassertion p)-#endif+    test "more period text in comment after one space" $ expectParseEq periodictransactionp+      "~ monthly from 2018/6 ;In 2019 we will change this\n" +      nullperiodictransaction {+         ptperiodexpr  = "monthly from 2018/6"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing+        ,ptstatus      = Unmarked+        ,ptcode        = ""+        ,ptdescription = ""+        ,ptcomment     = "In 2019 we will change this\n"+        ,pttags        = []+        ,ptpostings    = []+        } ---- * more tests+     -- TODO #807+    ,_test "more period text in description after two spaces" $ expectParseEq periodictransactionp +      "~ monthly from 2018/6   In 2019 we will change this\n" +      nullperiodictransaction {+         ptperiodexpr  = "monthly from 2018/6"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing+        ,ptdescription = "In 2019 we will change this\n"+        } -tests_Hledger_Read_JournalReader = TestList $ concat [-    -- test_numberp-    [-    "showParsedMarketPrice" ~: do-      let mp = parseWithState mempty marketpricedirectivep "P 2017/01/30 BTC $922.83\n"-          mpString = (fmap . fmap) showMarketPrice mp-      mpString `is` (Just (Right "P 2017/01/30 BTC $922.83"))+    ,_test "more period text in description after one space" $ expectParseEq periodictransactionp+      "~ monthly from 2018/6 In 2019 we will change this\n" +      nullperiodictransaction {+         ptperiodexpr  = "monthly from 2018/6"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan (Just $ fromGregorian 2018 6 1) Nothing+        ,ptdescription = "In 2019 we will change this\n"+        }++    ,_test "Next year in description" $ expectParseEq periodictransactionp+      "~ monthly  Next year blah blah\n"+      nullperiodictransaction {+         ptperiodexpr  = "monthly"+        ,ptinterval    = Months 1+        ,ptspan        = DateSpan Nothing Nothing+        ,ptdescription = "Next year blah blah\n"+        }+     ]- ] -{- old hunit tests+  ,tests "postingp" [+     test "basic" $ expectParseEq (postingp Nothing) +      "  expenses:food:dining  $10.00   ; a: a a \n   ; b: b b \n"+      posting{+        paccount="expenses:food:dining", +        pamount=Mixed [usd 10], +        pcomment="a: a a\nb: b b\n", +        ptags=[("a","a a"), ("b","b b")]+        } -tests_Hledger_Read_JournalReader = TestList $ concat [-    test_numberp,-    test_amountp,-    test_spaceandamountormissingp,-    test_tagcomment,-    test_inlinecomment,-    test_comments,-    test_ledgerDateSyntaxToTags,-    test_postingp,-    test_transactionp,-    [-   "modifiertransactionp" ~: do-     assertParse (parseWithState mempty modifiertransactionp "= (some value expr)\n some:postings  1\n")+    ,test "posting dates" $ expectParseEq (postingp Nothing) +      " a  1. ; date:2012/11/28, date2=2012/11/29,b:b\n"+      nullposting{+         paccount="a"+        ,pamount=Mixed [num 1]+        ,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"+        ,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")] -- TODO tag name parsed too greedily+        ,pdate=Just $ fromGregorian 2012 11 28+        ,pdate2=Nothing  -- Just $ fromGregorian 2012 11 29+        } -  ,"periodictransactionp" ~: do-     assertParse (parseWithState mempty periodictransactionp "~ (some period expr)\n some:postings  1\n")+    ,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing) +      " a  1. ; [2012/11/28=2012/11/29]\n"+      nullposting{+         paccount="a"+        ,pamount=Mixed [num 1]+        ,pcomment="[2012/11/28=2012/11/29]\n"+        ,ptags=[]+        ,pdate= Just $ fromGregorian 2012 11 28 +        ,pdate2=Just $ fromGregorian 2012 11 29+        } -  ,"directivep" ~: do-     assertParse (parseWithState mempty directivep "!include /some/file.x\n")-     assertParse (parseWithState mempty directivep "account some:account\n")-     assertParse (parseWithState mempty (directivep >> directivep) "!account a\nend\n")+    ,test "quoted commodity symbol with digits" $ expectParse (postingp Nothing) "  a  1 \"DE123\"\n" -  ,"comment" ~: do-     assertParse (parseWithState mempty comment "; some comment \n")-     assertParse (parseWithState mempty comment " \t; x\n")-     assertParse (parseWithState mempty comment "#x")+    ,test "balance assertion and fixed lot price" $ expectParse (postingp Nothing) "  a  1 \"DE123\" =$1 { =2.2 EUR} \n"+    ] -  ,"datep" ~: do-     assertParse (parseWithState mempty datep "2011/1/1")-     assertParseFailure (parseWithState mempty datep "1/1")-     assertParse (parseWithState mempty{jpsYear=Just 2011} datep "1/1")+  ,tests "transactionmodifierp" [ -  ,"datetimep" ~: do-      let p = do {t <- datetimep; eof; return t}-          bad = assertParseFailure . parseWithState mempty p-          good = assertParse . parseWithState mempty p-      bad "2011/1/1"-      bad "2011/1/1 24:00:00"-      bad "2011/1/1 00:60:00"-      bad "2011/1/1 00:00:60"-      good "2011/1/1 00:00"-      good "2011/1/1 23:59:59"-      good "2011/1/1 3:5:7"-      -- timezone is parsed but ignored-      let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))-      assertParseEqual (parseWithState mempty p "2011/1/1 00:00-0800") startofday-      assertParseEqual (parseWithState mempty p "2011/1/1 00:00+1234") startofday+    test "basic" $ expectParseEq transactionmodifierp +      "= (some value expr)\n some:postings  1.\n"+      nulltransactionmodifier {+        tmquerytxt = "(some value expr)"+       ,tmpostings = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}]+      }+    ] -  ,"defaultyeardirectivep" ~: do-     assertParse (parseWithState mempty defaultyeardirectivep "Y 2010\n")-     assertParse (parseWithState mempty defaultyeardirectivep "Y 10001\n")+  ,tests "transactionp" [+  +     test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}+  +    ,test "more complex" $ expectParseEq transactionp +      (T.unlines [+        "2012/05/14=2012/05/15 (code) desc  ; tcomment1",+        "    ; tcomment2",+        "    ; ttag1: val1",+        "    * a         $1.00  ; pcomment1",+        "    ; pcomment2",+        "    ; ptag1: val1",+        "    ; ptag2: val2"+        ])+      nulltransaction{+        tsourcepos=JournalSourcePos "" (1,7),  -- XXX why 7 here ?+        tpreceding_comment_lines="",+        tdate=fromGregorian 2012 5 14,+        tdate2=Just $ fromGregorian 2012 5 15,+        tstatus=Unmarked,+        tcode="code",+        tdescription="desc",+        tcomment="tcomment1\ntcomment2\nttag1: val1\n",+        ttags=[("ttag1","val1")],+        tpostings=[+          nullposting{+            pdate=Nothing,+            pstatus=Cleared,+            paccount="a",+            pamount=Mixed [usd 1],+            pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",+            ptype=RegularPosting,+            ptags=[("ptag1","val1"),("ptag2","val2")],+            ptransaction=Nothing+            }+          ]+      }+  +    ,test "parses a well-formed transaction" $+      expect $ isRight $ rjp transactionp $ T.unlines+        ["2007/01/28 coopportunity"+        ,"    expenses:food:groceries                   $47.18"+        ,"    assets:checking                          $-47.18"+        ,""+        ]+  +    ,test "does not parse a following comment as part of the description" $+      expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"+  +    ,test "transactionp parses a following whitespace line" $+      expect $ isRight $ rjp transactionp $ T.unlines+        ["2012/1/1"+        ,"  a  1"+        ,"  b"+        ," "+        ]+  +    ,test "comments everywhere, two postings parsed" $+      expectParseEqOn transactionp +        (T.unlines+          ["2009/1/1 x  ; transaction comment"+          ," a  1  ; posting 1 comment"+          ," ; posting 1 comment 2"+          ," b"+          ," ; posting 2 comment"+          ])+        (length . tpostings)+        2+  +    ] -  ,"marketpricedirectivep" ~:-    assertParseEqual (parseWithState mempty marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55)+  -- directives -  ,"ignoredpricecommoditydirectivep" ~: do-     assertParse (parseWithState mempty ignoredpricecommoditydirectivep "N $\n")+  ,tests "directivep" [+    test "supports !" $ do +      expectParse directivep "!account a\n"+      expectParse directivep "!D 1.0\n"+    ] -  ,"defaultcommoditydirectivep" ~: do-     assertParse (parseWithState mempty defaultcommoditydirectivep "D $1,000.0\n")+  ,test "accountdirectivep" $ do+    test "account" $ expectParse accountdirectivep "account a:b\n"+    test "does not support !" $ expectParseError accountdirectivep "!account a:b\n" "" -  ,"commodityconversiondirectivep" ~: do-     assertParse (parseWithState mempty commodityconversiondirectivep "C 1h = $50.00\n")+  ,test "commodityconversiondirectivep" $ do+     expectParse commodityconversiondirectivep "C 1h = $50.00\n" -  ,"tagdirectivep" ~: do-     assertParse (parseWithState mempty tagdirectivep "tag foo \n")+  ,test "defaultcommoditydirectivep" $ do+     expectParse defaultcommoditydirectivep "D $1,000.0\n"+     expectParseError defaultcommoditydirectivep "D $1000\n" "please include a decimal separator" -  ,"endtagdirectivep" ~: do-     assertParse (parseWithState mempty endtagdirectivep "end tag \n")-     assertParse (parseWithState mempty endtagdirectivep "pop \n")+  ,test "defaultyeardirectivep" $ do+    test "1000" $ expectParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others+    test "999" $ expectParseError defaultyeardirectivep "Y 999" "bad year number"+    test "12345" $ expectParse defaultyeardirectivep "Y 12345" -  ,"accountnamep" ~: do-    assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c")-    assertBool "accountnamep rejects an empty inner component" (isLeft $ parsewith accountnamep "a::c")-    assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c")-    assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:")+  ,test "ignoredpricecommoditydirectivep" $ do+     expectParse ignoredpricecommoditydirectivep "N $\n" -  ,"leftsymbolamountp" ~: do-    assertParseEqual (parseWithState mempty leftsymbolamountp "$1")  (usd 1 `withPrecision` 0)-    assertParseEqual (parseWithState mempty leftsymbolamountp "$-1") (usd (-1) `withPrecision` 0)-    assertParseEqual (parseWithState mempty leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0)+  ,test "includedirectivep" $ do+    test "include" $ expectParseError includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"+    test "glob" $ expectParseError includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" -  ,"amount" ~: do-     let -- | compare a parse result with an expected amount, showing the debug representation for clarity-         assertAmountParse parseresult amount =-             (either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug amount)-     assertAmountParse (parseWithState mempty amountp "1 @ $2")-       (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))+  ,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep+    "P 2017/01/30 BTC $922.83\n"+    MarketPrice{+      mpdate      = fromGregorian 2017 1 30,+      mpcommodity = "BTC",+      mpamount    = usd 922.83+      } - ]]--}+  ,test "tagdirectivep" $ do+     expectParse tagdirectivep "tag foo \n"++  ,test "endtagdirectivep" $ do+     expectParse endtagdirectivep "end tag \n"+     expectParse endtagdirectivep "pop \n"+++  ,tests "journalp" [+    test "empty file" $ expectParseEq journalp "" nulljournal+    ]++  ]

@@ -47,8 +47,6 @@   reader,   -- * Misc other exports   timeclockfilep,-  -- * Tests-  tests_Hledger_Read_TimeclockReader ) where import           Prelude ()@@ -59,7 +57,6 @@ import           Data.Maybe (fromMaybe) import           Data.Text (Text) import qualified Data.Text as T-import           Test.HUnit import           Text.Megaparsec hiding (parse) import           Text.Megaparsec.Char @@ -116,6 +113,4 @@   description <- T.pack . fromMaybe "" <$> lift (optional (skipSome spacenonewline >> restofline))   return $ TimeclockEntry sourcepos (read [code]) datetime account description -tests_Hledger_Read_TimeclockReader = TestList [- ] 

@@ -30,8 +30,6 @@   reader,   -- * Misc other exports   timedotfilep,-  -- * Tests-  tests_Hledger_Read_TimedotReader ) where import Prelude ()@@ -43,19 +41,18 @@ import Data.List (foldl') import Data.Maybe import Data.Text (Text)-import Test.HUnit import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char  import Hledger.Data import Hledger.Read.Common-import Hledger.Utils hiding (ptrace)+import Hledger.Utils hiding (traceParse)  -- easier to toggle this here sometimes--- import qualified Hledger.Utils (ptrace)--- ptrace = Hledger.Utils.ptrace-ptrace :: Monad m => a -> m a-ptrace = return+-- import qualified Hledger.Utils (parsertrace)+-- parsertrace = Hledger.Utils.parsertrace+traceParse :: Monad m => a -> m a+traceParse = return  reader :: Reader reader = Reader@@ -76,7 +73,7 @@     where       timedotfileitemp :: JournalParser m ()       timedotfileitemp = do-        ptrace "timedotfileitemp"+        traceParse "timedotfileitemp"         choice [           void $ lift emptyorcommentlinep          ,timedotdayp >>= \ts -> modify' (addTransactions ts)@@ -94,7 +91,7 @@ -- @ timedotdayp :: JournalParser m [Transaction] timedotdayp = do-  ptrace " timedotdayp"+  traceParse " timedotdayp"   d <- datep <* lift eolof   es <- catMaybes <$> many (const Nothing <$> try (lift emptyorcommentlinep) <|>                             Just <$> (notFollowedBy datep >> timedotentryp))@@ -106,7 +103,7 @@ -- @ timedotentryp :: JournalParser m Transaction timedotentryp = do-  ptrace "  timedotentryp"+  traceParse "  timedotentryp"   pos <- genericSourcePos <$> getPosition   lift (skipMany spacenonewline)   a <- modifiedaccountnamep@@ -173,7 +170,3 @@ timedotdotsp = do   dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))   return $ (/4) $ fromIntegral $ length dots--tests_Hledger_Read_TimedotReader = TestList [- ]-

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-|  Generate several common kinds of report from a journal, as \"*Report\" -@@ -18,14 +18,11 @@   module Hledger.Reports.MultiBalanceReports,   module Hledger.Reports.BudgetReport, --   module Hledger.Reports.BalanceHistoryReport,-   -- * Tests-  tests_Hledger_Reports+  tests_Reports ) where -import Test.HUnit- import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes import Hledger.Reports.EntriesReport@@ -35,15 +32,14 @@ import Hledger.Reports.MultiBalanceReports import Hledger.Reports.BudgetReport -- import Hledger.Reports.BalanceHistoryReport+import Hledger.Utils.Test -tests_Hledger_Reports :: Test-tests_Hledger_Reports = TestList $- -- ++ tests_isInterestingIndented- [- tests_Hledger_Reports_ReportOptions,- tests_Hledger_Reports_EntriesReport,- tests_Hledger_Reports_PostingsReport,- tests_Hledger_Reports_BalanceReport,- tests_Hledger_Reports_MultiBalanceReport,- tests_Hledger_Reports_BudgetReport- ]+tests_Reports = tests "Reports" [+   tests_BalanceReport+  ,tests_BudgetReport+  ,tests_EntriesReport+  ,tests_MultiBalanceReports+  ,tests_PostingsReport+  ,tests_ReportOptions+  ,tests_TransactionsReports+  ]

@@ -8,14 +8,10 @@  module Hledger.Reports.BalanceHistoryReport (   accountBalanceHistory--  -- -- * Tests-  -- tests_Hledger_Reports_BalanceReport ) where  import Data.Time.Calendar--- import Test.HUnit  import Hledger.Data import Hledger.Query

@@ -18,9 +18,10 @@   BalanceReportItem,   balanceReport,   flatShowsExclusiveBalance,+  sortAccountItemsLike,     -- * Tests-  tests_Hledger_Reports_BalanceReport+  tests_BalanceReport ) where @@ -28,12 +29,11 @@ import Data.Ord import Data.Maybe import Data.Time.Calendar-import Test.HUnit  import Hledger.Data import Hledger.Read (mamountp') import Hledger.Query-import Hledger.Utils+import Hledger.Utils  import Hledger.Reports.ReportOptions  @@ -79,7 +79,7 @@ balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport opts q j =    (if invert_ opts then brNegate else id) $ -  (items, total)+  (sorteditems, total)     where       -- dbg1 = const id -- exclude from debug output       dbg1 s = let p = "balanceReport" in Hledger.Utils.dbg1 (p++" "++s)  -- add prefix in debug output@@ -90,7 +90,6 @@                          dbg1 "accts" $                          take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts           | flat_ opts = dbg1 "accts" $-                         sortflat $                          filterzeros $                          filterempty $                          drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts@@ -99,27 +98,52 @@                          drop 1 $ flattenAccounts $                          markboring $                          prunezeros $-                         sorttree $+                         sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) $                          clipAccounts (queryDepth q) accts           where-            balance     = if flat_ opts then aebalance else aibalance+            balance   = if flat_ opts then aebalance else aibalance             filterzeros = if empty_ opts then id else filter (not . isZeroMixedAmount . balance)             filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a)))             prunezeros  = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance)             markboring  = if no_elide_ opts then id else markBoringParentAccounts-            sortflat | sort_amount_ opts = sortBy (maybeflip $ comparing balance)-                     | otherwise         = sortBy (comparing accountCodeAndNameForSort)-              where-                maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip-            sorttree | sort_amount_ opts = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts)-                     | otherwise         = sortAccountTreeByAccountCodeAndName+       items = dbg1 "items" $ map (balanceReportItem opts q) accts'++      -- now sort items like MultiBalanceReport, except +      -- sorting a tree by amount was more easily done above+      sorteditems +        | sort_amount_ opts && tree_ opts = items+        | sort_amount_ opts               = sortFlatBRByAmount items+        | otherwise                       = sortBRByAccountDeclaration items+      +        where    +          -- Sort the report rows, representing a flat account list, by row total. +          sortFlatBRByAmount :: [BalanceReportItem] -> [BalanceReportItem]+          sortFlatBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fourth4))+            where+              maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip+    +          -- Sort the report rows by account declaration order then account name. +          sortBRByAccountDeclaration :: [BalanceReportItem] -> [BalanceReportItem]+          sortBRByAccountDeclaration rows = sortedrows+            where +              anamesandrows = [(first4 r, r) | r <- rows]+              anames = map fst anamesandrows+              sortedanames = sortAccountNamesByDeclaration j (tree_ opts) anames+              sortedrows = sortAccountItemsLike sortedanames anamesandrows +       total | not (flat_ opts) = dbg1 "total" $ sum [amt | (_,_,indent,amt) <- items, indent == 0]             | otherwise        = dbg1 "total" $                                  if flatShowsExclusiveBalance                                  then sum $ map fourth4 items                                  else sum $ map aebalance $ clipAccountsAndAggregate 1 accts' +-- | A sorting helper: sort a list of things (eg report rows) keyed by account name+-- to match the provided ordering of those same account names.+sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b] +sortAccountItemsLike sortedas items =+  concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas+ -- | In an account tree with zero-balance leaves removed, mark the -- elidable parent accounts (those with one subaccount and no balance -- of their own).@@ -156,216 +180,6 @@   where     brItemNegate (a, a', d, amt) = (a, a', d, -amt) -tests_balanceReport =-  let-    (opts,journal) `gives` r = do-      let (eitems, etotal) = r-          (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal-          showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt)-      assertEqual "items" (map showw eitems) (map showw aitems)-      assertEqual "total" (showMixedAmountDebug etotal) (showMixedAmountDebug atotal)-    usd0 = usd 0-  in [--   "balanceReport with no args on null journal" ~: do-   (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])--  ,"balanceReport with no args on sample journal" ~: do-   (defreportopts, samplejournal) `gives`-    ([-      ("assets","assets",0, mamountp' "$0.00")-     ,("assets:bank","bank",1, mamountp' "$2.00")-     ,("assets:bank:checking","checking",2, mamountp' "$1.00")-     ,("assets:bank:saving","saving",2, mamountp' "$1.00")-     ,("assets:cash","cash",1, mamountp' "$-2.00")-     ,("expenses","expenses",0, mamountp' "$2.00")-     ,("expenses:food","food",1, mamountp' "$1.00")-     ,("expenses:supplies","supplies",1, mamountp' "$1.00")-     ,("income","income",0, mamountp' "$-2.00")-     ,("income:gifts","gifts",1, mamountp' "$-1.00")-     ,("income:salary","salary",1, mamountp' "$-1.00")-     ],-     Mixed [usd0])--  ,"balanceReport with --depth=N" ~: do-   (defreportopts{depth_=Just 1}, samplejournal) `gives`-    ([-     ("expenses",    "expenses",    0, mamountp'  "$2.00")-     ,("income",      "income",      0, mamountp' "$-2.00")-     ],-     Mixed [usd0])--  ,"balanceReport with depth:N" ~: do-   (defreportopts{query_="depth:1"}, samplejournal) `gives`-    ([-     ("expenses",    "expenses",    0, mamountp'  "$2.00")-     ,("income",      "income",      0, mamountp' "$-2.00")-     ],-     Mixed [usd0])--  ,"balanceReport with a date or secondary date span" ~: do-   (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`-    ([],-     Mixed [nullamt])-   (defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`-    ([-      ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")-     ,("income:salary","income:salary",0,mamountp' "$-1.00")-     ],-     Mixed [usd0])--  ,"balanceReport with desc:" ~: do-   (defreportopts{query_="desc:income"}, samplejournal) `gives`-    ([-      ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")-     ,("income:salary","income:salary",0, mamountp' "$-1.00")-     ],-     Mixed [usd0])--  ,"balanceReport with not:desc:" ~: do-   (defreportopts{query_="not:desc:income"}, samplejournal) `gives`-    ([-      ("assets","assets",0, mamountp' "$-1.00")-     ,("assets:bank:saving","bank:saving",1, mamountp' "$1.00")-     ,("assets:cash","cash",1, mamountp' "$-2.00")-     ,("expenses","expenses",0, mamountp' "$2.00")-     ,("expenses:food","food",1, mamountp' "$1.00")-     ,("expenses:supplies","supplies",1, mamountp' "$1.00")-     ,("income:gifts","income:gifts",0, mamountp' "$-1.00")-     ],-     Mixed [usd0])--  ,"balanceReport with period on a populated period" ~: do-    (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives`-     (-      [-       ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00")-      ,("income:salary","income:salary",0, mamountp' "$-1.00")-      ],-      Mixed [usd0])--   ,"balanceReport with period on an unpopulated period" ~: do-    (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`-     ([],Mixed [nullamt])----{--    ,"accounts report with account pattern o" ~:-     defreportopts{patterns_=["o"]} `gives`-     ["                  $1  expenses:food"-     ,"                 $-2  income"-     ,"                 $-1    gifts"-     ,"                 $-1    salary"-     ,"--------------------"-     ,"                 $-1"-     ]--    ,"accounts report with account pattern o and --depth 1" ~:-     defreportopts{patterns_=["o"],depth_=Just 1} `gives`-     ["                  $1  expenses"-     ,"                 $-2  income"-     ,"--------------------"-     ,"                 $-1"-     ]--    ,"accounts report with account pattern a" ~:-     defreportopts{patterns_=["a"]} `gives`-     ["                 $-1  assets"-     ,"                  $1    bank:saving"-     ,"                 $-2    cash"-     ,"                 $-1  income:salary"-     ,"                  $1  liabilities:debts"-     ,"--------------------"-     ,"                 $-1"-     ]--    ,"accounts report with account pattern e" ~:-     defreportopts{patterns_=["e"]} `gives`-     ["                 $-1  assets"-     ,"                  $1    bank:saving"-     ,"                 $-2    cash"-     ,"                  $2  expenses"-     ,"                  $1    food"-     ,"                  $1    supplies"-     ,"                 $-2  income"-     ,"                 $-1    gifts"-     ,"                 $-1    salary"-     ,"                  $1  liabilities:debts"-     ,"--------------------"-     ,"                   0"-     ]--    ,"accounts report with unmatched parent of two matched subaccounts" ~:-     defreportopts{patterns_=["cash","saving"]} `gives`-     ["                 $-1  assets"-     ,"                  $1    bank:saving"-     ,"                 $-2    cash"-     ,"--------------------"-     ,"                 $-1"-     ]--    ,"accounts report with multi-part account name" ~:-     defreportopts{patterns_=["expenses:food"]} `gives`-     ["                  $1  expenses:food"-     ,"--------------------"-     ,"                  $1"-     ]--    ,"accounts report with negative account pattern" ~:-     defreportopts{patterns_=["not:assets"]} `gives`-     ["                  $2  expenses"-     ,"                  $1    food"-     ,"                  $1    supplies"-     ,"                 $-2  income"-     ,"                 $-1    gifts"-     ,"                 $-1    salary"-     ,"                  $1  liabilities:debts"-     ,"--------------------"-     ,"                  $1"-     ]--    ,"accounts report negative account pattern always matches full name" ~:-     defreportopts{patterns_=["not:e"]} `gives`-     ["--------------------"-     ,"                   0"-     ]--    ,"accounts report negative patterns affect totals" ~:-     defreportopts{patterns_=["expenses","not:food"]} `gives`-     ["                  $1  expenses:supplies"-     ,"--------------------"-     ,"                  $1"-     ]--    ,"accounts report with -E shows zero-balance accounts" ~:-     defreportopts{patterns_=["assets"],empty_=True} `gives`-     ["                 $-1  assets"-     ,"                  $1    bank"-     ,"                   0      checking"-     ,"                  $1      saving"-     ,"                 $-2    cash"-     ,"--------------------"-     ,"                 $-1"-     ]--    ,"accounts report with cost basis" ~: do-       j <- (readJournal def Nothing $ unlines-              [""-              ,"2008/1/1 test           "-              ,"  a:b          10h @ $50"-              ,"  c:d                   "-              ]) >>= either error' return-       let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment-       balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is`-         ["                $500  a:b"-         ,"               $-500  c:d"-         ,"--------------------"-         ,"                   0"-         ]--}- ]- Right samplejournal2 =   journalBalanceTransactions False     nulljournal{@@ -389,14 +203,219 @@       ]     } --- tests_isInterestingIndented = [---   "isInterestingIndented" ~: do---    let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r---           where l = ledgerFromJournal (queryFromOpts nulldate opts) journal+-- tests ---    (defreportopts, samplejournal, "expenses") `gives` True---  ]+tests_BalanceReport = tests "BalanceReport" [+  tests "balanceReport" $+    let+      (opts,journal) `gives` r = do+        let (eitems, etotal) = r+            (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal+            showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt)+        (map showw eitems) `is` (map showw aitems)+        (showMixedAmountDebug etotal) `is` (showMixedAmountDebug atotal)+      usd0 = usd 0+    in [+  +     test "balanceReport with no args on null journal" $+     (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])+  +    ,test "balanceReport with no args on sample journal" $+     (defreportopts, samplejournal) `gives`+      ([+        ("assets","assets",0, mamountp' "$0.00")+       ,("assets:bank","bank",1, mamountp' "$2.00")+       ,("assets:bank:checking","checking",2, mamountp' "$1.00")+       ,("assets:bank:saving","saving",2, mamountp' "$1.00")+       ,("assets:cash","cash",1, mamountp' "$-2.00")+       ,("expenses","expenses",0, mamountp' "$2.00")+       ,("expenses:food","food",1, mamountp' "$1.00")+       ,("expenses:supplies","supplies",1, mamountp' "$1.00")+       ,("income","income",0, mamountp' "$-2.00")+       ,("income:gifts","gifts",1, mamountp' "$-1.00")+       ,("income:salary","salary",1, mamountp' "$-1.00")+       ],+       Mixed [usd0])+  +    ,test "balanceReport with --depth=N" $+     (defreportopts{depth_=Just 1}, samplejournal) `gives`+      ([+       ("expenses",    "expenses",    0, mamountp'  "$2.00")+       ,("income",      "income",      0, mamountp' "$-2.00")+       ],+       Mixed [usd0])+  +    ,test "balanceReport with depth:N" $+     (defreportopts{query_="depth:1"}, samplejournal) `gives`+      ([+       ("expenses",    "expenses",    0, mamountp'  "$2.00")+       ,("income",      "income",      0, mamountp' "$-2.00")+       ],+       Mixed [usd0])+  +    ,tests "balanceReport with a date or secondary date span" [+     (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`+      ([],+       Mixed [nullamt])+     ,(defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`+      ([+        ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")+       ,("income:salary","income:salary",0,mamountp' "$-1.00")+       ],+       Mixed [usd0])+     ] -tests_Hledger_Reports_BalanceReport :: Test-tests_Hledger_Reports_BalanceReport = TestList-  tests_balanceReport+    ,test "balanceReport with desc:" $+     (defreportopts{query_="desc:income"}, samplejournal) `gives`+      ([+        ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")+       ,("income:salary","income:salary",0, mamountp' "$-1.00")+       ],+       Mixed [usd0])+  +    ,test "balanceReport with not:desc:" $+     (defreportopts{query_="not:desc:income"}, samplejournal) `gives`+      ([+        ("assets","assets",0, mamountp' "$-1.00")+       ,("assets:bank:saving","bank:saving",1, mamountp' "$1.00")+       ,("assets:cash","cash",1, mamountp' "$-2.00")+       ,("expenses","expenses",0, mamountp' "$2.00")+       ,("expenses:food","food",1, mamountp' "$1.00")+       ,("expenses:supplies","supplies",1, mamountp' "$1.00")+       ,("income:gifts","income:gifts",0, mamountp' "$-1.00")+       ],+       Mixed [usd0])+  +    ,test "balanceReport with period on a populated period" $+      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives`+       (+        [+         ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00")+        ,("income:salary","income:salary",0, mamountp' "$-1.00")+        ],+        Mixed [usd0])+  +     ,test "balanceReport with period on an unpopulated period" $+      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`+       ([],Mixed [nullamt])+  +  +  +  {-+      ,test "accounts report with account pattern o" ~:+       defreportopts{patterns_=["o"]} `gives`+       ["                  $1  expenses:food"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"--------------------"+       ,"                 $-1"+       ]+  +      ,test "accounts report with account pattern o and --depth 1" ~:+       defreportopts{patterns_=["o"],depth_=Just 1} `gives`+       ["                  $1  expenses"+       ,"                 $-2  income"+       ,"--------------------"+       ,"                 $-1"+       ]+  +      ,test "accounts report with account pattern a" ~:+       defreportopts{patterns_=["a"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"                 $-1  income:salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                 $-1"+       ]+  +      ,test "accounts report with account pattern e" ~:+       defreportopts{patterns_=["e"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"                  $2  expenses"+       ,"                  $1    food"+       ,"                  $1    supplies"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                   0"+       ]+  +      ,test "accounts report with unmatched parent of two matched subaccounts" ~:+       defreportopts{patterns_=["cash","saving"]} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank:saving"+       ,"                 $-2    cash"+       ,"--------------------"+       ,"                 $-1"+       ]+  +      ,test "accounts report with multi-part account name" ~:+       defreportopts{patterns_=["expenses:food"]} `gives`+       ["                  $1  expenses:food"+       ,"--------------------"+       ,"                  $1"+       ]+  +      ,test "accounts report with negative account pattern" ~:+       defreportopts{patterns_=["not:assets"]} `gives`+       ["                  $2  expenses"+       ,"                  $1    food"+       ,"                  $1    supplies"+       ,"                 $-2  income"+       ,"                 $-1    gifts"+       ,"                 $-1    salary"+       ,"                  $1  liabilities:debts"+       ,"--------------------"+       ,"                  $1"+       ]+  +      ,test "accounts report negative account pattern always matches full name" ~:+       defreportopts{patterns_=["not:e"]} `gives`+       ["--------------------"+       ,"                   0"+       ]+  +      ,test "accounts report negative patterns affect totals" ~:+       defreportopts{patterns_=["expenses","not:food"]} `gives`+       ["                  $1  expenses:supplies"+       ,"--------------------"+       ,"                  $1"+       ]+  +      ,test "accounts report with -E shows zero-balance accounts" ~:+       defreportopts{patterns_=["assets"],empty_=True} `gives`+       ["                 $-1  assets"+       ,"                  $1    bank"+       ,"                   0      checking"+       ,"                  $1      saving"+       ,"                 $-2    cash"+       ,"--------------------"+       ,"                 $-1"+       ]+  +      ,test "accounts report with cost basis" $+         j <- (readJournal def Nothing $ unlines+                [""+                ,"2008/1/1 test           "+                ,"  a:b          10h @ $50"+                ,"  c:d                   "+                ]) >>= either error' return+         let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment+         balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is`+           ["                $500  a:b"+           ,"               $-500  c:d"+           ,"--------------------"+           ,"                   0"+           ]+  -}+   ]++ ]+

@@ -17,7 +17,6 @@ import Data.Ord import Data.Time.Calendar import Safe-import Test.HUnit --import Data.List --import Data.Maybe import qualified Data.Map as Map@@ -26,8 +25,6 @@ --import qualified Data.Text.Lazy as TL --import System.Console.CmdArgs.Explicit as C --import Lucid as L---import Text.CSV---import Test.HUnit import Text.Printf (printf) import Text.Tabular as T --import Text.Tabular.AsciiWide@@ -38,12 +35,15 @@ --import Hledger.Read (mamountp') import Hledger.Reports.ReportOptions import Hledger.Reports.ReportTypes+import Hledger.Reports.BalanceReport (sortAccountItemsLike) import Hledger.Reports.MultiBalanceReports  +-- for reference:+-- --type MultiBalanceReportRow    = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount) --type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals)-+-- --type PeriodicReportRow a = --  ( AccountName  -- ^ A full account name. --  , [a]          -- ^ The data value for each subperiod.@@ -56,7 +56,9 @@ type BudgetAverage = Average  -- | A budget report tracks expected and actual changes per account and subperiod.-type BudgetReport = PeriodicReport (Maybe Change, Maybe BudgetGoal)+type BudgetCell = (Maybe Change, Maybe BudgetGoal)+type BudgetReport = PeriodicReport BudgetCell+type BudgetReportRow = PeriodicReportRow BudgetCell  -- | Calculate budget goals from all periodic transactions, -- actual balance changes from the regular transactions,@@ -82,9 +84,55 @@       -- it should be safe to replace it with the latter, so they combine well.        | interval_ ropts == NoInterval = MultiBalanceReport (actualspans, budgetgoalitems, budgetgoaltotals)       | otherwise = budgetgoalreport +    budgetreport = combineBudgetAndActual budgetgoalreport' actualreport+    sortedbudgetreport = sortBudgetReport ropts j budgetreport   in-    dbg1 "budgetreport" $ combineBudgetAndActual budgetgoalreport' actualreport+    dbg1 "sortedbudgetreport" sortedbudgetreport +-- | Sort a budget report's rows according to options.+sortBudgetReport :: ReportOpts -> Journal -> BudgetReport -> BudgetReport+sortBudgetReport ropts j (PeriodicReport (ps, rows, trow)) = PeriodicReport (ps, sortedrows, trow)+  where+    sortedrows +      | sort_amount_ ropts && tree_ ropts = sortTreeBURByActualAmount rows+      | sort_amount_ ropts                = sortFlatBURByActualAmount rows+      | otherwise                         = sortByAccountDeclaration rows++    -- Sort a tree-mode budget report's rows by total actual amount at each level.+    sortTreeBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] +    sortTreeBURByActualAmount rows = sortedrows+      where+        anamesandrows = [(first6 r, r) | r <- rows]+        anames = map fst anamesandrows+        atotals = [(a,tot) | (a,_,_,_,(tot,_),_) <- rows]+        accounttree = accountTree "root" anames+        accounttreewithbals = mapAccounts setibalance accounttree+          where+            setibalance a = a{aibalance=+              fromMaybe 0 $ -- when there's no actual amount, assume 0; will mess up with negative amounts ? TODO +              fromMaybe (error "sortTreeByAmount 1") $ -- should not happen, but it's ugly; TODO +              lookup (aname a) atotals+              }+        sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals+        sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree+        sortedrows = sortAccountItemsLike sortedanames anamesandrows ++    -- Sort a flat-mode budget report's rows by total actual amount.+    sortFlatBURByActualAmount :: [BudgetReportRow] -> [BudgetReportRow] +    sortFlatBURByActualAmount = sortBy (maybeflip $ comparing (fst . fifth6))+      where+        maybeflip = if normalbalance_ ropts == Just NormallyNegative then id else flip++    -- Sort the report rows by account declaration order then account name. +    -- <unbudgeted> remains at the top.+    sortByAccountDeclaration rows = sortedrows+      where+        (unbudgetedrow,rows') = partition ((=="<unbudgeted>").first6) rows+        anamesandrows = [(first6 r, r) | r <- rows']+        anames = map fst anamesandrows+        sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames+        sortedrows = unbudgetedrow ++ sortAccountItemsLike sortedanames anamesandrows + -- | Use all periodic transactions in the journal to generate  -- budget transactions in the specified report period. -- Budget transactions are similar to forecast transactions except@@ -181,69 +229,11 @@         acctsdone = map first6 rows1      -- combine and re-sort rows-    -- TODO: respect hierarchy in tree mode+    -- TODO: use MBR code     -- TODO: respect --sort-amount     -- TODO: add --sort-budget to sort by budget goal amount     rows :: [PeriodicReportRow (Maybe Change, Maybe BudgetGoal)] =       sortBy (comparing first6) $ rows1 ++ rows2--- massive duplication from multiBalanceReport to handle tree mode sorting ?---      dbg1 "sorteditems" $---      sortitems items---      where---        sortitems---          | sort_amount_ opts && accountlistmode_ opts == ALTree       = sortTreeMultiBalanceReportRowsByAmount---          | sort_amount_ opts                                          = sortFlatMultiBalanceReportRowsByAmount---          | not (sort_amount_ opts) && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAccountCodeAndName---          | otherwise                                                  = sortFlatMultiBalanceReportRowsByAccountCodeAndName---          where---            -- Sort the report rows, representing a flat account list, by row total.---            sortFlatMultiBalanceReportRowsByAmount = sortBy (maybeflip $ comparing fifth6)---              where---                maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip------            -- Sort the report rows, representing a tree of accounts, by row total at each level.---            -- To do this we recreate an Account tree with the row totals as balances,---            -- so we can do a hierarchical sort, flatten again, and then reorder the---            -- report rows similarly. Yes this is pretty long winded.---            sortTreeMultiBalanceReportRowsByAmount rows = sortedrows---              where---                anamesandrows = [(first6 r, r) | r <- rows]---                anames = map fst anamesandrows---                atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]---                nametree = treeFromPaths $ map expandAccountName anames---                accounttree = nameTreeToAccount "root" nametree---                accounttreewithbals = mapAccounts setibalance accounttree---                  where---                    -- this error should not happen, but it's ugly TODO---                    setibalance a = a{aibalance=fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 1") $ lookup (aname a) atotals}---                sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals---                sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree---                -- dropped the root account, also ignore any parent accounts not in rows---                sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts------            -- Sort the report rows by account code if any, with the empty account code coming last, then account name.---            sortFlatMultiBalanceReportRowsByAccountCodeAndName = sortBy (comparing acodeandname)---              where---                acodeandname r = (acode', aname)---                  where---                    aname = first6 r---                    macode = fromMaybe Nothing $ lookup aname $ jaccounts j---                    acode' = fromMaybe maxBound macode------            -- Sort the report rows, representing a tree of accounts, by account code and then account name at each level.---            -- Convert a tree of account names, look up the account codes, sort and flatten the tree, reorder the rows.---            sortTreeMultiBalanceReportRowsByAccountCodeAndName rows = sortedrows---              where---                anamesandrows = [(first6 r, r) | r <- rows]---                anames = map fst anamesandrows---                nametree = treeFromPaths $ map expandAccountName anames---                accounttree = nameTreeToAccount "root" nametree---                accounttreewithcodes = mapAccounts (accountSetCodeFrom j) accounttree---                sortedaccounttree = sortAccountTreeByAccountCodeAndName accounttreewithcodes---                sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree---                -- dropped the root account, also ignore any parent accounts not in rows---                sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts---      -- TODO: grand total & average shows 0% when there are no actual amounts, inconsistent with other cells     totalrow =@@ -356,6 +346,7 @@ maybeAccountNameDrop opts a | flat_ opts = accountNameDrop (drop_ opts) a                             | otherwise  = a -tests_Hledger_Reports_BudgetReport :: Test-tests_Hledger_Reports_BudgetReport = TestList [-  ]+-- tests++tests_BudgetReport = tests "BudgetReport" [+ ]

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-|  Journal entries report, used by the print command.@@ -10,17 +10,17 @@   EntriesReportItem,   entriesReport,   -- * Tests-  tests_Hledger_Reports_EntriesReport+  tests_EntriesReport ) where  import Data.List import Data.Ord-import Test.HUnit  import Hledger.Data import Hledger.Query import Hledger.Reports.ReportOptions+import Hledger.Utils    -- | A journal entries report is a list of whole transactions as@@ -37,15 +37,10 @@       date = transactionDateFn opts       ts = jtxns $ journalSelectingAmountFromOpts opts j -tests_entriesReport :: [Test]-tests_entriesReport = [-  "entriesReport" ~: do-    assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal)-    let sp = mkdatespan "2008/06/01" "2008/07/01"-    assertEqual "date" 3 (length $ entriesReport defreportopts (Date sp) samplejournal)+tests_EntriesReport = tests "EntriesReport" [+  tests "entriesReport" [+     test "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) `is` 1+    ,test "date" $ (length $ entriesReport defreportopts (Date $ mkdatespan "2008/06/01" "2008/07/01") samplejournal) `is` 3+  ]  ]--tests_Hledger_Reports_EntriesReport :: Test-tests_Hledger_Reports_EntriesReport = TestList $- tests_entriesReport 

@@ -16,7 +16,7 @@   tableAsText,    -- -- * Tests-  tests_Hledger_Reports_MultiBalanceReport+  tests_MultiBalanceReports ) where @@ -25,13 +25,12 @@ import Data.Ord import Data.Time.Calendar import Safe-import Test.HUnit import Text.Tabular as T import Text.Tabular.AsciiWide  import Hledger.Data import Hledger.Query-import Hledger.Utils+import Hledger.Utils  import Hledger.Read (mamountp') import Hledger.Reports.ReportOptions import Hledger.Reports.BalanceReport@@ -69,11 +68,11 @@ type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount) -- (Totals list, sum of totals, average of totals)  instance Show MultiBalanceReport where-    -- use ppShow to break long lists onto multiple lines-    -- we add some bogus extra shows here to help ppShow parse the output+    -- use pshow (pretty-show's ppShow) to break long lists onto multiple lines+    -- we add some bogus extra shows here to help it parse the output     -- and wrap tuples and lists properly     show (MultiBalanceReport (spans, items, totals)) =-        "MultiBalanceReport (ignore extra quotes):\n" ++ ppShow (show spans, map show items, totals)+        "MultiBalanceReport (ignore extra quotes):\n" ++ pshow (show spans, map show items, totals)  -- type alias just to remind us which AccountNames might be depth-clipped, below. type ClippedAccountName = AccountName@@ -176,64 +175,45 @@            , empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals            ] +      -- TODO TBD: is it always ok to sort report rows after report has been generated ?+      -- Or does sorting sometimes need to be done as part of the report generation ?         sorteditems :: [MultiBalanceReportRow] =         dbg1 "sorteditems" $         sortitems items         where           sortitems-            | sort_amount_ opts && accountlistmode_ opts == ALTree       = sortTreeMultiBalanceReportRowsByAmount-            | sort_amount_ opts                                          = sortFlatMultiBalanceReportRowsByAmount-            | not (sort_amount_ opts) && accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAccountCodeAndName-            | otherwise                                                  = sortFlatMultiBalanceReportRowsByAccountCodeAndName+            | sort_amount_ opts && accountlistmode_ opts == ALTree       = sortTreeMBRByAmount+            | sort_amount_ opts                                          = sortFlatMBRByAmount+            | otherwise                                                  = sortMBRByAccountDeclaration             where-              -- Sort the report rows, representing a flat account list, by row total. -              sortFlatMultiBalanceReportRowsByAmount = sortBy (maybeflip $ comparing fifth6)-                where-                  maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip-               -- Sort the report rows, representing a tree of accounts, by row total at each level.-              -- To do this we recreate an Account tree with the row totals as balances, -              -- so we can do a hierarchical sort, flatten again, and then reorder the  -              -- report rows similarly. Yes this is pretty long winded. -              sortTreeMultiBalanceReportRowsByAmount rows = sortedrows+              -- Similar to sortMBRByAccountDeclaration/sortAccountNamesByDeclaration.+              sortTreeMBRByAmount rows = sortedrows                 where                   anamesandrows = [(first6 r, r) | r <- rows]                   anames = map fst anamesandrows                   atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]-                  nametree = treeFromPaths $ map expandAccountName anames-                  accounttree = nameTreeToAccount "root" nametree+                  accounttree = accountTree "root" anames                   accounttreewithbals = mapAccounts setibalance accounttree                     where-                      -- this error should not happen, but it's ugly TODO -                      setibalance a = a{aibalance=fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 1") $ lookup (aname a) atotals}+                      -- should not happen, but it's dangerous; TODO +                      setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}                   sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ opts) accounttreewithbals-                  sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree-                  -- dropped the root account, also ignore any parent accounts not in rows-                  sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts +                  sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree+                  sortedrows = sortAccountItemsLike sortedanames anamesandrows  -              -- Sort the report rows by account code if any, with the empty account code coming last, then account name. -              -- TODO keep children below their parent. Have to convert to tree ? -              sortFlatMultiBalanceReportRowsByAccountCodeAndName = sortBy (comparing acodeandname)+              -- Sort the report rows, representing a flat account list, by row total. +              sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . fifth6))                 where-                  acodeandname r = (acode', aname)-                    where-                      aname = first6 r-                      macode = fromMaybe Nothing $ lookup aname $ jaccounts j-                      acode' = fromMaybe maxBound macode +                  maybeflip = if normalbalance_ opts == Just NormallyNegative then id else flip -              -- Sort the report rows, representing a tree of accounts, by account code and then account name at each level.-              -- Convert a tree of account names, look up the account codes, sort and flatten the tree, reorder the rows.-              sortTreeMultiBalanceReportRowsByAccountCodeAndName rows = sortedrows-                where+              -- Sort the report rows by account declaration order then account name. +              sortMBRByAccountDeclaration rows = sortedrows+                where                    anamesandrows = [(first6 r, r) | r <- rows]                   anames = map fst anamesandrows-                  nametree = treeFromPaths $ map expandAccountName anames-                  accounttree = nameTreeToAccount "root" nametree-                  accounttreewithcodes = mapAccounts (accountSetCodeFrom j) accounttree-                  sortedaccounttree = sortAccountTreeByAccountCodeAndName accounttreewithcodes-                  sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree-                  -- dropped the root account, also ignore any parent accounts not in rows-                  sortedrows = concatMap (\a -> maybe [] (:[]) $ lookup (aname a) anamesandrows) sortedaccounts +                  sortedanames = sortAccountNamesByDeclaration j (tree_ opts) anames+                  sortedrows = sortAccountItemsLike sortedanames anamesandrows         totals :: [MixedAmount] =           -- dbg1 "totals" $@@ -285,53 +265,6 @@     total = headDef nullmixedamt totals  -tests_multiBalanceReport =-  let-    (opts,journal) `gives` r = do-      let (eitems, etotal) = r-          (MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal-          showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')-      assertEqual "items" (map showw eitems) (map showw aitems)-      assertEqual "total" (showMixedAmountDebug etotal) ((\(_, b, _) -> showMixedAmountDebug b) atotal) -- we only check the sum of the totals-    usd0 = usd 0-    amount0 = Amount {acommodity="$", aquantity=0, aprice=NoPrice, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, amultiplier=False}-  in [-   "multiBalanceReport with no args on null journal" ~: do-   (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])--   ,"multiBalanceReport with -H on a populated period" ~: do-    (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`-     (-      [-       ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-      ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-      ],-      Mixed [usd0])--   ,"multiBalanceReport tests the ability to have a valid history on an empty period" ~: do-    (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`-     (-      [-       ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-      ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-      ],-      Mixed [usd0])--   ,"multiBalanceReport tests the ability to have a valid history on an empty period (More complex)" ~: do-    (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`-     (-      [-      ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-      ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])-      ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amount0 {aquantity=(-2)}])-      ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])-      ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])-      ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-      ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])-      ],-      Mixed [usd0])-  ]- -- common rendering helper, XXX here for now  tableAsText :: ReportOpts -> (a -> String) -> Table String String a -> String@@ -348,6 +281,53 @@         acctswidth = maximum' $ map strWidth (headerContents l)         l'         = padRightWide acctswidth <$> l -tests_Hledger_Reports_MultiBalanceReport :: Test-tests_Hledger_Reports_MultiBalanceReport = TestList-  tests_multiBalanceReport+-- tests++tests_MultiBalanceReports = tests "MultiBalanceReports" [+  let+    (opts,journal) `gives` r = do+      let (eitems, etotal) = r+          (MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal+          showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')+      (map showw aitems) `is` (map showw eitems)+      ((\(_, b, _) -> showMixedAmountDebug b) atotal) `is` (showMixedAmountDebug etotal) -- we only check the sum of the totals+    usd0 = usd 0+    amount0 = Amount {acommodity="$", aquantity=0, aprice=NoPrice, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, amultiplier=False}+  in +   tests "multiBalanceReport" [+      test "null journal"  $+      (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])+  +     ,test "with -H on a populated period"  $+      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`+       (+        [+         ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])+        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])+        ],+        Mixed [usd0])+  +     ,test "a valid history on an empty period"  $+      (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`+       (+        [+         ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])+        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])+        ],+        Mixed [usd0])+  +     ,test "a valid history on an empty period (more complex)"  $+      (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`+       (+        [+        ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])+        ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])+        ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amount0 {aquantity=(-2)}])+        ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])+        ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])+        ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])+        ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}])+        ],+        Mixed [usd0])+    ]+ ]

@@ -12,7 +12,7 @@   mkpostingsReportItem,    -- * Tests-  tests_Hledger_Reports_PostingsReport+  tests_PostingsReport ) where @@ -23,11 +23,10 @@ import qualified Data.Text as T import Data.Time.Calendar import Safe (headMay, lastMay)-import Test.HUnit  import Hledger.Data import Hledger.Query-import Hledger.Utils+import Hledger.Utils  import Hledger.Reports.ReportOptions  @@ -175,11 +174,6 @@       summarisespan s = summarisePostingsInDateSpan s wd depth showempty (postingsinspan s)       postingsinspan s = filter (isPostingInDateSpan' wd s) ps -tests_summarisePostingsByInterval = [-  "summarisePostingsByInterval" ~: do-    summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] ~?= []- ]- -- | A summary posting summarises the activity in one account within a report -- interval. It is currently kludgily represented by a regular Posting with no -- description, the interval's start date stored as the posting date, and the@@ -221,210 +215,214 @@           bal = if isclipped a then aibalance else aebalance           isclipped a = accountNameLevel a >= depth --- tests_summarisePostingsInDateSpan = [-  --  "summarisePostingsInDateSpan" ~: do-  --   let gives (b,e,depth,showempty,ps) =-  --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)-  --   let ps =-  --           [-  --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 2]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}-  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 8]}-  --           ]-  --   ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`-  --    []-  --   ("2008/01/01","2009/01/01",0,9999,True,[]) `gives`-  --    [-  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}-  --    ]-  --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`-  --    [-  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}-  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 10]}-  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}-  --    ]-  --   ("2008/01/01","2009/01/01",0,2,False,ts) `gives`-  --    [-  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]}-  --    ]-  --   ("2008/01/01","2009/01/01",0,1,False,ts) `gives`-  --    [-  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]}-  --    ]-  --   ("2008/01/01","2009/01/01",0,0,False,ts) `gives`-  --    [-  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]}-  --    ]--tests_postingsReport = [-  "postingsReport" ~: do--   -- with the query specified explicitly-   let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n-   (Any, nulljournal) `gives` 0-   (Any, samplejournal) `gives` 13-   -- register --depth just clips account names-   (Depth 2, samplejournal) `gives` 13-   (And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2-   (And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2--   -- with query and/or command-line options-   assertEqual "" 13 (length $ snd $ postingsReport defreportopts Any samplejournal)-   assertEqual "" 11 (length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal)-   assertEqual "" 20 (length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal)-   assertEqual ""  5 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal)--   -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0-   -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking             $1,$1)-   -- ,(Nothing,income:salary                   $-1,0)-   -- ,(Just (2008-06-01,"gift"),assets:bank:checking             $1,$1)-   -- ,(Nothing,income:gifts                    $-1,0)-   -- ,(Just (2008-06-02,"save"),assets:bank:saving               $1,$1)-   -- ,(Nothing,assets:bank:checking            $-1,0)-   -- ,(Just (2008-06-03,"eat & shop"),expenses:food                    $1,$1)-   -- ,(Nothing,expenses:supplies                $1,$2)-   -- ,(Nothing,assets:cash                     $-2,0)-   -- ,(Just (2008-12-31,"pay off"),liabilities:debts                $1,$1)-   -- ,(Nothing,assets:bank:checking            $-1,0)-   -- ]--{--    let opts = defreportopts-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/01/01 income               assets:bank:checking             $1           $1"-     ,"                                income:salary                   $-1            0"-     ,"2008/06/01 gift                 assets:bank:checking             $1           $1"-     ,"                                income:gifts                    $-1            0"-     ,"2008/06/02 save                 assets:bank:saving               $1           $1"-     ,"                                assets:bank:checking            $-1            0"-     ,"2008/06/03 eat & shop           expenses:food                    $1           $1"-     ,"                                expenses:supplies                $1           $2"-     ,"                                assets:cash                     $-2            0"-     ,"2008/12/31 pay off              liabilities:debts                $1           $1"-     ,"                                assets:bank:checking            $-1            0"-     ]--  ,"postings report with cleared option" ~:-   do-    let opts = defreportopts{cleared_=True}-    j <- readJournal' sample_journal_str-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/06/03 eat & shop           expenses:food                    $1           $1"-     ,"                                expenses:supplies                $1           $2"-     ,"                                assets:cash                     $-2            0"-     ,"2008/12/31 pay off              liabilities:debts                $1           $1"-     ,"                                assets:bank:checking            $-1            0"-     ]--  ,"postings report with uncleared option" ~:-   do-    let opts = defreportopts{uncleared_=True}-    j <- readJournal' sample_journal_str-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/01/01 income               assets:bank:checking             $1           $1"-     ,"                                income:salary                   $-1            0"-     ,"2008/06/01 gift                 assets:bank:checking             $1           $1"-     ,"                                income:gifts                    $-1            0"-     ,"2008/06/02 save                 assets:bank:saving               $1           $1"-     ,"                                assets:bank:checking            $-1            0"-     ]--  ,"postings report sorts by date" ~:-   do-    j <- readJournal' $ unlines-        ["2008/02/02 a"-        ,"  b  1"-        ,"  c"-        ,""-        ,"2008/01/01 d"-        ,"  e  1"-        ,"  f"-        ]-    let opts = defreportopts-    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]--  ,"postings report with account pattern" ~:-   do-    j <- samplejournal-    let opts = defreportopts{patterns_=["cash"]}-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"-     ]--  ,"postings report with account pattern, case insensitive" ~:-   do-    j <- samplejournal-    let opts = defreportopts{patterns_=["cAsH"]}-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"-     ]--  ,"postings report with display expression" ~:-   do-    j <- samplejournal-    let gives displayexpr =-            (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`)-                where opts = defreportopts{display_=Just displayexpr}-    "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]-    "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]-    "d=[2008/6/2]"  `gives` ["2008/06/02"]-    "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]-    "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]+-- tests -  ,"postings report with period expression" ~:-   do-    j <- samplejournal-    let periodexpr `gives` dates = do-          j' <- samplejournal-          registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates-              where opts = defreportopts{period_=maybePeriod date1 periodexpr}-    ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]-    "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]-    "2007" `gives` []-    "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]-    "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]-    "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]-    let opts = defreportopts{period_=maybePeriod date1 "yearly"}-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"-     ,"                                assets:cash                     $-2          $-1"-     ,"                                expenses:food                    $1            0"-     ,"                                expenses:supplies                $1           $1"-     ,"                                income:gifts                    $-1            0"-     ,"                                income:salary                   $-1          $-1"-     ,"                                liabilities:debts                $1            0"-     ]-    let opts = defreportopts{period_=maybePeriod date1 "quarterly"}-    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]-    let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True}-    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]+tests_PostingsReport = tests "PostingsReport" [ -  ]+   tests "postingsReport" $+    let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n+    in [+     -- with the query specified explicitly+      (Any, nulljournal) `gives` 0+     ,(Any, samplejournal) `gives` 13+     -- register --depth just clips account names+     ,(Depth 2, samplejournal) `gives` 13+     ,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2+     ,(And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2+  +     -- with query and/or command-line options+     ,(length $ snd $ postingsReport defreportopts Any samplejournal) `is` 13+     ,(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) `is` 11+     ,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20+     ,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5+  +     -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0+     -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking             $1,$1)+     -- ,(Nothing,income:salary                   $-1,0)+     -- ,(Just (2008-06-01,"gift"),assets:bank:checking             $1,$1)+     -- ,(Nothing,income:gifts                    $-1,0)+     -- ,(Just (2008-06-02,"save"),assets:bank:saving               $1,$1)+     -- ,(Nothing,assets:bank:checking            $-1,0)+     -- ,(Just (2008-06-03,"eat & shop"),expenses:food                    $1,$1)+     -- ,(Nothing,expenses:supplies                $1,$2)+     -- ,(Nothing,assets:cash                     $-2,0)+     -- ,(Just (2008-12-31,"pay off"),liabilities:debts                $1,$1)+     -- ,(Nothing,assets:bank:checking            $-1,0)     -  , "postings report with depth arg" ~:-   do-    j <- samplejournal-    let opts = defreportopts{depth_=Just 2}-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines-     ["2008/01/01 income               assets:bank                      $1           $1"-     ,"                                income:salary                   $-1            0"-     ,"2008/06/01 gift                 assets:bank                      $1           $1"-     ,"                                income:gifts                    $-1            0"-     ,"2008/06/02 save                 assets:bank                      $1           $1"-     ,"                                assets:bank                     $-1            0"-     ,"2008/06/03 eat & shop           expenses:food                    $1           $1"-     ,"                                expenses:supplies                $1           $2"-     ,"                                assets:cash                     $-2            0"-     ,"2008/12/31 pay off              liabilities:debts                $1           $1"-     ,"                                assets:bank                     $-1            0"-     ]+    {-+        let opts = defreportopts+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank:checking             $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank:saving               $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"2008/12/31 pay off              liabilities:debts                $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ]+    +      ,"postings report with cleared option" ~:+       do+        let opts = defreportopts{cleared_=True}+        j <- readJournal' sample_journal_str+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"2008/12/31 pay off              liabilities:debts                $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ]+    +      ,"postings report with uncleared option" ~:+       do+        let opts = defreportopts{uncleared_=True}+        j <- readJournal' sample_journal_str+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank:checking             $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank:saving               $1           $1"+         ,"                                assets:bank:checking            $-1            0"+         ]+    +      ,"postings report sorts by date" ~:+       do+        j <- readJournal' $ unlines+            ["2008/02/02 a"+            ,"  b  1"+            ,"  c"+            ,""+            ,"2008/01/01 d"+            ,"  e  1"+            ,"  f"+            ]+        let opts = defreportopts+        registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]+    +      ,"postings report with account pattern" ~:+       do+        j <- samplejournal+        let opts = defreportopts{patterns_=["cash"]}+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+         ]+    +      ,"postings report with account pattern, case insensitive" ~:+       do+        j <- samplejournal+        let opts = defreportopts{patterns_=["cAsH"]}+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+         ]+    +      ,"postings report with display expression" ~:+       do+        j <- samplejournal+        let gives displayexpr =+                (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`)+                    where opts = defreportopts{display_=Just displayexpr}+        "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]+        "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]+        "d=[2008/6/2]"  `gives` ["2008/06/02"]+        "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]+        "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]+    +      ,"postings report with period expression" ~:+       do+        j <- samplejournal+        let periodexpr `gives` dates = do+              j' <- samplejournal+              registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates+                  where opts = defreportopts{period_=maybePeriod date1 periodexpr}+        ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+        "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+        "2007" `gives` []+        "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]+        "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]+        "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]+        let opts = defreportopts{period_=maybePeriod date1 "yearly"}+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"+         ,"                                assets:cash                     $-2          $-1"+         ,"                                expenses:food                    $1            0"+         ,"                                expenses:supplies                $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"                                income:salary                   $-1          $-1"+         ,"                                liabilities:debts                $1            0"+         ]+        let opts = defreportopts{period_=maybePeriod date1 "quarterly"}+        registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]+        let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True}+        registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]+    +      ]+    +      , "postings report with depth arg" ~:+       do+        j <- samplejournal+        let opts = defreportopts{depth_=Just 2}+        (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+         ["2008/01/01 income               assets:bank                      $1           $1"+         ,"                                income:salary                   $-1            0"+         ,"2008/06/01 gift                 assets:bank                      $1           $1"+         ,"                                income:gifts                    $-1            0"+         ,"2008/06/02 save                 assets:bank                      $1           $1"+         ,"                                assets:bank                     $-1            0"+         ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+         ,"                                expenses:supplies                $1           $2"+         ,"                                assets:cash                     $-2            0"+         ,"2008/12/31 pay off              liabilities:debts                $1           $1"+         ,"                                assets:bank                     $-1            0"+         ]+    +    -}+    ] --}+  ,tests "summarisePostingsByInterval" [+    tests "summarisePostingsByInterval" [+      summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` []+      ]+   ]+  +  -- ,tests_summarisePostingsInDateSpan = [+    --  "summarisePostingsInDateSpan" ~: do+    --   let gives (b,e,depth,showempty,ps) =+    --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)+    --   let ps =+    --           [+    --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 2]}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}+    --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 8]}+    --           ]+    --   ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`+    --    []+    --   ("2008/01/01","2009/01/01",0,9999,True,[]) `gives`+    --    [+    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}+    --    ]+    --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`+    --    [+    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=Mixed [usd 4]}+    --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [usd 10]}+    --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]}+    --    ]+    --   ("2008/01/01","2009/01/01",0,2,False,ts) `gives`+    --    [+    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]}+    --    ]+    --   ("2008/01/01","2009/01/01",0,1,False,ts) `gives`+    --    [+    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]}+    --    ]+    --   ("2008/01/01","2009/01/01",0,0,False,ts) `gives`+    --    [+    --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]}+    --    ]+    ]--tests_Hledger_Reports_PostingsReport :: Test-tests_Hledger_Reports_PostingsReport = TestList $-    tests_summarisePostingsByInterval- ++ tests_postingsReport-