hledger-lib 0.27.1 → 1.0

raw patch · 57 files changed

+8596/−2910 lines, 57 filesdep +Globdep +data-defaultdep +doctestdep ~parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, data-default, doctest, ghc-prim, megaparsec, semigroups, text

Dependency ranges changed: parsec

API changes (from Hackage documentation)

Files

• CHANGES +149/−4
• Hledger.hs +8/−12
• Hledger/Data.hs +5/−4
• Hledger/Data/Account.hs +7/−4
• Hledger/Data/AccountName.hs +35/−28
• Hledger/Data/Amount.hs +16/−31
• Hledger/Data/Commodity.hs +11/−5
• Hledger/Data/Dates.hs +176/−209
• Hledger/Data/Journal.hs +206/−110
• Hledger/Data/Ledger.hs +6/−4
• Hledger/Data/Period.hs +262/−0
• Hledger/Data/Posting.hs +19/−14
• Hledger/Data/RawOptions.hs +3/−2
• Hledger/Data/StringFormat.hs +15/−14
• Hledger/Data/TimeLog.hs +0/−142
• Hledger/Data/Timeclock.hs +145/−0
• Hledger/Data/Transaction.hs +42/−19
• Hledger/Data/Types.hs +166/−121
• Hledger/Query.hs +115/−82
• Hledger/Read.hs +114/−107
• Hledger/Read/Common.hs +828/−0
• Hledger/Read/CsvReader.hs +139/−114
• Hledger/Read/JournalReader.hs +722/−1201
• Hledger/Read/TimeclockReader.hs +125/−0
• Hledger/Read/TimedotReader.hs +159/−0
• Hledger/Read/TimelogReader.hs +0/−116
• Hledger/Reports.hs +2/−2
• Hledger/Reports/BalanceHistoryReport.hs +1/−0
• Hledger/Reports/BalanceReport.hs +105/−82
• Hledger/Reports/MultiBalanceReports.hs +53/−36
• Hledger/Reports/PostingsReport.hs +79/−41
• Hledger/Reports/ReportOptions.hs +162/−137
• Hledger/Reports/TransactionsReports.hs +116/−88
• Hledger/Utils.hs +40/−8
• Hledger/Utils/Debug.hs +59/−61
• Hledger/Utils/Parse.hs +43/−17
• Hledger/Utils/String.hs +4/−21
• Hledger/Utils/Test.hs +5/−4
• Hledger/Utils/Text.hs +414/−0
• Hledger/Utils/Tree.hs +1/−1
• README +3/−0
• doc/hledger_csv.5 +239/−0
• doc/hledger_csv.5.info +231/−0
• doc/hledger_csv.5.txt +169/−0
• doc/hledger_journal.5 +926/−0
• doc/hledger_journal.5.info +995/−0
• doc/hledger_journal.5.txt +700/−0
• doc/hledger_timeclock.5 +100/−0
• doc/hledger_timeclock.5.info +67/−0
• doc/hledger_timeclock.5.txt +82/−0
• doc/hledger_timedot.5 +144/−0
• doc/hledger_timedot.5.info +121/−0
• doc/hledger_timedot.5.txt +123/−0
• hledger-lib.cabal +124/−63
• tests/doctests.hs +9/−0
• tests/hunittests.hs +6/−0
• tests/suite.hs +0/−6

@@ -1,9 +1,154 @@-API-ish changes in hledger-lib.-For user-visible changes, see hledger's change log.+API-ish changes in the hledger-lib package.+(For user-visible changes, see hledger's change log.) -0.27.1 (2016/05/27) -- GHC 8 compatibility+# 1.0 (2016/10/26)++## timedot format++-   new "timedot" format for retroactive/approximate time logging.++    Timedot is a plain text format for logging dated, categorised+    quantities (eg time), supported by hledger.  It is convenient+    for approximate and retroactive time logging, eg when the+    real-time clock-in/out required with a timeclock file is too+    precise or too interruptive.  It can be formatted like a bar+    chart, making clear at a glance where time was spent.++## timeclock format++-   renamed "timelog" format to "timeclock", matching the emacs package++-   sessions can no longer span file boundaries (unclocked-out++    sessions will be auto-closed at the end of the file).++-   transaction ids now count up rather than down (#394)++-   timeclock files no longer support default year directives++-   removed old code for appending timeclock transactions to journal transactions.++    A holdover from the days when both were allowed in one file.++## csv format++-   fix empty field assignment parsing, rule parse errors after megaparsec port (#407) (Hans-Peter Deifel)++## journal format++-   journal files can now include timeclock or timedot files (#320)++    (but not yet CSV files).++-   fixed an issue with ordering of same-date transactions included from other files++-   the "commodity" directive and "format" subdirective are now supported, allowing++    full control of commodity style (#295) The commodity directive's+    format subdirective can now be used to override the inferred+    style for a commodity, eg to increase or decrease the+    precision. This is at least a good workaround for #295.++-   Ledger-style "apply account"/"end apply account" directives are now used to set a default parent account.++-   the Ledger-style "account" directive is now accepted (and ignored).++-   bracketed posting dates are more robust (#304)++    Bracketed posting dates were fragile; they worked only if you+    wrote full 10-character dates. Also some semantics were a bit+    unclear. Now they should be robust, and have been documented+    more clearly. This is a legacy undocumented Ledger syntax, but+    it improves compatibility and might be preferable to the more+    verbose "date:" tags if you write posting dates often (as I do).+    Internally, bracketed posting dates are no longer considered to+    be tags.  Journal comment, tag, and posting date parsers have+    been reworked, all with doctests.++-   balance assertion failure messages are clearer++-   with --debug=2, more detail about balance assertions is shown.++## misc++-   file parsers have been ported from Parsec to Megaparsec \o/ (#289, #366) (Alexey Shmalko, Moritz Kiefer)++-   most hledger types have been converted from String to Text, reducing memory usage by 30%+ on large files and giving a slight speed increase++-   file parsers have been simplified for easier troubleshooting (#275).++    The journal/timeclock/timedot parsers, instead of constructing+    opaque journal update functions which are later applied to build+    the journal, now construct the journal directly by modifying the+    parser state. This is easier to understand and debug. It also+    rules out the possibility of journal updates being a space+    leak. (They weren't, in fact this change increased memory usage+    slightly, but that has been addressed in other ways).  The+    ParsedJournal type alias has been added to distinguish+    "being-parsed" journals and "finalised" journals.++-   file format detection is more robust.++    The Journal, Timelog and Timedot readers' detectors now check+    each line in the sample data, not just the first one. I think the+    sample data is only about 30 chars right now, but even so this+    fixed a format detection issue I was seeing. +    Also, we now always try parsing stdin as journal format (not just sometimes).++-   all file formats now produce transaction ids, not just journal (#394)++-   git clone of the hledger repo on windows now works (#345)++-   added missing benchmark file (#342)++-   our stack.yaml files are more compatible across stack versions (#300)++-   use newer file-embed to fix ghci working directory dependence (<https://github.com/snoyberg/file-embed/issues/18>)++-   report more accurate dates in account transaction report when postings have their own dates++    (affects hledger-ui and hledger-web registers).+    The newly-named "transaction register date" is the date to be+    displayed for that transaction in a transaction register, for+    some current account and filter query.  It is either the+    transaction date from the journal ("transaction general date"),+    or if postings to the current account and matched by the+    register's filter query have their own dates, the earliest of+    those posting dates.++-   simplify account transactions report's running total.++    The account transactions report used for hledger-ui and -web+    registers now gives either the "period total" or "historical+    total", depending strictly on the --historical flag. It doesn't+    try to indicate whether the historical total is the accurate+    historical balance (which depends on the user's report query).++-   reloading a file now preserves the effect of options, query arguments etc.++-   reloading a journal should now reload all included files as well.++-   the Hledger.Read.\* modules have been reorganised for better reuse.++    Hledger.Read.Utils has been renamed Hledger.Read.Common+    and holds low-level parsers & utilities; high-level read+    utilities are now in Hledger.Read.++-   clarify amount display style canonicalisation code and terminology a bit.++    Individual amounts still have styles; from these we derive+    the standard "commodity styles". In user docs, we might call+    these "commodity formats" since they can be controlled by the+    "format" subdirective in journal files.++-   Journal is now a monoid++-   expandPath now throws a proper IO error++-   more unit tests, start using doctest++   0.27 (2015/10/30)

@@ -1,19 +1,15 @@ module Hledger (-                module Hledger.Data-               ,module Hledger.Query-               ,module Hledger.Read-               ,module Hledger.Reports-               ,module Hledger.Utils-               ,tests_Hledger+  module X+ ,tests_Hledger ) where-import Test.HUnit+import           Test.HUnit -import Hledger.Data-import Hledger.Query-import Hledger.Read hiding (samplejournal)-import Hledger.Reports-import Hledger.Utils+import           Hledger.Data    as X+import           Hledger.Query   as X+import           Hledger.Read    as X hiding (samplejournal)+import           Hledger.Reports as X+import           Hledger.Utils   as X  tests_Hledger = TestList     [

@@ -15,10 +15,11 @@                module Hledger.Data.Dates,                module Hledger.Data.Journal,                module Hledger.Data.Ledger,+               module Hledger.Data.Period,                module Hledger.Data.Posting,                module Hledger.Data.RawOptions,                module Hledger.Data.StringFormat,-               module Hledger.Data.TimeLog,+               module Hledger.Data.Timeclock,                module Hledger.Data.Transaction,                module Hledger.Data.Types,                tests_Hledger_Data@@ -33,10 +34,11 @@ import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Ledger+import Hledger.Data.Period import Hledger.Data.Posting import Hledger.Data.RawOptions import Hledger.Data.StringFormat-import Hledger.Data.TimeLog+import Hledger.Data.Timeclock import Hledger.Data.Transaction import Hledger.Data.Types @@ -47,13 +49,12 @@     ,tests_Hledger_Data_AccountName     ,tests_Hledger_Data_Amount     ,tests_Hledger_Data_Commodity-    ,tests_Hledger_Data_Dates     ,tests_Hledger_Data_Journal     ,tests_Hledger_Data_Ledger     ,tests_Hledger_Data_Posting     -- ,tests_Hledger_Data_RawOptions     -- ,tests_Hledger_Data_StringFormat-    ,tests_Hledger_Data_TimeLog+    ,tests_Hledger_Data_Timeclock     ,tests_Hledger_Data_Transaction     -- ,tests_Hledger_Data_Types     ]

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, StandaloneDeriving #-}+{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings #-} {-|  @@ -52,9 +52,12 @@   , aboring = False   } --- | Derive 1. an account tree and 2. their balances from a list of postings.--- (ledger's core feature). The accounts are returned in a list, but--- retain their tree structure; the first one is the root of the tree.+-- | Derive 1. an account tree and 2. each account's total exclusive+-- and inclusive changes from a list of postings.+-- This is the core of the balance command (and of *ledger).+-- The accounts are returned as a list in flattened tree order,+-- and also reference each other as a tree.+-- (The first account is the root of the tree.) accountsFromPostings :: [Posting] -> [Account] accountsFromPostings ps =   let

@@ -1,4 +1,4 @@-{-# LANGUAGE NoMonomorphismRestriction#-}+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-|  'AccountName's are strings like @assets:cash:petty@, with multiple@@ -10,7 +10,9 @@ module Hledger.Data.AccountName where import Data.List-import Data.List.Split (splitOn)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T import Data.Tree import Test.HUnit import Text.Printf@@ -19,24 +21,29 @@ import Hledger.Utils  ---- change to use a different separator for nested accounts+acctsepchar :: Char acctsepchar = ':' -accountNameComponents :: AccountName -> [String]-accountNameComponents = splitAtElement acctsepchar+acctsep :: Text+acctsep = T.pack [acctsepchar] -accountNameFromComponents :: [String] -> AccountName-accountNameFromComponents = concat . intersperse [acctsepchar]+-- accountNameComponents :: AccountName -> [String]+-- accountNameComponents = splitAtElement acctsepchar -accountLeafName :: AccountName -> String+accountNameComponents :: AccountName -> [Text]+accountNameComponents = T.splitOn acctsep++accountNameFromComponents :: [Text] -> AccountName+accountNameFromComponents = T.intercalate acctsep++accountLeafName :: AccountName -> Text accountLeafName = last . accountNameComponents  -- | Truncate all account name components but the last to two characters.-accountSummarisedName :: AccountName -> String+accountSummarisedName :: AccountName -> Text accountSummarisedName a   --   length cs > 1 = take 2 (head cs) ++ ":" ++ a'-  | length cs > 1 = intercalate ":" (map (take 2) $ init cs) ++ ":" ++ a'+  | length cs > 1 = (T.intercalate ":" (map (T.take 2) $ init cs)) <> ":" <> a'   | otherwise     = a'     where       cs = accountNameComponents a@@ -44,7 +51,7 @@  accountNameLevel :: AccountName -> Int accountNameLevel "" = 0-accountNameLevel a = length (filter (==acctsepchar) a) + 1+accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1  accountNameDrop :: Int -> AccountName -> AccountName accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents@@ -72,7 +79,7 @@  -- | Is the first account a parent or other ancestor of (and not the same as) the second ? isAccountNamePrefixOf :: AccountName -> AccountName -> Bool-isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])+isAccountNamePrefixOf = T.isPrefixOf . (<> acctsep)  isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p =@@ -113,22 +120,22 @@ elideAccountName :: Int -> AccountName -> AccountName elideAccountName width s   -- XXX special case for transactions register's multi-account pseudo-names-  | " (split)" `isSuffixOf` s =+  | " (split)" `T.isSuffixOf` s =     let-      names = splitOn ", " $ take (length s - 8) s+      names = T.splitOn ", " $ T.take (T.length s - 8) s       widthpername = (max 0 (width - 8 - 2 * (max 1 (length names) - 1))) `div` length names     in-     fitString Nothing (Just width) True False $-     (++" (split)") $-     intercalate ", " $+     fitText Nothing (Just width) True False $+     (<>" (split)") $+     T.intercalate ", " $      [accountNameFromComponents $ elideparts widthpername [] $ accountNameComponents s' | s' <- names]   | otherwise =-    fitString Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s+    fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where-        elideparts :: Int -> [String] -> [String] -> [String]+        elideparts :: Int -> [Text] -> [Text] -> [Text]         elideparts width done ss-          | strWidth (accountNameFromComponents $ done++ss) <= width = done++ss-          | length ss > 1 = elideparts width (done++[takeWidth 2 $ head ss]) (tail ss)+          | textWidth (accountNameFromComponents $ done++ss) <= width = done++ss+          | length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss)           | otherwise = done++ss  -- | Keep only the first n components of an account name, where n@@ -143,18 +150,18 @@ clipOrEllipsifyAccountName n = accountNameFromComponents . take n . accountNameComponents  -- | Convert an account name to a regular expression matching it and its subaccounts.-accountNameToAccountRegex :: String -> String+accountNameToAccountRegex :: AccountName -> Regexp accountNameToAccountRegex "" = ""-accountNameToAccountRegex a = printf "^%s(:|$)" a+accountNameToAccountRegex a = printf "^%s(:|$)" (T.unpack a)  -- | Convert an account name to a regular expression matching it but not its subaccounts.-accountNameToAccountOnlyRegex :: String -> String+accountNameToAccountOnlyRegex :: AccountName -> Regexp accountNameToAccountOnlyRegex "" = ""-accountNameToAccountOnlyRegex a = printf "^%s$" a+accountNameToAccountOnlyRegex a = printf "^%s$"  $ T.unpack a -- XXX pack  -- | Convert an exact account-matching regular expression to a plain account name.-accountRegexToAccountName :: String -> String-accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1"+accountRegexToAccountName :: Regexp -> AccountName+accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack  -- | Does this string look like an exact account-matching regular expression ? isAccountRegex  :: String -> Bool

@@ -1,7 +1,6 @@-{-# LANGUAGE CPP, StandaloneDeriving, RecordWildCards #-} {-| A simple 'Amount' is some quantity of money, shares, or anything else.-It has a (possibly null) 'Commodity' and a numeric quantity:+It has a (possibly null) 'CommoditySymbol' and a numeric quantity:  @   $1@@ -41,6 +40,8 @@  -} +{-# LANGUAGE CPP, StandaloneDeriving, RecordWildCards, OverloadedStrings #-}+ module Hledger.Data.Amount (   -- * Amount   amount,@@ -101,15 +102,13 @@ ) where  import Data.Char (isDigit)-#ifdef DOUBLE-roundTo = flip const-#else import Data.Decimal (roundTo)-#endif import Data.Function (on) import Data.List import Data.Map (findWithDefault) import Data.Maybe+-- import Data.Text (Text)+import qualified Data.Text as T import Test.HUnit import Text.Printf import qualified Data.Map as M@@ -180,7 +179,7 @@  -- | Convert an amount to the specified commodity, ignoring and discarding -- any assigned prices and assuming an exchange rate of 1.-amountWithCommodity :: Commodity -> Amount -> Amount+amountWithCommodity :: CommoditySymbol -> Amount -> Amount amountWithCommodity c a = a{acommodity=c, aprice=NoPrice}  -- | Convert an amount to the commodity of its assigned price, if any.  Notes:@@ -211,16 +210,8 @@                | otherwise     = (null . filter (`elem` digits) . showAmountWithoutPriceOrCommodity) a  -- | Is this amount "really" zero, regardless of the display precision ?--- Since we are using floating point, for now just test to some high precision. isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount Amount{aquantity=q} = iszero q-  where-   iszero =-#ifdef DOUBLE-    null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") where zeroprecision = 8-#else-    (==0)-#endif+isReallyZeroAmount Amount{aquantity=q} = q == 0  -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision.@@ -270,14 +261,14 @@ showAmountHelper _ Amount{acommodity="AUTO"} = "" showAmountHelper showzerocommodity a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) =     case ascommodityside of-      L -> printf "%s%s%s%s" c' space quantity' price-      R -> printf "%s%s%s%s" quantity' space c' price+      L -> printf "%s%s%s%s" (T.unpack c') space quantity' price+      R -> printf "%s%s%s%s" quantity' space (T.unpack c') price     where       quantity = showamountquantity a       displayingzero = null $ filter (`elem` digits) $ quantity       (quantity',c') | displayingzero && not showzerocommodity = ("0","")                      | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)-      space = if (not (null c') && ascommodityspaced) then " " else "" :: String+      space = if (not (T.null c') && ascommodityspaced) then " " else "" :: String       price = showPrice p  -- | Like showAmount, but show a zero amount's commodity if it has one.@@ -292,15 +283,9 @@     where       -- isint n = fromIntegral (round n) == n       qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer)-#ifdef DOUBLE-        | p == maxprecisionwithpoint = printf "%f" q-        | p == maxprecision          = chopdotzero $ printf "%f" q-        | otherwise                  = printf ("%."++show p++"f") q-#else         | p == maxprecisionwithpoint = show q         | p == maxprecision          = chopdotzero $ show q         | otherwise                  = show $ roundTo (fromIntegral p) q-#endif  -- | Replace a number string's decimal point with the specified character, -- and add the specified digit group separators. The last digit group will@@ -340,7 +325,7 @@  -- like journalCanonicaliseAmounts -- | Canonicalise an amount's display style using the provided commodity style map.-canonicaliseAmount :: M.Map Commodity AmountStyle -> Amount -> Amount+canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}     where       s' = findWithDefault s c styles@@ -449,9 +434,9 @@ sumSimilarAmountsUsingFirstPrice [] = nullamt sumSimilarAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as} --- | Sum same-commodity amounts. If there were different prices, set--- the price to a special marker indicating "various". Only used as a--- rendering helper.+-- -- | Sum same-commodity amounts. If there were different prices, set+-- -- the price to a special marker indicating "various". Only used as a+-- -- rendering helper. -- sumSimilarAmountsNotingPriceDifference :: [Amount] -> Amount -- sumSimilarAmountsNotingPriceDifference [] = nullamt -- sumSimilarAmountsNotingPriceDifference as = undefined@@ -468,7 +453,7 @@ -- with the specified commodity and the quantity of that commodity -- found in the original. NB if Amount's quantity is zero it will be -- discarded next time the MixedAmount gets normalised.-filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount+filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount filterMixedAmountByCommodity c (Mixed as) = Mixed as'   where     as' = case filter ((==c) . acommodity) as of@@ -580,7 +565,7 @@       stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}  -- | Canonicalise a mixed amount's display styles using the provided commodity style map.-canonicaliseMixedAmount :: M.Map Commodity AmountStyle -> MixedAmount -> MixedAmount+canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as  -------------------------------------------------------------------------------

@@ -6,10 +6,16 @@ are thousands separated by comma, significant decimal places and so on.  -}++{-# LANGUAGE OverloadedStrings #-}+ module Hledger.Data.Commodity where import Data.List import Data.Maybe (fromMaybe)+import Data.Monoid+-- import Data.Text (Text)+import qualified Data.Text as T import Test.HUnit -- import qualified Data.Map as M @@ -18,9 +24,9 @@   -- characters that may not be used in a non-quoted commodity symbol-nonsimplecommoditychars = "0123456789-+.@;\n \"{}=" :: String+nonsimplecommoditychars = "0123456789-+.@;\n \"{}=" :: [Char] -quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\""+quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) (T.unpack s) = "\"" <> s <> "\""                                | otherwise = s  commodity = ""@@ -42,18 +48,18 @@   ]  -- | Look up one of the sample commodities' symbol by name.-comm :: String -> Commodity+comm :: String -> CommoditySymbol comm name = snd $ fromMaybe               (error' "commodity lookup failed")               (find (\n -> fst n == name) commoditysymbols)  -- | Find the conversion rate between two commodities. Currently returns 1.-conversionRate :: Commodity -> Commodity -> Double+conversionRate :: CommoditySymbol -> CommoditySymbol -> Double conversionRate _ _ = 1  -- -- | Convert a list of commodities to a map from commodity symbols to -- -- unique, display-preference-canonicalised commodities.--- canonicaliseCommodities :: [Commodity] -> Map.Map String Commodity+-- canonicaliseCommodities :: [CommoditySymbol] -> Map.Map String CommoditySymbol -- canonicaliseCommodities cs = --     Map.fromList [(s,firstc{precision=maxp}) | s <- symbols, --                   let cs = commoditymap ! s,

@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-} {-|  Date parsing and utilities for hledger.@@ -19,6 +21,8 @@ An 'Interval' is ledger's \"reporting interval\" - weekly, monthly, quarterly, etc. +'Period' will probably replace DateSpan in due course.+ -}  -- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?@@ -38,7 +42,6 @@   prevday,   parsePeriodExpr,   nulldatespan,-  tests_Hledger_Data_Dates,   failIfInvalidYear,   failIfInvalidMonth,   failIfInvalidDay,@@ -69,6 +72,8 @@ import Control.Monad import Data.List.Compat import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T #if MIN_VERSION_time(1,5,0) import Data.Time.Format hiding (months) #else@@ -77,82 +82,30 @@ #endif import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate-import Data.Time.Calendar.WeekDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay)-import Test.HUnit-import Text.Parsec+import Text.Megaparsec+import Text.Megaparsec.Text import Text.Printf  import Hledger.Data.Types+import Hledger.Data.Period import Hledger.Utils   -- Help ppShow parse and line-wrap DateSpans better in debug output. instance Show DateSpan where-    show (DateSpan s1 s2) = "DateSpan \"" ++ show s1 ++ "\" \"" ++ show s2 ++ "\""+    show s = "DateSpan " ++ showDateSpan s+    -- show s = "DateSpan \"" ++ showDateSpan s ++ "\"" -- quotes to help pretty-show  showDate :: Day -> String showDate = formatTime defaultTimeLocale "%0C%y/%m/%d" --- XXX review for more boundary crossing issues -- | Render a datespan as a display string, abbreviating into a -- compact form if possible.-showDateSpan ds@(DateSpan (Just from) (Just to)) =-  case (toGregorian from, toGregorian to) of-    -- special cases we can abbreviate:-    -- a year, YYYY-    ((fy,1,1), (ty,1,1))   | fy+1==ty           -> formatTime defaultTimeLocale "%0C%y" from-    -- a half, YYYYhN-    ((fy,1,1), (ty,7,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yh1" from-    ((fy,7,1), (ty,1,1))   | fy+1==ty           -> formatTime defaultTimeLocale "%0C%yh2" from-    -- a quarter, YYYYqN-    ((fy,1,1), (ty,4,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yq1" from-    ((fy,4,1), (ty,7,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yq2" from-    ((fy,7,1), (ty,10,1))  | fy==ty             -> formatTime defaultTimeLocale "%0C%yq3" from-    ((fy,10,1), (ty,1,1))  | fy+1==ty           -> formatTime defaultTimeLocale "%0C%yq4" from-    -- a month, YYYY/MM-    ((fy,fm,1), (ty,tm,1)) | fy==ty && fm+1==tm -> formatTime defaultTimeLocale "%0C%y/%m" from-    ((fy,12,1), (ty,1,1))  | fy+1==ty           -> formatTime defaultTimeLocale "%0C%y/%m" from-    -- a week (two successive mondays),-    -- YYYYwN ("week N of year YYYY")-    -- _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate to) in fy==ty && fw+1==tw && fd==1 && td==1-    --                                             -> formatTime defaultTimeLocale "%0f%gw%V" from-    -- YYYY/MM/DDwN ("week N, starting on YYYY/MM/DD")-    _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate (addDays (-1) to)) in fy==ty && fw==tw && fd==1 && td==7-                                                -> formatTime defaultTimeLocale "%0C%y/%m/%dw%V" from-    -- a day, YYYY/MM/DDd (d suffix is to distinguish from a regular date in register)-    ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm==tm && fd+1==td -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from-    -- crossing a year boundary-    ((fy,fm,fd), (ty,tm,td)) | fy+1==ty && fm==12 && tm==1 && fd==31 && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from-    -- crossing a month boundary XXX wrongly shows LEAPYEAR/2/28-LEAPYEAR/3/1 as LEAPYEAR/2/28-    ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm+1==tm && fd `elem` fromMaybe [] (lookup fm lastdayofmonth) && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from-    -- otherwise, YYYY/MM/DD-YYYY/MM/DD-    _                                           -> showDateSpan' ds-  where lastdayofmonth = [(1,[31])-                         ,(2,[28,29])-                         ,(3,[31])-                         ,(4,[30])-                         ,(5,[31])-                         ,(6,[30])-                         ,(7,[31])-                         ,(8,[31])-                         ,(9,[30])-                         ,(10,[31])-                         ,(11,[30])-                         ,(12,[31])-                         ]--showDateSpan ds = showDateSpan' ds---- | Render a datespan as a display string.-showDateSpan' (DateSpan from to) =-  concat-    [maybe "" showDate from-    ,"-"-    ,maybe "" (showDate . prevday) to-    ]+showDateSpan :: DateSpan -> String+showDateSpan = showPeriod . dateSpanAsPeriod  -- | Get the current local date. getCurrentDay :: IO Day@@ -189,6 +142,32 @@  -- | Split a DateSpan into one or more consecutive whole spans of the specified length which enclose it. -- If no interval is specified, the original span is returned.+--+-- ==== Examples:+-- >>> let t i d1 d2 = splitSpan i $ mkdatespan d1 d2+-- >>> t NoInterval "2008/01/01" "2009/01/01"+-- [DateSpan 2008]+-- >>> t (Quarters 1) "2008/01/01" "2009/01/01"+-- [DateSpan 2008q1,DateSpan 2008q2,DateSpan 2008q3,DateSpan 2008q4]+-- >>> splitSpan (Quarters 1) nulldatespan+-- [DateSpan -]+-- >>> t (Days 1) "2008/01/01" "2008/01/01"  -- an empty datespan+-- [DateSpan 2008/01/01-2007/12/31]+-- >>> t (Quarters 1) "2008/01/01" "2008/01/01"+-- [DateSpan 2008/01/01-2007/12/31]+-- >>> t (Months 1) "2008/01/01" "2008/04/01"+-- [DateSpan 2008/01,DateSpan 2008/02,DateSpan 2008/03]+-- >>> t (Months 2) "2008/01/01" "2008/04/01"+-- [DateSpan 2008/01/01-2008/02/29,DateSpan 2008/03/01-2008/04/30]+-- >>> t (Weeks 1) "2008/01/01" "2008/01/15"+-- [DateSpan 2007/12/31w01,DateSpan 2008/01/07w02,DateSpan 2008/01/14w03]+-- >>> t (Weeks 2) "2008/01/01" "2008/01/15"+-- [DateSpan 2007/12/31-2008/01/13,DateSpan 2008/01/14-2008/01/27]+-- >>> t (DayOfMonth 2) "2008/01/01" "2008/04/01"+-- [DateSpan 2008/01/02-2008/02/01,DateSpan 2008/02/02-2008/03/01,DateSpan 2008/03/02-2008/04/01]+-- >>> t (DayOfWeek 2) "2011/01/01" "2011/01/15"+-- [DateSpan 2011/01/04-2011/01/10,DateSpan 2011/01/11-2011/01/17]+-- splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval     s = [s]@@ -271,10 +250,10 @@  -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date, or return a parse error.-parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan)+parsePeriodExpr :: Day -> Text -> Either (ParseError Char Dec) (Interval, DateSpan) parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof) -maybePeriod :: Day -> String -> Maybe (Interval,DateSpan)+maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate  -- | Show a DateSpan as a human-readable pseudo-period-expression string.@@ -327,22 +306,93 @@  -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date, or raise an error.-fixSmartDateStr :: Day -> String -> String+fixSmartDateStr :: Day -> Text -> String fixSmartDateStr d s = either                        (\e->error' $ printf "could not parse date %s %s" (show s) (show e))                        id-                       $ fixSmartDateStrEither d s+                       $ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String)  -- | A safe version of fixSmartDateStr.-fixSmartDateStrEither :: Day -> String -> Either ParseError String+fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Dec) String fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d -fixSmartDateStrEither' :: Day -> String -> Either ParseError Day-fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of+fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Dec) Day+fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of                                Right sd -> Right $ fixSmartDate d sd                                Left e -> Left e  -- | Convert a SmartDate to an absolute date using the provided reference date.+--+-- ==== Examples:+-- >>> let t = fixSmartDateStr (parsedate "2008/11/26")+-- >>> t "0000-01-01"+-- "0000/01/01"+-- >>> t "1999-12-02"+-- "1999/12/02"+-- >>> t "1999.12.02"+-- "1999/12/02"+-- >>> t "1999/3/2"+-- "1999/03/02"+-- >>> t "19990302"+-- "1999/03/02"+-- >>> t "2008/2"+-- "2008/02/01"+-- >>> t "0020/2"+-- "0020/02/01"+-- >>> t "1000"+-- "1000/01/01"+-- >>> t "4/2"+-- "2008/04/02"+-- >>> t "2"+-- "2008/11/02"+-- >>> t "January"+-- "2008/01/01"+-- >>> t "feb"+-- "2008/02/01"+-- >>> t "today"+-- "2008/11/26"+-- >>> t "yesterday"+-- "2008/11/25"+-- >>> t "tomorrow"+-- "2008/11/27"+-- >>> t "this day"+-- "2008/11/26"+-- >>> t "last day"+-- "2008/11/25"+-- >>> t "next day"+-- "2008/11/27"+-- >>> t "this week"  -- last monday+-- "2008/11/24"+-- >>> t "last week"  -- previous monday+-- "2008/11/17"+-- >>> t "next week"  -- next monday+-- "2008/12/01"+-- >>> t "this month"+-- "2008/11/01"+-- >>> t "last month"+-- "2008/10/01"+-- >>> t "next month"+-- "2008/12/01"+-- >>> t "this quarter"+-- "2008/10/01"+-- >>> t "last quarter"+-- "2008/07/01"+-- >>> t "next quarter"+-- "2009/01/01"+-- >>> t "this year"+-- "2008/01/01"+-- >>> t "last year"+-- "2007/01/01"+-- >>> t "next year"+-- "2009/01/01"+--+-- t "last wed"+-- "2008/11/19"+-- t "next friday"+-- "2008/11/28"+-- t "next january"+-- "2009/01/01"+-- fixSmartDate :: Day -> SmartDate -> Day fixSmartDate refdate sdate = fix sdate     where@@ -448,7 +498,10 @@ -- parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"") --                             (parsedatetimeM s) --- | Parse a date string to a time type, or raise an error.+-- | Parse a YYYY-MM-DD or YYYY/MM/DD date string to a Day, or raise an error. For testing/debugging.+--+-- >>> parsedate "2008/02/03"+-- 2008-02-03 parsedate :: String -> Day parsedate s =  fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"")                          (parsedateM s)@@ -471,8 +524,8 @@  -- | Parse a time string to a time type using the provided pattern, or -- return the default.-parsetimewith :: ParseTime t => String -> String -> t -> t-parsetimewith pat s def = fromMaybe def $ parsetime defaultTimeLocale pat s+_parsetimewith :: ParseTime t => String -> String -> t -> t+_parsetimewith pat s def = fromMaybe def $ parsetime defaultTimeLocale pat s  {-| Parse a date in any of the formats allowed in ledger's period expressions,@@ -490,22 +543,23 @@ Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Assumes any text in the parse stream has been lowercased. -}-smartdate :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+smartdate :: Parser SmartDate smartdate = do   -- XXX maybe obscures date errors ? see ledgerdate   (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]   return (y,m,d)  -- | Like smartdate, but there must be nothing other than whitespace after the date.-smartdateonly :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+smartdateonly :: Parser SmartDate smartdateonly = do   d <- smartdate   many spacenonewline   eof   return d +datesepchars :: [Char] datesepchars = "/-."-datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char+datesepchar :: TextParser m Char datesepchar = oneOf datesepchars  validYear, validMonth, validDay :: String -> Bool@@ -518,54 +572,54 @@ failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidDay s   = unless (validDay s)   $ fail $ "bad day number: " ++ s -yyyymmdd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+yyyymmdd :: Parser SmartDate yyyymmdd = do-  y <- count 4 digit-  m <- count 2 digit+  y <- count 4 digitChar+  m <- count 2 digitChar   failIfInvalidMonth m-  d <- count 2 digit+  d <- count 2 digitChar   failIfInvalidDay d   return (y,m,d) -ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+ymd :: Parser SmartDate ymd = do-  y <- many1 digit+  y <- some digitChar   failIfInvalidYear y   sep <- datesepchar-  m <- many1 digit+  m <- some digitChar   failIfInvalidMonth m   char sep-  d <- many1 digit+  d <- some digitChar   failIfInvalidDay d   return $ (y,m,d) -ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+ym :: Parser SmartDate ym = do-  y <- many1 digit+  y <- some digitChar   failIfInvalidYear y   datesepchar-  m <- many1 digit+  m <- some digitChar   failIfInvalidMonth m   return (y,m,"") -y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+y :: Parser SmartDate y = do-  y <- many1 digit+  y <- some digitChar   failIfInvalidYear y   return (y,"","") -d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+d :: Parser SmartDate d = do-  d <- many1 digit+  d <- some digitChar   failIfInvalidDay d   return ("","",d) -md :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+md :: Parser SmartDate md = do-  m <- many1 digit+  m <- some digitChar   failIfInvalidMonth m   datesepchar-  d <- many1 digit+  d <- some digitChar   failIfInvalidDay d   return ("",m,d) @@ -578,24 +632,24 @@ monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monIndex s   = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs -month :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+month :: Parser SmartDate month = do   m <- choice $ map (try . string) months   let i = monthIndex m   return ("",show i,"") -mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+mon :: Parser SmartDate mon = do   m <- choice $ map (try . string) monthabbrevs   let i = monIndex m   return ("",show i,"") -today,yesterday,tomorrow :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+today,yesterday,tomorrow :: Parser SmartDate today     = string "today"     >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow  = string "tomorrow"  >> return ("","","tomorrow") -lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m SmartDate+lastthisnextthing :: Parser SmartDate lastthisnextthing = do   r <- choice [         string "last"@@ -615,7 +669,19 @@    return ("",r,p) -periodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)+-- |+-- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) :: T.Text -> Either (ParseError Char Dec) (Interval, DateSpan)+-- >>> p "from aug to oct"+-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)+-- >>> p "aug to oct"+-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)+-- >>> p "every 3 days in aug"+-- Right (Days 3,DateSpan 2008/08)+-- >>> p "daily from aug"+-- Right (Days 1,DateSpan 2008/08/01-)+-- >>> p "every week to 2009"+-- Right (Weeks 1,DateSpan -2008/12/31)+periodexpr :: Day -> Parser (Interval, DateSpan) periodexpr rdate = choice $ map try [                     intervalanddateperiodexpr rdate,                     intervalperiodexpr,@@ -623,7 +689,7 @@                     (return (NoInterval,DateSpan Nothing Nothing))                    ] -intervalanddateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)+intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan) intervalanddateperiodexpr rdate = do   many spacenonewline   i <- reportinginterval@@ -631,20 +697,20 @@   s <- periodexprdatespan rdate   return (i,s) -intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan)+intervalperiodexpr :: Parser (Interval, DateSpan) intervalperiodexpr = do   many spacenonewline   i <- reportinginterval   return (i, DateSpan Nothing Nothing) -dateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan)+dateperiodexpr :: Day -> Parser (Interval, DateSpan) dateperiodexpr rdate = do   many spacenonewline   s <- periodexprdatespan rdate   return (NoInterval, s)  -- Parse a reporting interval.-reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m Interval+reportinginterval :: Parser Interval reportinginterval = choice' [                        tryinterval "day"     "daily"     Days,                        tryinterval "week"    "weekly"    Weeks,@@ -657,7 +723,7 @@                           return $ Months 2,                        do string "every"                           many spacenonewline-                          n <- fmap read $ many1 digit+                          n <- fmap read $ some digitChar                           thsuffix                           many spacenonewline                           string "day"@@ -668,7 +734,7 @@                           return $ DayOfWeek n,                        do string "every"                           many spacenonewline-                          n <- fmap read $ many1 digit+                          n <- fmap read $ some digitChar                           thsuffix                           many spacenonewline                           string "day"@@ -684,7 +750,7 @@       thsuffix = choice' $ map string ["st","nd","rd","th"]        -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".-      tryinterval :: Stream [Char] m Char => String -> String -> (Int -> Interval) -> ParsecT [Char] st m Interval+      tryinterval :: String -> String -> (Int -> Interval) -> Parser Interval       tryinterval singular compact intcons =           choice' [            do string compact@@ -695,14 +761,14 @@               return $ intcons 1,            do string "every"               many spacenonewline-              n <- fmap read $ many1 digit+              n <- fmap read $ some digitChar               many spacenonewline               string plural               return $ intcons n            ]           where plural = singular ++ "s" -periodexprdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan+periodexprdatespan :: Day -> Parser DateSpan periodexprdatespan rdate = choice $ map try [                             doubledatespan rdate,                             fromdatespan rdate,@@ -710,7 +776,7 @@                             justdatespan rdate                            ] -doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan+doubledatespan :: Day -> Parser DateSpan doubledatespan rdate = do   optional (string "from" >> many spacenonewline)   b <- smartdate@@ -719,7 +785,7 @@   e <- smartdate   return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) -fromdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan+fromdatespan :: Day -> Parser DateSpan fromdatespan rdate = do   b <- choice [     do@@ -733,13 +799,13 @@     ]   return $ DateSpan (Just $ fixSmartDate rdate b) Nothing -todatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan+todatespan :: Day -> Parser DateSpan todatespan rdate = do   choice [string "to", string "-"] >> many spacenonewline   e <- smartdate   return $ DateSpan Nothing (Just $ fixSmartDate rdate e) -justdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan+justdatespan :: Day -> Parser DateSpan justdatespan rdate = do   optional (string "in" >> many spacenonewline)   d <- smartdate@@ -754,103 +820,4 @@ nulldatespan = DateSpan Nothing Nothing  nulldate :: Day-nulldate = parsedate "0000/01/01"--tests_Hledger_Data_Dates = TestList- [--   "parsedate" ~: do-    let date1 = parsedate "2008/11/26"-    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1-    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1--  ,"period expressions" ~: do-    let todaysdate = parsedate "2008/11/26"-    let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result)-    "from aug to oct"           `gives` "(NoInterval,DateSpan \"Just 2008-08-01\" \"Just 2008-10-01\")"-    "aug to oct"                `gives` "(NoInterval,DateSpan \"Just 2008-08-01\" \"Just 2008-10-01\")"-    "every 3 days in aug"       `gives` "(Days 3,DateSpan \"Just 2008-08-01\" \"Just 2008-09-01\")"-    "daily from aug"            `gives` "(Days 1,DateSpan \"Just 2008-08-01\" \"Nothing\")"-    "every week to 2009"        `gives` "(Weeks 1,DateSpan \"Nothing\" \"Just 2009-01-01\")"--  ,"splitSpan" ~: do-    let gives (interval, span) = (splitSpan interval span `is`)-    (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2009/01/01"]-    (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/04/01"-     ,mkdatespan "2008/04/01" "2008/07/01"-     ,mkdatespan "2008/07/01" "2008/10/01"-     ,mkdatespan "2008/10/01" "2009/01/01"-     ]-    (Quarters 1,nulldatespan) `gives`-     [nulldatespan]-    (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-    (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-    (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/01" "2008/02/01"-     ,mkdatespan "2008/02/01" "2008/03/01"-     ,mkdatespan "2008/03/01" "2008/04/01"-     ]-    (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/01" "2008/03/01"-     ,mkdatespan "2008/03/01" "2008/05/01"-     ]-    (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives`-     [mkdatespan "2007/12/31" "2008/01/07"-     ,mkdatespan "2008/01/07" "2008/01/14"-     ,mkdatespan "2008/01/14" "2008/01/21"-     ]-    (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives`-     [mkdatespan "2007/12/31" "2008/01/14"-     ,mkdatespan "2008/01/14" "2008/01/28"-     ]-    (DayOfMonth 2,mkdatespan "2008/01/01" "2008/04/01") `gives`-     [mkdatespan "2008/01/02" "2008/02/02"-     ,mkdatespan "2008/02/02" "2008/03/02"-     ,mkdatespan "2008/03/02" "2008/04/02"-     ]-    (DayOfWeek 2,mkdatespan "2011/01/01" "2011/01/15") `gives`-     [mkdatespan "2011/01/04" "2011/01/11"-     ,mkdatespan "2011/01/11" "2011/01/18"-     ]--  ,"fixSmartDateStr" ~: do-    let gives = is . fixSmartDateStr (parsedate "2008/11/26")-    "0000-01-01"   `gives` "0000/01/01"-    "1999-12-02"   `gives` "1999/12/02"-    "1999.12.02"   `gives` "1999/12/02"-    "1999/3/2"     `gives` "1999/03/02"-    "19990302"     `gives` "1999/03/02"-    "2008/2"       `gives` "2008/02/01"-    "0020/2"       `gives` "0020/02/01"-    "1000"         `gives` "1000/01/01"-    "4/2"          `gives` "2008/04/02"-    "2"            `gives` "2008/11/02"-    "January"      `gives` "2008/01/01"-    "feb"          `gives` "2008/02/01"-    "today"        `gives` "2008/11/26"-    "yesterday"    `gives` "2008/11/25"-    "tomorrow"     `gives` "2008/11/27"-    "this day"     `gives` "2008/11/26"-    "last day"     `gives` "2008/11/25"-    "next day"     `gives` "2008/11/27"-    "this week"    `gives` "2008/11/24" -- last monday-    "last week"    `gives` "2008/11/17" -- previous monday-    "next week"    `gives` "2008/12/01" -- next monday-    "this month"   `gives` "2008/11/01"-    "last month"   `gives` "2008/10/01"-    "next month"   `gives` "2008/12/01"-    "this quarter" `gives` "2008/10/01"-    "last quarter" `gives` "2008/07/01"-    "next quarter" `gives` "2009/01/01"-    "this year"    `gives` "2008/01/01"-    "last year"    `gives` "2007/01/01"-    "next year"    `gives` "2009/01/01"---     "last wed"     `gives` "2008/11/19"---     "next friday"  `gives` "2008/11/28"---     "next january" `gives` "2009/01/01"-- ]+nulldate = fromGregorian 0 1 1

@@ -1,4 +1,4 @@--- {-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-} {-|  A 'Journal' is a set of transactions, plus optional related data.  This is@@ -12,11 +12,11 @@   addMarketPrice,   addModifierTransaction,   addPeriodicTransaction,-  addTimeLogEntry,   addTransaction,   journalApplyAliases,   journalBalanceTransactions,-  journalCanonicaliseAmounts,+  journalApplyCommodityStyles,+  commodityStylesFromAmounts,   journalConvertAmountsToCost,   journalFinalise,   -- * Filtering@@ -24,6 +24,7 @@   filterJournalPostings,   filterJournalAmounts,   filterTransactionAmounts,+  filterTransactionPostings,   filterPostingAmount,   -- * Querying   journalAccountNames,@@ -49,10 +50,12 @@   journalEquityAccountQuery,   journalCashAccountQuery,   -- * Misc-  canonicalStyles,+  canonicalStyleFrom,   matchpats,-  nullctx,   nulljournal,+  journalCheckBalanceAssertions,+  journalNumberAndTieTransactions,+  journalUntieTransactions,   -- * Tests   samplejournal,   tests_Hledger_Data_Journal,@@ -62,12 +65,13 @@ import Data.List -- import Data.Map (findWithDefault) import Data.Maybe+import Data.Monoid import Data.Ord-import Safe (headMay)+import Data.Text (Text)+import qualified Data.Text as T+import Safe (headMay, headDef) import Data.Time.Calendar-import Data.Time.LocalTime import Data.Tree-import Safe (headDef) import System.Time (ClockTime(TOD)) import Test.HUnit import Text.Printf@@ -81,10 +85,14 @@ import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.Posting-import Hledger.Data.TimeLog import Hledger.Query  +-- try to make Journal ppShow-compatible+-- instance Show ClockTime where+--   show t = "<ClockTime>"+-- deriving instance Show Journal+ instance Show Journal where   show j     | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts"@@ -107,7 +115,7 @@               length (jperiodictxns j))              (length accounts)              (show accounts)-             (show $ jcommoditystyles j)+             (show $ jinferredcommodities j)              -- ++ (show $ journalTransactions l)              where accounts = filter (/= "root") $ flatten $ journalAccountNameTree j @@ -116,37 +124,73 @@ --                      ,show (jtxns j) --                      ,show (jmodifiertxns j) --                      ,show (jperiodictxns j)---                      ,show $ open_timelog_entries j+--                      ,show $ jparsetimeclockentries j --                      ,show $ jmarketprices j---                      ,show $ final_comment_lines j---                      ,show $ jContext j---                      ,show $ map fst $ files j+--                      ,show $ jfinalcommentlines j+--                      ,show $ jparsestate j+--                      ,show $ map fst $ jfiles j --                      ] -nulljournal :: Journal-nulljournal = Journal { jmodifiertxns = []-                      , jperiodictxns = []-                      , jtxns = []-                      , open_timelog_entries = []-                      , jmarketprices = []-                      , final_comment_lines = []-                      , jContext = nullctx-                      , files = []-                      , filereadtime = TOD 0 0-                      , jcommoditystyles = M.fromList []-                      }+-- The monoid instance for Journal is useful for two situations.+-- +-- 1. concatenating finalised journals, eg with multiple -f options:+-- FIRST <> SECOND. The second's list fields are appended to the+-- first's, map fields are combined, transaction counts are summed,+-- the parse state of the second is kept.+-- +-- 2. merging a child parsed journal, eg with the include directive:+-- CHILD <> PARENT. A parsed journal's data is in reverse order, so+-- this gives what we want.+--+instance Monoid Journal where+  mempty = nulljournal+  mappend j1 j2 = Journal {+     jparsedefaultyear          = jparsedefaultyear          j2+    ,jparsedefaultcommodity     = jparsedefaultcommodity     j2+    ,jparseparentaccounts       = jparseparentaccounts       j2+    ,jparsealiases              = jparsealiases              j2+    -- ,jparsetransactioncount     = jparsetransactioncount     j1 +  jparsetransactioncount     j2+    ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2+    ,jaccounts                  = jaccounts                  j1 <> jaccounts                  j2+    ,jcommodities               = jcommodities               j1 <> jcommodities               j2+    ,jinferredcommodities       = jinferredcommodities       j1 <> jinferredcommodities       j2+    ,jmarketprices              = jmarketprices              j1 <> jmarketprices              j2+    ,jmodifiertxns              = jmodifiertxns              j1 <> jmodifiertxns              j2+    ,jperiodictxns              = jperiodictxns              j1 <> jperiodictxns              j2+    ,jtxns                      = jtxns                      j1 <> jtxns                      j2+    ,jfinalcommentlines         = jfinalcommentlines         j2+    ,jfiles                     = jfiles                     j1 <> jfiles                     j2+    ,jlastreadtime              = max (jlastreadtime j1) (jlastreadtime j2)+    } -nullctx :: JournalContext-nullctx = Ctx{ctxYear=Nothing, ctxDefaultCommodityAndStyle=Nothing, ctxAccount=[], ctxAliases=[], ctxTransactionIndex=0}+nulljournal :: Journal+nulljournal = Journal {+   jparsedefaultyear          = Nothing+  ,jparsedefaultcommodity     = Nothing+  ,jparseparentaccounts       = []+  ,jparsealiases              = []+  -- ,jparsetransactioncount     = 0+  ,jparsetimeclockentries = []+  ,jaccounts                  = []+  ,jcommodities               = M.fromList []+  ,jinferredcommodities       = M.fromList []+  ,jmarketprices              = []+  ,jmodifiertxns              = []+  ,jperiodictxns              = []+  ,jtxns                      = []+  ,jfinalcommentlines         = ""+  ,jfiles                     = []+  ,jlastreadtime              = TOD 0 0+  }  journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile  journalFilePaths :: Journal -> [FilePath]-journalFilePaths = map fst . files+journalFilePaths = map fst . jfiles -mainfile :: Journal -> (FilePath, String)-mainfile = headDef ("", "") . files+mainfile :: Journal -> (FilePath, Text)+mainfile = headDef ("", "") . jfiles  addTransaction :: Transaction -> Journal -> Journal addTransaction t j = j { jtxns = t : jtxns j }@@ -160,9 +204,6 @@ addMarketPrice :: MarketPrice -> Journal -> Journal addMarketPrice h j = j { jmarketprices = h : jmarketprices j } -addTimeLogEntry :: TimeLogEntry -> Journal -> Journal-addTimeLogEntry tle j = j { open_timelog_entries = tle : open_timelog_entries j }- -- | Get the transaction with this index (its 1-based position in the input stream), if any. journalTransactionAt :: Journal -> Integer -> Maybe Transaction journalTransactionAt Journal{jtxns=ts} i =@@ -172,13 +213,13 @@ -- | Get the transaction that appeared immediately after this one in the input stream, if any. journalNextTransaction :: Journal -> Transaction -> Maybe Transaction journalNextTransaction j t = journalTransactionAt j (tindex t + 1)-  + -- | Get the transaction that appeared immediately before this one in the input stream, if any. journalPrevTransaction :: Journal -> Transaction -> Maybe Transaction journalPrevTransaction j t = journalTransactionAt j (tindex t - 1)-  + -- | Unique transaction descriptions used in this journal.-journalDescriptions :: Journal -> [String]+journalDescriptions :: Journal -> [Text] journalDescriptions = nub . sort . map tdescription . jtxns  -- | All postings from this journal's transactions, in order.@@ -258,9 +299,7 @@ -- | Keep only postings matching the query expression. -- This can leave unbalanced transactions. filterJournalPostings :: Query -> Journal -> Journal-filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}-    where-      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}+filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionPostings q) ts}  -- | Within each posting's amount, keep only the parts matching the query. -- This can leave unbalanced transactions.@@ -276,6 +315,10 @@ filterPostingAmount :: Query -> Posting -> Posting filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as} +filterTransactionPostings :: Query -> Transaction -> Transaction+filterTransactionPostings q t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}++ {- ------------------------------------------------------------------------------- -- filtering V1@@ -414,25 +457,40 @@       dotransaction t@Transaction{tpostings=ps} = t{tpostings=map doposting ps}       doposting p@Posting{paccount=a} = p{paccount= accountNameApplyAliases aliases a} --- | Do post-parse processing on a journal to make it ready for use: check--- all transactions balance, canonicalise amount formats, close any open--- timelog entries, maybe check balance assertions and so on.-journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Bool -> Journal -> Either String Journal-journalFinalise tclock tlocal path txt ctx assrt j@Journal{files=fs} = do-  (journalBalanceTransactions $-    journalCanonicaliseAmounts $-    journalCloseTimeLogEntries tlocal $-    j{ files=(path,txt):fs-     , filereadtime=tclock-     , jContext=ctx-     , jtxns=reverse $ jtxns j -- NOTE: see addTransaction-     , jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction-     , jperiodictxns=reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction-     , jmarketprices=reverse $ jmarketprices j -- NOTE: see addMarketPrice-     , open_timelog_entries=reverse $ open_timelog_entries j -- NOTE: see addTimeLogEntry-     })+-- | Do post-parse processing on a parsed journal to make it ready for+-- use.  Reverse parsed data to normal order, canonicalise amount+-- formats, check/ensure that transactions are balanced, and maybe+-- check balance assertions.+journalFinalise :: ClockTime -> FilePath -> Text -> Bool -> ParsedJournal -> Either String Journal+journalFinalise t path txt assrt j@Journal{jfiles=fs} = do+  (journalNumberAndTieTransactions <$>+    (journalBalanceTransactions $+    journalApplyCommodityStyles $+    j{ jfiles        = (path,txt) : reverse fs+     , jlastreadtime = t+     , jtxns         = reverse $ jtxns j -- NOTE: see addTransaction+     , jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction+     , jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction+     , jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice+     }))   >>= if assrt then journalCheckBalanceAssertions else return +journalNumberAndTieTransactions = journalTieTransactions . journalNumberTransactions++-- | Number (set the tindex field) this journal's transactions, counting upward from 1.+journalNumberTransactions :: Journal -> Journal+journalNumberTransactions j@Journal{jtxns=ts} = j{jtxns=map (\(i,t) -> t{tindex=i}) $ zip [1..] ts}++-- | Tie the knot in all of this journal's transactions, ensuring their postings+-- refer to them. This should be done last, after any other transaction-modifying operations.+journalTieTransactions :: Journal -> Journal+journalTieTransactions j@Journal{jtxns=ts} = j{jtxns=map txnTieKnot ts}++-- | Untie all transaction-posting knots in this journal, so that eg+-- recursiveSize and GHCI's :sprint can work on it.+journalUntieTransactions :: Transaction -> Transaction+journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}+ -- | Check any balance assertions in the journal and return an error -- message if any of them fail. journalCheckBalanceAssertions :: Journal -> Either String Journal@@ -462,26 +520,47 @@ checkBalanceAssertion :: ([String],MixedAmount) -> [Posting] -> ([String],MixedAmount) checkBalanceAssertion (errs,startbal) ps   | null ps = (errs,startbal)-  | isNothing assertion = (errs,startbal)-  | -- bal' /= assertedbal  -- MixedAmount's Eq instance currently gets confused by different precisions-    not $ isReallyZeroMixedAmount (bal - assertedbal) = (errs++[err], fullbal)-  | otherwise = (errs,fullbal)+  | isNothing $ pbalanceassertion p = (errs,startbal)+  | iswrong = (errs++[err], finalfullbal)+  | otherwise = (errs,finalfullbal)   where     p = last ps-    assertion = pbalanceassertion p-    Just assertedbal = dbg2 "assertedbal" assertion-    assertedcomm = dbg2 "assertedcomm" $ maybe "" acommodity $ headMay $ amounts assertedbal-    fullbal = dbg2 "fullbal" $ sum $ [dbg2 "startbal" startbal] ++ map pamount ps-    singlebal = dbg2 "singlebal" $ filterMixedAmount (\a -> acommodity a == assertedcomm) fullbal-    bal = singlebal -- check single-commodity balance like Ledger; maybe add == FULLBAL later-    err = printf "Balance assertion failed for account %s on %s\n%sAfter posting:\n   %s\nexpected balance in commodity \"%s\" is %s, calculated balance was %s."-                 (paccount p)-                 (show $ postingDate p)-                 (maybe "" (("In transaction:\n"++).show) $ ptransaction p)-                 (show p)+    Just assertedbal = pbalanceassertion p+    assertedcomm = maybe "" acommodity $ headMay $ amounts assertedbal+    finalfullbal = sum $ [startbal] ++ map pamount (dbg2 "ps" ps)+    finalsinglebal = filterMixedAmount (\a -> acommodity a == assertedcomm) finalfullbal+    actualbal = finalsinglebal -- just check the single-commodity balance, like Ledger; maybe add ==FULLBAL later+    iswrong = dbg2 debugmsg $+      not (isReallyZeroMixedAmount (actualbal - assertedbal))+      -- bal' /= assertedbal  -- MixedAmount's Eq instance currently gets confused by different precisions+      where+        debugmsg = "assertions: on " ++ show (postingDate p) ++ " balance of " ++ show assertedcomm+                    ++ " in " ++ T.unpack (paccount p) ++ " should be " ++ show assertedbal+    diff = assertedbal - actualbal+    diffplus | isNegativeMixedAmount diff == Just False = "+"+             | otherwise = ""+    err = printf (unlines [+                      "balance assertion error%s",+                      "after posting:",+                      "%s",+                      "balance assertion details:",+                      "date:       %s",+                      "account:    %s",+                      "commodity:  %s",+                      "calculated: %s",+                      "asserted:   %s (difference: %s)"+                      ])+                 (case ptransaction p of+                    Nothing -> ":" -- shouldn't happen+                    Just t ->  printf " in \"%s\" (line %d, column %d):\nin transaction:\n%s" f l c (chomp $ show t) :: String+                      where GenericSourcePos f l c = tsourcepos t)+                 (showPostingLine p)+                 (showDate $ postingDate p)+                 (T.unpack $ paccount p) -- XXX pack                  assertedcomm+                 (showMixedAmount finalsinglebal)                  (showMixedAmount assertedbal)-                 (showMixedAmount singlebal)+                 (diffplus ++ showMixedAmount diff)  -- Given a sequence of postings to a single account, split it into -- sub-sequences consisting of ordinary postings followed by a single@@ -496,55 +575,77 @@  -- | Fill in any missing amounts and check that all journal transactions -- balance, or return an error message. This is done after parsing all--- amounts and working out the canonical commodities, since balancing+-- amounts and applying canonical commodity styles, since balancing -- depends on display precision. Reports only the first error encountered. journalBalanceTransactions :: Journal -> Either String Journal-journalBalanceTransactions j@Journal{jtxns=ts, jcommoditystyles=ss} =-  case sequence $ map balance ts of Right ts' -> Right j{jtxns=map txnTieKnot ts'}+journalBalanceTransactions j@Journal{jtxns=ts, jinferredcommodities=ss} =+  case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'}                                     Left e    -> Left e       where balance = balanceTransaction (Just ss) --- | Convert all the journal's posting amounts (and historical price--- amounts, but currently not transaction price amounts) to their--- canonical display settings. Ie, all amounts in a given commodity--- will use (a) the display settings of the first, and (b) the--- greatest precision, of the posting amounts in that commodity.-journalCanonicaliseAmounts :: Journal -> Journal-journalCanonicaliseAmounts j@Journal{jtxns=ts, jmarketprices=mps} = j''+-- | Choose and apply a consistent display format to the posting+-- amounts in each commodity. Each commodity's format is specified by+-- a commodity format directive, or otherwise inferred from posting+-- amounts as in hledger < 0.28.+journalApplyCommodityStyles :: Journal -> Journal+journalApplyCommodityStyles j@Journal{jtxns=ts, jmarketprices=mps} = j''     where+      j' = journalInferCommodityStyles j       j'' = j'{jtxns=map fixtransaction ts, jmarketprices=map fixmarketprice mps}-      j' = j{jcommoditystyles = canonicalStyles $ dbg8 "journalAmounts" $ journalAmounts j}       fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}       fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}       fixmarketprice mp@MarketPrice{mpamount=a} = mp{mpamount=fixamount a}       fixmixedamount (Mixed as) = Mixed $ map fixamount as       fixamount a@Amount{acommodity=c} = a{astyle=journalCommodityStyle j' c} --- | Given a list of amounts in parse order, build a map from commodities--- to canonical display styles for amounts in that commodity.-canonicalStyles :: [Amount] -> M.Map Commodity AmountStyle-canonicalStyles amts = M.fromList commstyles+-- | Get this journal's standard display style for the given+-- commodity.  That is the style defined by the last corresponding+-- commodity format directive if any, otherwise the style inferred+-- from the posting amounts (or in some cases, price amounts) in this+-- commodity if any, otherwise the default style.+journalCommodityStyle :: Journal -> CommoditySymbol -> AmountStyle+journalCommodityStyle j c =+  headDef amountstyle{asprecision=2} $+  catMaybes [+     M.lookup c (jcommodities j) >>= cformat+    ,M.lookup c $ jinferredcommodities j+    ]++-- | Infer a display format for each commodity based on the amounts parsed.+-- "hledger... will use the format of the first posting amount in the+-- commodity, and the highest precision of all posting amounts in the commodity."+journalInferCommodityStyles :: Journal -> Journal+journalInferCommodityStyles j =+  j{jinferredcommodities =+        commodityStylesFromAmounts $+        dbg8 "journalChooseCommmodityStyles using amounts" $ journalAmounts j}++-- | Given a list of amounts in parse order, build a map from their commodity names+-- to standard commodity display formats.+commodityStylesFromAmounts :: [Amount] -> M.Map CommoditySymbol AmountStyle+commodityStylesFromAmounts amts = M.fromList commstyles   where     samecomm = \a1 a2 -> acommodity a1 == acommodity a2     commamts = [(acommodity $ head as, as) | as <- groupBy samecomm $ sortBy (comparing acommodity) amts]     commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts] --- Given an ordered list of amount styles for a commodity, build a canonical style.+-- | Given an ordered list of amount styles, choose a canonical style.+-- That is: the style of the first, and the+-- maximum precision of all. canonicalStyleFrom :: [AmountStyle] -> AmountStyle canonicalStyleFrom [] = amountstyle canonicalStyleFrom ss@(first:_) =   first{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}   where-    -- precision is the maximum of all precisions seen+    mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss+    -- precision is maximum of all precisions     prec = maximum $ map asprecision ss-    -- find the first decimal point and the first digit group style seen,-    -- or use defaults.     mdec  = Just $ headDef '.' $ catMaybes $ map asdecimalpoint ss-    mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss---- | Get this journal's canonical amount style for the given commodity, or the null style.-journalCommodityStyle :: Journal -> Commodity -> AmountStyle-journalCommodityStyle j c = M.findWithDefault amountstyle c $ jcommoditystyles j+    -- precision is that of first amount with a decimal point+    -- (mdec, prec) =+    --   case filter (isJust . asdecimalpoint) ss of+    --   (s:_) -> (asdecimalpoint s, asprecision s)+    --   []    -> (Just '.', 0)  -- -- | Apply this journal's historical price records to unpriced amounts where possible. -- journalApplyMarketPrices :: Journal -> Journal@@ -560,41 +661,36 @@  -- -- | Get the price for a commodity on the specified day from the price database, if known. -- -- Does only one lookup step, ie will not look up the price of a price.--- journalMarketPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount--- journalMarketPriceFor j d Commodity{symbol=s} = do+-- journalMarketPriceFor :: Journal -> Day -> CommoditySymbol -> Maybe MixedAmount+-- journalMarketPriceFor j d CommoditySymbol{symbol=s} = do --   let ps = reverse $ filter ((<= d).mpdate) $ filter ((s==).hsymbol) $ sortBy (comparing mpdate) $ jmarketprices j --   case ps of (MarketPrice{mpamount=a}:_) -> Just a --              _ -> Nothing --- | Close any open timelog sessions in this journal using the provided current time.-journalCloseTimeLogEntries :: LocalTime -> Journal -> Journal-journalCloseTimeLogEntries now j@Journal{jtxns=ts, open_timelog_entries=es} =-  j{jtxns = ts ++ (timeLogEntriesToTransactions now es), open_timelog_entries = []}- -- | Convert all this journal's amounts to cost by applying their prices, if any. journalConvertAmountsToCost :: Journal -> Journal journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}     where-      -- similar to journalCanonicaliseAmounts+      -- similar to journalApplyCommodityStyles       fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}       fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}       fixmixedamount (Mixed as) = Mixed $ map fixamount as-      fixamount = canonicaliseAmount (jcommoditystyles j) . costOfAmount+      fixamount = canonicaliseAmount (jinferredcommodities j) . costOfAmount  -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol.--- journalCanonicalCommodities :: Journal -> M.Map String Commodity+-- journalCanonicalCommodities :: Journal -> M.Map String CommoditySymbol -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j  -- -- | Get all this journal's amounts' commodities, in the order parsed.--- journalAmountCommodities :: Journal -> [Commodity]+-- journalAmountCommodities :: Journal -> [CommoditySymbol] -- journalAmountCommodities = map acommodity . concatMap amounts . journalAmounts  -- -- | Get all this journal's amount and price commodities, in the order parsed.--- journalAmountAndPriceCommodities :: Journal -> [Commodity]+-- journalAmountAndPriceCommodities :: Journal -> [CommoditySymbol] -- journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts  -- -- | Get this amount's commodity and any commodities referenced in its price.--- amountCommodities :: Amount -> [Commodity]+-- amountCommodities :: Amount -> [CommoditySymbol] -- amountCommodities Amount{acommodity=c,aprice=p} = --     case p of Nothing -> [c] --               Just (UnitPrice ma)  -> c:(concatMap amountCommodities $ amounts ma)

@@ -10,6 +10,8 @@ module Hledger.Data.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@@ -37,7 +39,7 @@  -- | Filter a journal's transactions with the given query, then derive -- a ledger containing the chart of accounts and balances. If the--- query includes a depth limit, that will affect the this ledger's+-- query includes a depth limit, that will affect the ledger's -- journal but not the ledger's account tree. ledgerFromJournal :: Query -> Journal -> Ledger ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as}@@ -72,7 +74,7 @@  -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account]-ledgerAccountsMatching pats = filter (matchpats pats . aname) . laccounts+ledgerAccountsMatching pats = filter (matchpats pats . T.unpack . aname) . laccounts -- XXX pack  -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting]@@ -84,8 +86,8 @@ ledgerDateSpan = postingsDateSpan . ledgerPostings  -- | All commodities used in this ledger.-ledgerCommodities :: Ledger -> [Commodity]-ledgerCommodities = M.keys . jcommoditystyles . ljournal+ledgerCommodities :: Ledger -> [CommoditySymbol]+ledgerCommodities = M.keys . jinferredcommodities . ljournal   tests_ledgerFromJournal = [

@@ -0,0 +1,262 @@+{-|++Manipulate the time periods typically used for reports with Period,+a richer abstraction than DateSpan. See also Types and Dates.++-}++module Hledger.Data.Period+where++import Data.Time.Calendar+import Data.Time.Calendar.MonthDay+import Data.Time.Calendar.OrdinalDate+import Data.Time.Calendar.WeekDate+import Data.Time.Format+import Text.Printf++import Hledger.Data.Types++-- | Convert Periods to DateSpans.+--+-- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- True+periodAsDateSpan :: Period -> DateSpan+periodAsDateSpan (DayPeriod d) = DateSpan (Just d) (Just $ addDays 1 d)+periodAsDateSpan (WeekPeriod b) = DateSpan (Just b) (Just $ addDays 7 b)+periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+  where+    (y',m') | m==12     = (y+1,1)+            | otherwise = (y,m+1)+periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)+  where+    (y', q') | q==4      = (y+1,1)+             | otherwise = (y,q+1)+    quarterAsMonth q = (q-1) * 3 + 1+    m  = quarterAsMonth q+    m' = quarterAsMonth q'+periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1)+periodAsDateSpan (PeriodBetween b e) = DateSpan (Just b) (Just e)+periodAsDateSpan (PeriodFrom b) = DateSpan (Just b) Nothing+periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just e)+periodAsDateSpan (PeriodAll) = DateSpan Nothing Nothing++-- | Convert DateSpans to Periods.+--+-- >>> dateSpanAsPeriod $ DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)+-- MonthPeriod 2000 1+dateSpanAsPeriod :: DateSpan -> Period+dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween b e+dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom b+dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo e+dateSpanAsPeriod (DateSpan Nothing Nothing) = PeriodAll++-- | Convert PeriodBetweens to a more abstract period where possible.+--+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 1 1 1) (fromGregorian 2 1 1)+-- YearPeriod 1+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 10 1) (fromGregorian 2001 1 1)+-- QuarterPeriod 2000 4+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 1) (fromGregorian 2000 3 1)+-- MonthPeriod 2000 2+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2016 7 25) (fromGregorian 2016 8 1)+-- WeekPeriod 2016-07-25+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 1 1) (fromGregorian 2000 1 2)+-- DayPeriod 2000-01-01+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 28) (fromGregorian 2000 3 1)+-- PeriodBetween 2000-02-28 2000-03-01+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 29) (fromGregorian 2000 3 1)+-- DayPeriod 2000-02-29+-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 12 31) (fromGregorian 2001 1 1)+-- DayPeriod 2000-12-31+--+simplifyPeriod :: Period -> Period+simplifyPeriod (PeriodBetween b e) =+  case (toGregorian b, toGregorian e) of+    -- a year+    ((by,1,1), (ey,1,1))   | by+1==ey           -> YearPeriod by+    -- a half-year+    -- ((by,1,1), (ey,7,1))   | by==ey             ->+    -- ((by,7,1), (ey,1,1))   | by+1==ey           ->+    -- a quarter+    ((by,1,1), (ey,4,1))   | by==ey             -> QuarterPeriod by 1+    ((by,4,1), (ey,7,1))   | by==ey             -> QuarterPeriod by 2+    ((by,7,1), (ey,10,1))  | by==ey             -> QuarterPeriod by 3+    ((by,10,1), (ey,1,1))  | by+1==ey           -> QuarterPeriod by 4+    -- a month+    ((by,bm,1), (ey,em,1)) | by==ey && bm+1==em -> MonthPeriod by bm+    ((by,12,1), (ey,1,1))  | by+1==ey           -> MonthPeriod by 12+    -- a week (two successive mondays),+    -- YYYYwN ("week N of year YYYY")+    -- _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate from, toWeekDate to) in by==ey && fw+1==tw && bd==1 && ed==1 ->+    -- a week starting on a monday+    _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate b, toWeekDate (addDays (-1) e))+        in by==ey && bw==ew && bd==1 && ed==7   -> WeekPeriod b+    -- a day+    ((by,bm,bd), (ey,em,ed)) |+        (by==ey && bm==em && bd+1==ed) ||+        (by+1==ey && bm==12 && em==1 && bd==31 && ed==1) || -- crossing a year boundary+        (by==ey && bm+1==em && isLastDayOfMonth by bm bd && ed==1) -- crossing a month boundary+         -> DayPeriod b+    _ -> PeriodBetween b e+simplifyPeriod p = p++isLastDayOfMonth y m d =+  case m of+    1 -> d==31+    2 | isLeapYear y -> d==29+      | otherwise    -> d==28+    3 -> d==31+    4 -> d==30+    5 -> d==31+    6 -> d==30+    7 -> d==31+    8 -> d==31+    9 -> d==30+    10 -> d==31+    11 -> d==30+    12 -> d==31+    _ -> False++-- | Render a period as a compact display string suitable for user output.+--+-- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))+-- "2016/07/25w30"+showPeriod (DayPeriod b)       = formatTime defaultTimeLocale "%0C%y/%m/%d" b     -- DATE+showPeriod (WeekPeriod b)      = formatTime defaultTimeLocale "%0C%y/%m/%dw%V" b  -- STARTDATEwYEARWEEK+showPeriod (MonthPeriod y m)   = printf "%04d/%02d" y m                           -- YYYY/MM+showPeriod (QuarterPeriod y q) = printf "%04dq%d" y q                             -- YYYYqN+showPeriod (YearPeriod y)      = printf "%04d" y                                  -- YYYY+showPeriod (PeriodBetween b e) = formatTime defaultTimeLocale "%0C%y/%m/%d" b+                                 ++ formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e) -- STARTDATE-INCLUSIVEENDDATE+showPeriod (PeriodFrom b)      = formatTime defaultTimeLocale "%0C%y/%m/%d-" b                   -- STARTDATE-+showPeriod (PeriodTo e)        = formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e)    -- -INCLUSIVEENDDATE+showPeriod PeriodAll           = "-"++periodStart :: Period -> Maybe Day+periodStart p = mb+  where+    DateSpan mb _ = periodAsDateSpan p++periodEnd :: Period -> Maybe Day+periodEnd p = me+  where+    DateSpan _ me = periodAsDateSpan p++-- | Move a period to the following period of same duration.+periodNext :: Period -> Period+periodNext (DayPeriod b) = DayPeriod (addDays 1 b)+periodNext (WeekPeriod b) = WeekPeriod (addDays 7 b)+periodNext (MonthPeriod y 12) = MonthPeriod (y+1) 1+periodNext (MonthPeriod y m) = MonthPeriod y (m+1)+periodNext (QuarterPeriod y 4) = QuarterPeriod (y+1) 1+periodNext (QuarterPeriod y q) = QuarterPeriod y (q+1)+periodNext (YearPeriod y) = YearPeriod (y+1)+periodNext p = p++-- | Move a period to the preceding period of same duration.+periodPrevious :: Period -> Period+periodPrevious (DayPeriod b) = DayPeriod (addDays (-1) b)+periodPrevious (WeekPeriod b) = WeekPeriod (addDays (-7) b)+periodPrevious (MonthPeriod y 1) = MonthPeriod (y-1) 12+periodPrevious (MonthPeriod y m) = MonthPeriod y (m-1)+periodPrevious (QuarterPeriod y 1) = QuarterPeriod (y-1) 4+periodPrevious (QuarterPeriod y q) = QuarterPeriod y (q-1)+periodPrevious (YearPeriod y) = YearPeriod (y-1)+periodPrevious p = p++-- | Move a period to the following period of same duration, staying within enclosing dates.+periodNextIn :: DateSpan -> Period -> Period+periodNextIn (DateSpan _ (Just e)) p =+  case mb of+    Just b -> if b < e then p' else p+    _      -> p+  where+    p' = periodNext p+    mb = periodStart p'+periodNextIn _ p = periodNext p++-- | Move a period to the preceding period of same duration, staying within enclosing dates.+periodPreviousIn :: DateSpan -> Period -> Period+periodPreviousIn (DateSpan (Just b) _) p =+  case me of+    Just e -> if e > b then p' else p+    _      -> p+  where+    p' = periodPrevious p+    me = periodEnd p'+periodPreviousIn _ p = periodPrevious p++-- | Enlarge a standard period to the next larger enclosing standard period, if there is one.+-- Eg, a day becomes the enclosing week.+-- A week becomes whichever month the week's thursday falls into.+-- A year becomes all (unlimited).+-- Growing an unlimited period, or a non-standard period (arbitrary dates) has no effect.+periodGrow :: Period -> Period+periodGrow (DayPeriod b) = WeekPeriod $ mondayBefore b+periodGrow (WeekPeriod b) = MonthPeriod y m+  where (y,m) = yearMonthContainingWeekStarting b+periodGrow (MonthPeriod y m) = QuarterPeriod y (quarterContainingMonth m)+periodGrow (QuarterPeriod y _) = YearPeriod y+periodGrow (YearPeriod _) = PeriodAll+periodGrow p = p++-- | Shrink a period to the next smaller standard period inside it,+-- choosing the subperiod which contains today's date if possible,+-- otherwise the first subperiod. It goes like this:+-- unbounded periods and nonstandard periods (between two arbitrary dates) ->+-- current year ->+-- current quarter if it's in selected year, otherwise first quarter of selected year ->+-- current month if it's in selected quarter, otherwise first month of selected quarter ->+-- current week if it's in selected month, otherwise first week of selected month ->+-- today if it's in selected week, otherwise first day of selected week,+--  unless that's in previous month, in which case first day of month containing selected week.+-- Shrinking a day has no effect.+periodShrink :: Day -> Period -> Period+periodShrink _     p@(DayPeriod _) = p+periodShrink today (WeekPeriod b)+  | today >= b && diffDays today b < 7 = DayPeriod today+  | m /= weekmonth                     = DayPeriod $ fromGregorian weekyear weekmonth 1+  | otherwise                          = DayPeriod b+  where+    (_,m,_) = toGregorian b+    (weekyear,weekmonth) = yearMonthContainingWeekStarting b+periodShrink today (MonthPeriod y m)+  | (y',m') == (y,m) = WeekPeriod $ mondayBefore today+  | otherwise        = WeekPeriod $ startOfFirstWeekInMonth y m+  where (y',m',_) = toGregorian today+periodShrink today (QuarterPeriod y q)+  | quarterContainingMonth thismonth == q = MonthPeriod y thismonth+  | otherwise                             = MonthPeriod y (firstMonthOfQuarter q)+  where (_,thismonth,_) = toGregorian today+periodShrink today (YearPeriod y)+  | y == thisyear = QuarterPeriod y thisquarter+  | otherwise     = QuarterPeriod y 1+  where+    (thisyear,thismonth,_) = toGregorian today+    thisquarter = quarterContainingMonth thismonth+periodShrink today _ = YearPeriod y+  where (y,_,_) = toGregorian today++mondayBefore d = addDays (fromIntegral (1 - wd)) d+  where+    (_,_,wd) = toWeekDate d++yearMonthContainingWeekStarting weekstart = (y,m)+  where+    thu = addDays 3 weekstart+    (y,yd) = toOrdinalDate thu+    (m,_) = dayOfYearToMonthAndDay (isLeapYear y) yd++quarterContainingMonth m = (m-1) `div` 3 + 1++firstMonthOfQuarter q = (q-1)*3 + 1++startOfFirstWeekInMonth y m+  | monthstartday <= 4 = mon+  | otherwise          = addDays 7 mon  -- month starts with a fri/sat/sun+  where+    monthstart = fromGregorian y m 1+    mon = mondayBefore monthstart+    (_,_,monthstartday) = toWeekDate monthstart+

@@ -7,6 +7,8 @@  -} +{-# LANGUAGE OverloadedStrings #-}+ module Hledger.Data.Posting (   -- * Posting   nullposting,@@ -50,7 +52,10 @@ import Data.List import Data.Maybe import Data.MemoUgly (memo)+import Data.Monoid import Data.Ord+import Data.Text (Text)+import qualified Data.Text as T import Data.Time.Calendar import Safe import Test.HUnit@@ -89,7 +94,7 @@     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22-      showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . elideAccountName width+      showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . T.unpack . elideAccountName width       (bracket,width) = case t of                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)@@ -97,8 +102,8 @@       showamount = padLeftWide 12 . showMixedAmount  -showComment :: String -> String-showComment s = if null s then "" else "  ;" ++ s+showComment :: Text -> String+showComment t = if T.null t then "" else "  ;" ++ T.unpack t  isReal :: Posting -> Bool isReal p = ptype p == RegularPosting@@ -192,32 +197,32 @@  accountNamePostingType :: AccountName -> PostingType accountNamePostingType a-    | null a = RegularPosting-    | head a == '[' && last a == ']' = BalancedVirtualPosting-    | head a == '(' && last a == ')' = VirtualPosting+    | T.null a = RegularPosting+    | T.head a == '[' && T.last a == ']' = BalancedVirtualPosting+    | T.head a == '(' && T.last a == ')' = VirtualPosting     | otherwise = RegularPosting  accountNameWithoutPostingType :: AccountName -> AccountName accountNameWithoutPostingType a = case accountNamePostingType a of-                                    BalancedVirtualPosting -> init $ tail a-                                    VirtualPosting -> init $ tail a+                                    BalancedVirtualPosting -> T.init $ T.tail a+                                    VirtualPosting -> T.init $ T.tail a                                     RegularPosting -> a  accountNameWithPostingType :: PostingType -> AccountName -> AccountName-accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]"-accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")"+accountNameWithPostingType BalancedVirtualPosting a = "["<>accountNameWithoutPostingType a<>"]"+accountNameWithPostingType VirtualPosting a = "("<>accountNameWithoutPostingType a<>")" accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a  -- | Prefix one account name to another, preserving posting type -- indicators like concatAccountNames. joinAccountNames :: AccountName -> AccountName -> AccountName-joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b]+joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b]  -- | Join account names into one. If any of them has () or [] posting type -- indicators, these (the first type encountered) will also be applied to -- the resulting account name. concatAccountNames :: [AccountName] -> AccountName-concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as+concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as     where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as  -- | Rewrite an account name using all matching aliases from the given list, in sequence.@@ -241,9 +246,9 @@  aliasReplace :: AccountAlias -> AccountName -> AccountName aliasReplace (BasicAlias old new) a-  | old `isAccountNamePrefixOf` a || old == a = new ++ drop (length old) a+  | old `isAccountNamePrefixOf` a || old == a = new <> T.drop (T.length old) a   | otherwise = a-aliasReplace (RegexAlias re repl) a = regexReplaceCIMemo re repl a+aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX   tests_Hledger_Data_Posting = TestList [

@@ -23,6 +23,7 @@ where  import Data.Maybe+import qualified Data.Text as T import Safe  import Hledger.Utils@@ -32,7 +33,7 @@ type RawOpts = [(String,String)]  setopt :: String -> String -> RawOpts -> RawOpts-setopt name val = (++ [(name, quoteIfNeeded val)])+setopt name val = (++ [(name, quoteIfNeeded $ val)])  setboolopt :: String -> RawOpts -> RawOpts setboolopt name = (++ [(name,"")])@@ -45,7 +46,7 @@ boolopt = inRawOpts  maybestringopt :: String -> RawOpts -> Maybe String-maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name . reverse+maybestringopt name = maybe Nothing (Just . T.unpack . stripquotes . T.pack) . lookup name . reverse  stringopt :: String -> RawOpts -> String stringopt name = fromMaybe "" . maybestringopt name

@@ -2,7 +2,7 @@ -- hledger's report item fields. The formats are used by -- report-specific renderers like renderBalanceReportItem. -{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}  module Hledger.Data.StringFormat (           parseStringFormat@@ -19,7 +19,8 @@ import Data.Char (isPrint) import Data.Maybe import Test.HUnit-import Text.Parsec+import Text.Megaparsec+import Text.Megaparsec.String  import Hledger.Utils.String (formatString) @@ -79,15 +80,15 @@  -- | Parse a string format specification, or return a parse error. parseStringFormat :: String -> Either String StringFormat-parseStringFormat input = case (runParser (stringformatp <* eof) () "(unknown)") input of+parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of     Left y -> Left $ show y     Right x -> Right x  defaultStringFormatStyle = BottomAligned -stringformatp :: Stream [Char] m Char => ParsecT [Char] st m StringFormat+stringformatp :: Parser StringFormat stringformatp = do-  alignspec <- optionMaybe (try $ char '%' >> oneOf "^_,")+  alignspec <- optional (try $ char '%' >> oneOf "^_,")   let constructor =         case alignspec of           Just '^' -> TopAligned@@ -96,24 +97,24 @@           _        -> defaultStringFormatStyle   constructor <$> many componentp -componentp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent+componentp :: Parser StringFormatComponent componentp = formatliteralp <|> formatfieldp -formatliteralp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent+formatliteralp :: Parser StringFormatComponent formatliteralp = do-    s <- many1 c+    s <- some c     return $ FormatLiteral s     where       isPrintableButNotPercentage x = isPrint x && (not $ x == '%')       c =     (satisfy isPrintableButNotPercentage <?> "printable character")           <|> try (string "%%" >> return '%') -formatfieldp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent+formatfieldp :: Parser StringFormatComponent formatfieldp = do     char '%'-    leftJustified <- optionMaybe (char '-')-    minWidth <- optionMaybe (many1 $ digit)-    maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)+    leftJustified <- optional (char '-')+    minWidth <- optional (some $ digitChar)+    maxWidth <- optional (do char '.'; some $ digitChar) -- TODO: Can this be (char '1') *> (some digitChar)     char '('     f <- fieldp     char ')'@@ -123,14 +124,14 @@         Just text -> Just m where ((m,_):_) = readDec text         _ -> Nothing -fieldp :: Stream [Char] m Char => ParsecT [Char] st m ReportItemField+fieldp :: Parser ReportItemField fieldp = do         try (string "account" >> return AccountField)     <|> try (string "depth_spacer" >> return DepthSpacerField)     <|> try (string "date" >> return DescriptionField)     <|> try (string "description" >> return DescriptionField)     <|> try (string "total" >> return TotalField)-    <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s))+    <|> try (some digitChar >>= (\s -> return $ FieldNo $ read s))  ---------------------------------------------------------------------- 

@@ -1,142 +0,0 @@-{-# LANGUAGE CPP #-}-{-|--A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog-file (see timeclock.el or the command-line version). These can be-converted to 'Transactions' and queried like a ledger.---}--module Hledger.Data.TimeLog-where-import Data.Maybe-import Data.Time.Calendar-import Data.Time.Clock-import Data.Time.Format-import Data.Time.LocalTime-#if !(MIN_VERSION_time(1,5,0))-import System.Locale (defaultTimeLocale)-#endif-import Test.HUnit-import Text.Printf--import Hledger.Utils-import Hledger.Data.Types-import Hledger.Data.Dates-import Hledger.Data.Amount-import Hledger.Data.Posting-import Hledger.Data.Transaction--instance Show TimeLogEntry where-    show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)--instance Show TimeLogCode where-    show SetBalance = "b"-    show SetRequiredHours = "h"-    show In = "i"-    show Out = "o"-    show FinalOut = "O"--instance Read TimeLogCode where-    readsPrec _ ('b' : xs) = [(SetBalance, xs)]-    readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]-    readsPrec _ ('i' : xs) = [(In, xs)]-    readsPrec _ ('o' : xs) = [(Out, xs)]-    readsPrec _ ('O' : xs) = [(FinalOut, xs)]-    readsPrec _ _ = []---- | Convert time log entries to journal transactions. When there is no--- clockout, add one with the provided current time. Sessions crossing--- midnight are split into days to give accurate per-day totals.-timeLogEntriesToTransactions :: LocalTime -> [TimeLogEntry] -> [Transaction]-timeLogEntriesToTransactions _ [] = []-timeLogEntriesToTransactions now [i]-    | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now [i',o]-    | otherwise = [entryFromTimeLogInOut i o]-    where-      o = TimeLogEntry (tlsourcepos i) Out end "" ""-      end = if itime > now then itime else now-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-timeLogEntriesToTransactions now (i:o:rest)-    | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now (i':o:rest)-    | otherwise = entryFromTimeLogInOut i o : timeLogEntriesToTransactions now rest-    where-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}---- | Convert a timelog clockin and clockout entry to an equivalent journal--- transaction, representing the time expenditure. Note this entry is  not balanced,--- since we omit the \"assets:time\" transaction for simpler output.-entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction-entryFromTimeLogInOut i o-    | otime >= itime = t-    | otherwise =-        error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t-    where-      t = Transaction {-            tindex       = 0,-            tsourcepos   = tlsourcepos i,-            tdate        = idate,-            tdate2       = Nothing,-            tstatus      = Cleared,-            tcode        = "",-            tdescription = desc,-            tcomment     = "",-            ttags        = [],-            tpostings    = ps,-            tpreceding_comment_lines=""-          }-      itime    = tldatetime i-      otime    = tldatetime o-      itod     = localTimeOfDay itime-      otod     = localTimeOfDay otime-      idate    = localDay itime-      desc     | null (tldescription i) = showtime itod ++ "-" ++ showtime otod-               | otherwise              = tldescription i-      showtime = take 5 . show-      hours    = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc-      acctname = tlaccount i-      amount   = Mixed [hrs hours]-      ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]---tests_Hledger_Data_TimeLog = TestList [--   "timeLogEntriesToTransactions" ~: do-     today <- getCurrentDay-     now' <- getCurrentTime-     tz <- getCurrentTimeZone-     let now = utcToLocalTime tz now'-         nowstr = showtime now-         yesterday = prevday today-         clockin = TimeLogEntry nullsourcepos In-         mktime d = LocalTime d . fromMaybe midnight .-#if MIN_VERSION_time(1,5,0)-                    parseTimeM True defaultTimeLocale "%H:%M:%S"-#else-                    parseTime defaultTimeLocale "%H:%M:%S"-#endif-         showtime = formatTime defaultTimeLocale "%H:%M"-         assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions 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]-- ]

@@ -0,0 +1,145 @@+{-|++A 'TimeclockEntry' is a clock-in, clock-out, or other directive in a timeclock+file (see timeclock.el or the command-line version). These can be+converted to 'Transactions' and queried like a ledger.++-}++{-# LANGUAGE CPP, OverloadedStrings #-}++module Hledger.Data.Timeclock+where+import Data.Maybe+-- import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime+#if !(MIN_VERSION_time(1,5,0))+import System.Locale (defaultTimeLocale)+#endif+import Test.HUnit+import Text.Printf++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.Dates+import Hledger.Data.Amount+import Hledger.Data.Posting+import Hledger.Data.Transaction++instance Show TimeclockEntry where+    show t = printf "%s %s %s  %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription t)++instance Show TimeclockCode where+    show SetBalance = "b"+    show SetRequiredHours = "h"+    show In = "i"+    show Out = "o"+    show FinalOut = "O"++instance Read TimeclockCode where+    readsPrec _ ('b' : xs) = [(SetBalance, xs)]+    readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]+    readsPrec _ ('i' : xs) = [(In, xs)]+    readsPrec _ ('o' : xs) = [(Out, xs)]+    readsPrec _ ('O' : xs) = [(FinalOut, xs)]+    readsPrec _ _ = []++-- | Convert time log entries to journal transactions. When there is no+-- clockout, add one with the provided current time. Sessions crossing+-- midnight are split into days to give accurate per-day totals.+timeclockEntriesToTransactions :: LocalTime -> [TimeclockEntry] -> [Transaction]+timeclockEntriesToTransactions _ [] = []+timeclockEntriesToTransactions now [i]+    | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now [i',o]+    | otherwise = [entryFromTimeclockInOut i o]+    where+      o = TimeclockEntry (tlsourcepos i) Out end "" ""+      end = if itime > now then itime else now+      (itime,otime) = (tldatetime i,tldatetime o)+      (idate,odate) = (localDay itime,localDay otime)+      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}+timeclockEntriesToTransactions now (i:o:rest)+    | odate > idate = entryFromTimeclockInOut i o' : timeclockEntriesToTransactions now (i':o:rest)+    | otherwise = entryFromTimeclockInOut i o : timeclockEntriesToTransactions now rest+    where+      (itime,otime) = (tldatetime i,tldatetime o)+      (idate,odate) = (localDay itime,localDay otime)+      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}+      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}++-- | Convert a timeclock clockin and clockout entry to an equivalent journal+-- transaction, representing the time expenditure. Note this entry is  not balanced,+-- since we omit the \"assets:time\" transaction for simpler output.+entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction+entryFromTimeclockInOut i o+    | otime >= itime = t+    | otherwise =+        error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t+    where+      t = Transaction {+            tindex       = 0,+            tsourcepos   = tlsourcepos i,+            tdate        = idate,+            tdate2       = Nothing,+            tstatus      = Cleared,+            tcode        = "",+            tdescription = desc,+            tcomment     = "",+            ttags        = [],+            tpostings    = ps,+            tpreceding_comment_lines=""+          }+      itime    = tldatetime i+      otime    = tldatetime o+      itod     = localTimeOfDay itime+      otod     = localTimeOfDay otime+      idate    = localDay itime+      desc     | T.null (tldescription i) = T.pack $ showtime itod ++ "-" ++ showtime otod+               | otherwise                = tldescription i+      showtime = take 5 . show+      hours    = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc+      acctname = tlaccount i+      amount   = Mixed [hrs hours]+      ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}]+++tests_Hledger_Data_Timeclock = TestList [++   "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 .+#if MIN_VERSION_time(1,5,0)+                    parseTimeM True defaultTimeLocale "%H:%M:%S"+#else+                    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]++ ]

@@ -7,12 +7,14 @@  -} +{-# LANGUAGE OverloadedStrings #-}+ module Hledger.Data.Transaction (   -- * Transaction   nullsourcepos,   nulltransaction,   txnTieKnot,-  -- settxn,+  txnUntieKnot,   -- * operations   showAccountName,   hasRealPostings,@@ -31,12 +33,15 @@   showTransaction,   showTransactionUnelided,   showTransactionUnelidedOneLineAmounts,+  showPostingLine,   -- * misc.   tests_Hledger_Data_Transaction ) where import Data.List import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T import Data.Time.Calendar import Test.HUnit import Text.Printf@@ -51,10 +56,10 @@ instance Show Transaction where show = showTransactionUnelided  instance Show ModifierTransaction where-    show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))+    show t = "= " ++ T.unpack (mtvalueexpr t) ++ "\n" ++ unlines (map show (mtpostings t))  instance Show PeriodicTransaction where-    show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))+    show t = "~ " ++ T.unpack (ptperiodicexpr t) ++ "\n" ++ unlines (map show (ptpostings t))  nullsourcepos :: GenericSourcePos nullsourcepos = GenericSourcePos "" 1 1@@ -145,16 +150,16 @@       status | tstatus t == Cleared = " *"              | tstatus t == Pending = " !"              | otherwise            = ""-      code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""-      desc = if null d then "" else " " ++ d where d = tdescription t+      code = if T.length (tcode t) > 0 then printf " (%s)" $ T.unpack $ tcode t else ""+      desc = if null d then "" else " " ++ d where d = T.unpack $ tdescription t       (samelinecomment, newlinecomments) =         case renderCommentLines (tcomment t) of []   -> ("",[])                                                 c:cs -> (c,cs)  -- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines.-renderCommentLines :: String -> [String]-renderCommentLines s  = case lines s of ("":ls) -> "":map commentprefix ls-                                        ls      -> map commentprefix ls+renderCommentLines :: Text -> [String]+renderCommentLines t  = case lines $ T.unpack t of ("":ls) -> "":map commentprefix ls+                                                   ls      -> map commentprefix ls     where       commentprefix = indent . ("; "++) @@ -187,7 +192,7 @@         showstatus p ++ fitString (Just acctwidth) Nothing False True (showAccountName Nothing (ptype p) (paccount p))         where           showstatus p = if pstatus p == Cleared then "* " else ""-          acctwidth = maximum $ map (strWidth . paccount) ps+          acctwidth = maximum $ map (textWidth . paccount) ps      -- currently prices are considered part of the amount string when right-aligning amounts     amount@@ -201,6 +206,15 @@       case renderCommentLines (pcomment p) of []   -> ("",[])                                               c:cs -> (c,cs) ++-- used in balance assertion error+showPostingLine p =+  indent $+  if pstatus p == Cleared then "* " else "" +++  showAccountName Nothing (ptype p) (paccount p) +++  "    " +++  showMixedAmountOneLine (pamount p)+ tests_postingAsLines = [    "postingAsLines" ~: do     let p `gives` ls = assertEqual "" ls (postingAsLines False False [p] p)@@ -229,13 +243,17 @@ showAccountName :: Maybe Int -> PostingType -> AccountName -> String showAccountName w = fmt     where-      fmt RegularPosting = take w'-      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse-      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse+      fmt RegularPosting = take w' . T.unpack+      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse . T.unpack+      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse . T.unpack       w' = fromMaybe 999999 w-      parenthesise s = "("++s++")"-      bracket s = "["++s++"]" +parenthesise :: String -> String+parenthesise s = "("++s++")"++bracket :: String -> String+bracket s = "["++s++"]"+ hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings @@ -260,7 +278,7 @@ -- | Is this transaction balanced ? A balanced transaction's real -- (non-virtual) postings sum to 0, and any balanced virtual postings -- also sum to 0.-isTransactionBalanced :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Bool+isTransactionBalanced :: Maybe (Map.Map CommoditySymbol AmountStyle) -> Transaction -> Bool isTransactionBalanced styles t =     -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum     isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'@@ -274,7 +292,7 @@ -- amount or conversion price(s), or return an error message. -- Balancing is affected by commodity display precisions, so those can -- (optionally) be provided.-balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction+balanceTransaction :: Maybe (Map.Map CommoditySymbol AmountStyle) -> Transaction -> Either String Transaction balanceTransaction styles t =   case inferBalancingAmount t of     Left err -> Left err@@ -402,11 +420,16 @@ -- | Ensure a transaction's postings refer back to it, so that eg -- relatedPostings works right. txnTieKnot :: Transaction -> Transaction-txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}+txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (postingSetTransaction t) ps} +-- | Ensure a transaction's postings do not refer back to it, so that eg+-- recursiveSize and GHCI's :sprint work right.+txnUntieKnot :: Transaction -> Transaction+txnUntieKnot t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}+ -- | Set a posting's parent transaction.-settxn :: Transaction -> Posting -> Posting-settxn t p = p{ptransaction=Just t}+postingSetTransaction :: Transaction -> Posting -> Posting+postingSetTransaction t p = p{ptransaction=Just t}  tests_Hledger_Data_Transaction = TestList $ concat [   tests_postingAsLines,

@@ -24,11 +24,12 @@ import Control.DeepSeq (NFData) import Control.Monad.Except (ExceptT) import Data.Data-#ifndef DOUBLE import Data.Decimal+import Data.Default import Text.Blaze (ToMarkup(..))-#endif 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(..))@@ -44,15 +45,61 @@  instance NFData DateSpan -data Interval = NoInterval-              | Days Int | Weeks Int | Months Int | Quarters Int | Years Int-              | DayOfMonth Int | DayOfWeek Int-              -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int-                deriving (Eq,Show,Ord,Data,Generic,Typeable)+-- synonyms for various date-related scalars+type Year = Integer+type Month = Int     -- 1-12+type Quarter = Int   -- 1-4+type YearWeek = Int  -- 1-52+type MonthWeek = Int -- 1-5+type YearDay = Int   -- 1-366+type MonthDay = Int  -- 1-31+type WeekDay = Int   -- 1-7 +-- Typical report periods (spans of time), both finite and open-ended.+-- A richer abstraction than DateSpan.+data Period =+    DayPeriod Day+  | WeekPeriod Day+  | MonthPeriod Year Month+  | QuarterPeriod Year Quarter+  | YearPeriod Year+  | PeriodBetween Day Day+  | PeriodFrom Day+  | PeriodTo Day+  | PeriodAll+  deriving (Eq,Ord,Show,Data,Generic,Typeable)++instance Default Period where def = PeriodAll++---- Typical report period/subperiod durations, from a day to a year.+--data Duration =+--    DayLong+--   WeekLong+--   MonthLong+--   QuarterLong+--   YearLong+--  deriving (Eq,Ord,Show,Data,Generic,Typeable)++-- Ways in which a period can be divided into subperiods.+data Interval =+    NoInterval+  | Days Int+  | Weeks Int+  | Months Int+  | Quarters Int+  | Years Int+  | DayOfMonth Int+  | DayOfWeek Int+  -- WeekOfYear Int+  -- MonthOfYear Int+  -- QuarterOfYear Int+  deriving (Eq,Show,Ord,Data,Generic,Typeable)++instance Default Interval where def = NoInterval+ instance NFData Interval -type AccountName = String+type AccountName = Text  data AccountAlias = BasicAlias AccountName AccountName                   | RegexAlias Regexp Replacement@@ -64,15 +111,7 @@  instance NFData Side -type Commodity = String---- | The basic numeric type used in amounts. Different implementations--- can be selected via cabal flag for testing and benchmarking purposes.-numberRepresentation :: String-#ifdef DOUBLE-type Quantity = Double-numberRepresentation = "Double"-#else+-- | The basic numeric type used in amounts. type Quantity = Decimal deriving instance Data (Quantity) -- The following is for hledger-web, and requires blaze-markup.@@ -80,8 +119,6 @@ instance ToMarkup (Quantity)  where    toMarkup = toMarkup . show-numberRepresentation = "Decimal"-#endif  -- | 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.@@ -91,11 +128,11 @@  -- | Display style for an amount. data AmountStyle = AmountStyle {-      ascommodityside :: Side,       -- ^ does the symbol appear on the left or the right ?-      ascommodityspaced :: Bool,     -- ^ space between symbol and quantity ?-      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+      ascommodityside   :: Side,                 -- ^ does the symbol appear on the left or the right ?+      ascommodityspaced :: Bool,                 -- ^ space between symbol and quantity ?+      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)  instance NFData AmountStyle@@ -111,11 +148,20 @@  instance NFData DigitGroupStyle +type CommoditySymbol = Text++data Commodity = Commodity {+  csymbol :: CommoditySymbol,+  cformat :: Maybe AmountStyle+  } deriving (Show,Eq,Data,Generic) --,Ord,Typeable,Data,Generic)++instance NFData Commodity+ data Amount = Amount {-      acommodity :: Commodity,-      aquantity :: Quantity,-      aprice :: Price,                -- ^ the (fixed) price for this amount, if any-      astyle :: AmountStyle+      acommodity :: CommoditySymbol,+      aquantity  :: Quantity,+      aprice     :: Price,           -- ^ the (fixed) price for this amount, if any+      astyle     :: AmountStyle     } deriving (Eq,Ord,Typeable,Data,Generic)  instance NFData Amount@@ -129,30 +175,32 @@  instance NFData PostingType -type Tag = (String, String)  -- ^ A tag name and (possibly empty) value.+type TagName = Text+type TagValue = Text+type Tag = (TagName, TagValue)  -- ^ A tag name and (possibly empty) value.  data ClearedStatus = Uncleared | Pending | Cleared-                   deriving (Eq,Ord,Typeable,Data,Generic)+  deriving (Eq,Ord,Typeable,Data,Generic)  instance NFData ClearedStatus -instance Show ClearedStatus where -- custom show-  show Uncleared = ""             -- a bad idea-  show Pending   = "!"            -- don't do it+instance Show ClearedStatus where -- custom show.. bad idea.. don't do it..+  show Uncleared = ""+  show Pending   = "!"   show Cleared   = "*"  data Posting = Posting {-      pdate :: Maybe Day,  -- ^ this posting's date, if different from the transaction's-      pdate2 :: Maybe Day,  -- ^ this posting's secondary date, if different from the transaction's-      pstatus :: ClearedStatus,-      paccount :: AccountName,-      pamount :: MixedAmount,-      pcomment :: String, -- ^ this posting's comment lines, as a single non-indented multi-line string-      ptype :: PostingType,-      ptags :: [Tag], -- ^ tag names and values, extracted from the comment-      pbalanceassertion :: Maybe MixedAmount,  -- ^ optional: the expected balance in the account after this posting-      ptransaction :: Maybe Transaction    -- ^ this posting's parent transaction (co-recursive types).-                                           -- Tying this knot gets tedious, Maybe makes it easier/optional.+      pdate             :: Maybe Day,         -- ^ this posting's date, if different from the transaction's+      pdate2            :: Maybe Day,         -- ^ this posting's secondary date, if different from the transaction's+      pstatus           :: ClearedStatus,+      paccount          :: AccountName,+      pamount           :: MixedAmount,+      pcomment          :: Text,              -- ^ this posting's comment lines, as a single non-indented multi-line string+      ptype             :: PostingType,+      ptags             :: [Tag],             -- ^ tag names and values, extracted from the comment+      pbalanceassertion :: Maybe MixedAmount, -- ^ optional: the expected balance in the account after this posting+      ptransaction      :: Maybe Transaction  -- ^ this posting's parent transaction (co-recursive types).+                                              -- Tying this knot gets tedious, Maybe makes it easier/optional.     } deriving (Typeable,Data,Generic)  instance NFData Posting@@ -170,102 +218,99 @@ instance NFData GenericSourcePos  data Transaction = Transaction {-      tindex :: Integer, -- ^ this transaction's 1-based position in the input stream, or 0 when not available-      tsourcepos :: GenericSourcePos,-      tdate :: Day,-      tdate2 :: Maybe Day,-      tstatus :: ClearedStatus,-      tcode :: String,-      tdescription :: String,-      tcomment :: String, -- ^ this transaction's comment lines, as a single non-indented multi-line string-      ttags :: [Tag], -- ^ tag names and values, extracted from the comment-      tpostings :: [Posting],            -- ^ this transaction's postings-      tpreceding_comment_lines :: String -- ^ any comment lines immediately preceding this transaction+      tindex                   :: Integer,   -- ^ this transaction's 1-based position in the input stream, or 0 when not available+      tsourcepos               :: GenericSourcePos,+      tdate                    :: Day,+      tdate2                   :: Maybe Day,+      tstatus                  :: ClearedStatus,+      tcode                    :: Text,+      tdescription             :: Text,+      tcomment                 :: Text,      -- ^ this transaction's comment lines, as a single non-indented multi-line string+      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)  instance NFData Transaction  data ModifierTransaction = ModifierTransaction {-      mtvalueexpr :: String,-      mtpostings :: [Posting]+      mtvalueexpr :: Text,+      mtpostings  :: [Posting]     } deriving (Eq,Typeable,Data,Generic)  instance NFData ModifierTransaction  data PeriodicTransaction = PeriodicTransaction {-      ptperiodicexpr :: String,-      ptpostings :: [Posting]+      ptperiodicexpr :: Text,+      ptpostings     :: [Posting]     } deriving (Eq,Typeable,Data,Generic)  instance NFData PeriodicTransaction -data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)+data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic) -instance NFData TimeLogCode+instance NFData TimeclockCode -data TimeLogEntry = TimeLogEntry {-      tlsourcepos :: GenericSourcePos,-      tlcode :: TimeLogCode,-      tldatetime :: LocalTime,-      tlaccount :: String,-      tldescription :: String+data TimeclockEntry = TimeclockEntry {+      tlsourcepos   :: GenericSourcePos,+      tlcode        :: TimeclockCode,+      tldatetime    :: LocalTime,+      tlaccount     :: AccountName,+      tldescription :: Text     } deriving (Eq,Ord,Typeable,Data,Generic) -instance NFData TimeLogEntry+instance NFData TimeclockEntry  data MarketPrice = MarketPrice {-      mpdate :: Day,-      mpcommodity :: Commodity,-      mpamount :: Amount+      mpdate      :: Day,+      mpcommodity :: CommoditySymbol,+      mpamount    :: Amount     } deriving (Eq,Ord,Typeable,Data,Generic) -- & Show (in Amount.hs)  instance NFData MarketPrice -type Year = Integer---- | A journal "context" is some data which can change in the course of--- parsing a journal. An example is the default year, which changes when a--- Y directive is encountered.  At the end of parsing, the final context--- is saved for later use by eg the add command.-data JournalContext = Ctx {-      ctxYear      :: !(Maybe Year)      -- ^ the default year most recently specified with Y-    , ctxDefaultCommodityAndStyle :: !(Maybe (Commodity,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D-    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts/account name components-                                        --   specified with "account" directive(s). Concatenated, these-                                        --   are the account prefix prepended to parsed account names.-    , ctxAliases   :: ![AccountAlias]   -- ^ the current list of account name aliases in effect-    , ctxTransactionIndex   :: !Integer -- ^ the number of transactions read so far-    } deriving (Read, Show, Eq, Data, Typeable, Generic)--instance NFData JournalContext+-- | A Journal, containing transactions and various other things.+-- The basic data model for hledger.+--+-- This is used during parsing (as the type alias ParsedJournal), and+-- then finalised/validated for use as a Journal. Some extra+-- parsing-related fields are included for convenience, at least for+-- now. In a ParsedJournal these are updated as parsing proceeds, in a+-- Journal they represent the final state at end of parsing (used eg+-- by the add command).+--+data Journal = Journal {+  -- parsing-related data+   jparsedefaultyear      :: Maybe Year                            -- ^ the current default year, specified by the most recent Y directive (or current date)+  ,jparsedefaultcommodity :: Maybe (CommoditySymbol,AmountStyle)   -- ^ the current default commodity and its format, specified by the most recent D directive+  ,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+  -- principal data+  ,jaccounts              :: [AccountName]                         -- ^ accounts that have been declared by account directives+  ,jcommodities           :: M.Map CommoditySymbol Commodity        -- ^ commodities and formats declared by commodity directives+  ,jinferredcommodities   :: M.Map CommoditySymbol AmountStyle      -- ^ commodities and formats inferred from journal amounts+  ,jmarketprices          :: [MarketPrice]+  ,jmodifiertxns          :: [ModifierTransaction]+  ,jperiodictxns          :: [PeriodicTransaction]+  ,jtxns                  :: [Transaction]+  ,jfinalcommentlines     :: Text                                   -- ^ any final trailing comments in the (main) journal file+  ,jfiles                 :: [(FilePath, Text)]                     -- ^ the file path and raw text of the main and+                                                                    --   any included journal files. The main file is first,+                                                                    --   followed by any included files in the order encountered.+  ,jlastreadtime          :: ClockTime                              -- ^ when this journal was last read from its file(s)+  } deriving (Eq, Typeable, Data, Generic)  deriving instance Data (ClockTime) deriving instance Typeable (ClockTime) deriving instance Generic (ClockTime)- instance NFData ClockTime--data Journal = Journal {-      jmodifiertxns :: [ModifierTransaction],-      jperiodictxns :: [PeriodicTransaction],-      jtxns :: [Transaction],-      open_timelog_entries :: [TimeLogEntry],-      jmarketprices :: [MarketPrice],-      final_comment_lines :: String,        -- ^ any trailing comments from the journal file-      jContext :: JournalContext,           -- ^ the context (parse state) at the end of parsing-      files :: [(FilePath, String)],        -- ^ the file path and raw text of the main and-                                            -- any included journal files. The main file is-                                            -- first followed by any included files in the-                                            -- order encountered.-      filereadtime :: ClockTime,            -- ^ when this journal was last read from its file(s)-      jcommoditystyles :: M.Map Commodity AmountStyle  -- ^ how to display amounts in each commodity-    } deriving (Eq, Typeable, Data, Generic)- instance NFData Journal --- | A JournalUpdate is some transformation of a Journal. It can do I/O or--- raise an exception.-type JournalUpdate = ExceptT String IO (Journal -> Journal)+-- | A journal in the process of being parsed, not yet finalised.+-- The data is partial, and list fields are in reverse order.+type ParsedJournal = Journal  -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output.@@ -277,9 +322,9 @@      -- name of the format this reader handles      rFormat   :: StorageFormat      -- quickly check if this reader can probably handle the given file path and file content-    ,rDetector :: FilePath -> String -> Bool+    ,rDetector :: FilePath -> Text -> Bool      -- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path-    ,rParser   :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal+    ,rParser   :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal     }  instance Show Reader where show r = rFormat r ++ " reader"@@ -287,22 +332,22 @@ -- | An account, with name, balances and links to parent/subaccounts -- which let you walk up or down the account tree. data Account = Account {-  aname :: AccountName,     -- ^ this account's full name-  aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts-  asubs :: [Account],       -- ^ sub-accounts-  anumpostings :: Int,      -- ^ number of postings to this account-  -- derived from the above:-  aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts-  aparent :: Maybe Account, -- ^ parent account-  aboring :: Bool           -- ^ used in the accounts report to label elidable parents-  }+  aname                     :: AccountName,   -- ^ this account's full name+  aebalance                 :: MixedAmount,   -- ^ this account's balance, excluding subaccounts+  asubs                     :: [Account],     -- ^ sub-accounts+  anumpostings              :: Int,           -- ^ number of postings to this account+  -- derived from the above :+  aibalance                 :: MixedAmount,   -- ^ this account's balance, including subaccounts+  aparent                   :: Maybe Account, -- ^ parent account+  aboring                   :: Bool           -- ^ used in the accounts report to label elidable parents+  } deriving (Typeable, Data, Generic)  -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and -- tree-wise, since each one knows its parent and subs; the first -- account is the root of the tree and always exists. data Ledger = Ledger {-  ljournal :: Journal,+  ljournal  :: Journal,   laccounts :: [Account] } 

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-|  A general query system for matching things (accounts, postings,@@ -6,6 +5,8 @@  -} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}+ module Hledger.Query (   -- * Query and QueryOpt   Query(..),@@ -23,6 +24,9 @@   queryIsDateOrDate2,   queryIsStartDateOnly,   queryIsSym,+  queryIsReal,+  queryIsStatus,+  queryIsEmpty,   queryStartDate,   queryEndDate,   queryDateSpan,@@ -45,13 +49,16 @@ import Data.Either import Data.List import Data.Maybe+import Data.Monoid ((<>))+-- import Data.Text (Text)+import qualified Data.Text as T import Data.Time.Calendar import Safe (readDef, headDef) import Test.HUnit--- import Text.ParserCombinators.Parsec-import Text.Parsec hiding (Empty)+import Text.Megaparsec+import Text.Megaparsec.Text -import Hledger.Utils+import Hledger.Utils hiding (words') import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount (amount, nullamt, usd)@@ -149,7 +156,7 @@ -- 1. multiple account patterns are OR'd together -- 2. multiple description patterns are OR'd together -- 3. then all terms are AND'd together-parseQuery :: Day -> String -> (Query,[QueryOpt])+parseQuery :: Day -> T.Text -> (Query,[QueryOpt]) parseQuery d s = (q, opts)   where     terms = words'' prefixes s@@ -173,21 +180,27 @@ -- | 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 -- prefixes in front, and maybe an additional not: prefix in front of that.-words'' :: [String] -> String -> [String]+words'' :: [T.Text] -> T.Text -> [T.Text] words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX     where-      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` many1 spacenonewline+      maybeprefixedquotedphrases :: Parser [T.Text]+      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline+      prefixedQuotedPattern :: Parser T.Text       prefixedQuotedPattern = do-        not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")+        not' <- fromMaybe "" `fmap` (optional $ string "not:")         let allowednexts | null not' = prefixes                          | otherwise = prefixes ++ [""]-        next <- choice' $ map string allowednexts-        let prefix = not' ++ next+        next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts+        let prefix :: T.Text+            prefix = T.pack not' <> next         p <- singleQuotedPattern <|> doubleQuotedPattern-        return $ prefix ++ stripquotes p-      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes-      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes-      pattern = many (noneOf " \n\r")+        return $ prefix <> stripquotes p+      singleQuotedPattern :: Parser T.Text+      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack+      doubleQuotedPattern :: Parser T.Text+      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack+      pattern :: Parser T.Text+      pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))  tests_words'' = [    "words''" ~: do@@ -204,7 +217,8 @@  -- XXX -- keep synced with patterns below, excluding "not"-prefixes = map (++":") [+prefixes :: [T.Text]+prefixes = map (<>":") [      "inacctonly"     ,"inacct"     ,"amt"@@ -221,6 +235,7 @@     ,"tag"     ] +defaultprefix :: T.Text defaultprefix = "acct"  -- -- | Parse the query string as a boolean tree of match patterns.@@ -235,36 +250,37 @@  -- | Parse a single query term as either a query or a query option, -- or raise an error if it has invalid syntax.-parseQueryTerm :: Day -> String -> Either Query QueryOpt-parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s-parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s-parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of-                                       Left m  -> Left $ Not m-                                       Right _ -> Left Any -- not:somequeryoption will be ignored-parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s-parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s-parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s-parseQueryTerm d ('d':'a':'t':'e':'2':':':s) =-        case parsePeriodExpr d s of Left e         -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e+parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt+parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s+parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s+parseQueryTerm d (T.stripPrefix "not:" -> Just s) =+  case parseQueryTerm d s of+    Left m -> Left $ Not m+    Right _ -> Left Any -- not:somequeryoption will be ignored+parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s+parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s+parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s+parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =+        case parsePeriodExpr d s of Left e         -> error' $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e                                     Right (_,span) -> Left $ Date2 span-parseQueryTerm d ('d':'a':'t':'e':':':s) =-        case parsePeriodExpr d s of Left e         -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e+parseQueryTerm d (T.stripPrefix "date:" -> Just s) =+        case parsePeriodExpr d s of Left e         -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e                                     Right (_,span) -> Left $ Date span-parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = -        case parseStatus s of Left e   -> error' $ "\"status:"++s++"\" gave a parse error: " ++ e+parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =+        case parseStatus s of Left e   -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e                               Right st -> Left $ Status st-parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s || null s-parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s-parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s-parseQueryTerm _ ('d':'e':'p':'t':'h':':':s)+parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s+parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s+parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s+parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)   | n >= 0    = Left $ Depth n   | otherwise = error' "depth: should have a positive number"-  where n = readDef 0 s+  where n = readDef 0 (T.unpack s) -parseQueryTerm _ ('c':'u':'r':':':s) = Left $ Sym s -- support cur: as an alias-parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s+parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s) -- support cur: as an alias+parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ "" = Left $ Any-parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s+parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s  tests_parseQueryTerm = [   "parseQueryTerm" ~: do@@ -293,35 +309,40 @@  deriving (Show,Eq,Data,Typeable)  -- can fail-parseAmountQueryTerm :: String -> (OrdPlus, Quantity)+parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity) parseAmountQueryTerm s' =   case s' of     -- feel free to do this a smarter way     ""              -> err-    '<':'+':s       -> (Lt, readDef err s)-    '<':'=':'+':s   -> (LtEq, readDef err s)-    '>':'+':s       -> (Gt, readDef err s)-    '>':'=':'+':s   -> (GtEq, readDef err s)-    '=':'+':s       -> (Eq, readDef err s)-    '+':s           -> (Eq, readDef err s)-    '<':'-':s       -> (Lt, negate $ readDef err s)-    '<':'=':'-':s   -> (LtEq, negate $ readDef err s)-    '>':'-':s       -> (Gt, negate $ readDef err s)-    '>':'=':'-':s   -> (GtEq, negate $ readDef err s)-    '=':'-':s       -> (Eq, negate $ readDef err s)-    '-':s           -> (Eq, negate $ readDef err s)-    '<':'=':s       -> let n = readDef err s in case n of 0 -> (LtEq, 0)-                                                          _ -> (AbsLtEq, n)-    '<':s           -> let n = readDef err s in case n of 0 -> (Lt, 0)-                                                          _ -> (AbsLt, n)-    '>':'=':s       -> let n = readDef err s in case n of 0 -> (GtEq, 0)-                                                          _ -> (AbsGtEq, n)-    '>':s           -> let n = readDef err s in case n of 0 -> (Gt, 0)-                                                          _ -> (AbsGt, n)-    '=':s           -> (AbsEq, readDef err s)-    s               -> (AbsEq, readDef err s)+    (T.stripPrefix "<+" -> Just s)  -> (Lt, readDef err (T.unpack s))+    (T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))+    (T.stripPrefix ">+" -> Just s)  -> (Gt, readDef err (T.unpack s))+    (T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))+    (T.stripPrefix "=+" -> Just s)  -> (Eq, readDef err (T.unpack s))+    (T.stripPrefix "+" -> Just s)   -> (Eq, readDef err (T.unpack s))+    (T.stripPrefix "<-" -> Just s)  -> (Lt, negate $ readDef err (T.unpack s))+    (T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))+    (T.stripPrefix ">-" -> Just s)  -> (Gt, negate $ readDef err (T.unpack s))+    (T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))+    (T.stripPrefix "=-" -> Just s)  -> (Eq, negate $ readDef err (T.unpack s))+    (T.stripPrefix "-" -> Just s)   -> (Eq, negate $ readDef err (T.unpack s))+    (T.stripPrefix "<=" -> Just s)  -> let n = readDef err (T.unpack s) in+                                         case n of+                                           0 -> (LtEq, 0)+                                           _ -> (AbsLtEq, n)+    (T.stripPrefix "<" -> Just s)   -> let n = readDef err (T.unpack s) in+                                         case n of 0 -> (Lt, 0)+                                                   _ -> (AbsLt, n)+    (T.stripPrefix ">=" -> Just s)  -> let n = readDef err (T.unpack s) in+                                         case n of 0 -> (GtEq, 0)+                                                   _ -> (AbsGtEq, n)+    (T.stripPrefix ">" -> Just s)   -> let n = readDef err (T.unpack s) in+                                         case n of 0 -> (Gt, 0)+                                                   _ -> (AbsGt, n)+    (T.stripPrefix "=" -> Just s)           -> (AbsEq, readDef err (T.unpack s))+    s               -> (AbsEq, readDef err (T.unpack s))   where-    err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s'+    err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s'  tests_parseAmountQueryTerm = [   "parseAmountQueryTerm" ~: do@@ -335,13 +356,13 @@     "-0.23" `gives` (Eq,(-0.23))   ] -parseTag :: String -> (Regexp, Maybe Regexp)-parseTag s | '=' `elem` s = (n, Just $ tail v)-           | otherwise    = (s, Nothing)-           where (n,v) = break (=='=') s+parseTag :: T.Text -> (Regexp, Maybe Regexp)+parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)+           | otherwise    = (T.unpack s, Nothing)+           where (n,v) = T.break (=='=') s  -- | Parse the value part of a "status:" query, or return an error.-parseStatus :: String -> Either String ClearedStatus+parseStatus :: T.Text -> Either String ClearedStatus parseStatus s | s `elem` ["*","1"] = Right Cleared               | s `elem` ["!"]     = Right Pending               | s `elem` ["","0"]  = Right Uncleared@@ -349,10 +370,10 @@  -- | Parse the boolean value part of a "status:" query. "1" means true, -- anything else will be parsed as false without error.-parseBool :: String -> Bool+parseBool :: T.Text -> Bool parseBool s = s `elem` truestrings -truestrings :: [String]+truestrings :: [T.Text] truestrings = ["1"]  simplifyQuery :: Query -> Query@@ -395,7 +416,7 @@ same (a:as) = all (a==) as  -- | Remove query terms (or whole sub-expressions) not matching the given--- predicate from this query.  XXX Semantics not yet clear.+-- predicate from this query.  XXX Semantics not completely clear. filterQuery :: (Query -> Bool) -> Query -> Query filterQuery p = simplifyQuery . filterQuery' p @@ -452,6 +473,18 @@ queryIsSym (Sym _) = True queryIsSym _ = False +queryIsReal :: Query -> Bool+queryIsReal (Real _) = True+queryIsReal _ = False++queryIsStatus :: Query -> Bool+queryIsStatus (Status _) = True+queryIsStatus _ = False++queryIsEmpty :: Query -> Bool+queryIsEmpty (Empty _) = True+queryIsEmpty _ = False+ -- | Does this query specify a start date and nothing else (that would -- filter postings prior to the date) ? -- When the flag is true, look for a starting secondary date instead.@@ -557,8 +590,8 @@ -- Just looks at the first query option. inAccountQuery :: [QueryOpt] -> Maybe Query inAccountQuery [] = Nothing-inAccountQuery (QueryOptInAcctOnly a:_) = Just $ Acct $ accountNameToAccountOnlyRegex a-inAccountQuery (QueryOptInAcct a:_) = Just $ Acct $ accountNameToAccountRegex a+inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a+inAccountQuery (QueryOptInAcct a     : _) = Just $ Acct $ accountNameToAccountRegex a  -- -- | Convert a query to its inverse. -- negateQuery :: Query -> Query@@ -573,7 +606,7 @@ matchesAccount (Not m) a = not $ matchesAccount m a matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms-matchesAccount (Acct r) a = regexMatchesCI r a+matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a) -- XXX pack matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True@@ -605,7 +638,7 @@ matchesAmount (And qs) a = all (`matchesAmount` a) qs -- matchesAmount (Amt ord n) a = compareAmount ord n a-matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ acommodity a+matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ T.unpack $ acommodity a -- matchesAmount _ _ = True @@ -632,9 +665,9 @@ matchesPosting (None) _ = False matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs-matchesPosting (Code r) p = regexMatchesCI r $ maybe "" tcode $ ptransaction p-matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p-matchesPosting (Acct r) p = regexMatchesCI r $ paccount p+matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p+matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p+matchesPosting (Acct r) p = regexMatchesCI r $ T.unpack $ paccount p -- XXX pack matchesPosting (Date span) p = span `spanContainsDate` postingDate p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (Status Uncleared) p = postingStatus p /= Cleared@@ -647,7 +680,7 @@ -- 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 acommodity as+matchesPosting (Sym r) Posting{pamount=Mixed as} = any (regexMatchesCI $ "^" ++ r ++ "$") $ map (T.unpack . acommodity) as matchesPosting (Tag n v) p = not $ null $ matchedTags n v $ postingAllTags p -- matchesPosting _ _ = False @@ -690,8 +723,8 @@ matchesTransaction (None) _ = False matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs-matchesTransaction (Code r) t = regexMatchesCI r $ tcode t-matchesTransaction (Desc r) t = regexMatchesCI r $ tdescription t+matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t+matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Date span) t = spanContainsDate span $ tdate t matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t@@ -723,8 +756,8 @@ matchedTags :: Regexp -> Maybe Regexp -> [Tag] -> [Tag] matchedTags namepat valuepat tags = filter (match namepat valuepat) tags   where-    match npat Nothing     (n,_) = regexMatchesCI npat n-    match npat (Just vpat) (n,v) = regexMatchesCI npat n && regexMatchesCI vpat v+    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)  -- tests 

@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-|  This is the entry point to hledger's reading system, which can read@@ -8,7 +7,12 @@  -} -module Hledger.Read (+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}++module Hledger.Read+  (+       module Hledger.Read.Common,+       readFormatNames,        -- * Journal reading API        defaultJournalPath,        defaultJournal,@@ -20,12 +24,12 @@        ensureJournalFileExists,        -- * Parsers used elsewhere        postingp,-       accountnamep,-       amountp,-       amountp',-       mamountp',-       numberp,-       codep,+       -- accountnamep,+       -- amountp,+       -- amountp',+       -- mamountp',+       -- numberp,+       -- codep,        accountaliasp,        -- * Tests        samplejournal,@@ -36,115 +40,54 @@ import Control.Monad.Except import Data.List import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure) import System.FilePath ((</>))-import System.IO (IOMode(..), openFile, stdin, stderr, hSetNewlineMode, universalNewlineMode)+import System.IO (stderr) import Test.HUnit import Text.Printf  import Hledger.Data.Dates (getCurrentDay) import Hledger.Data.Types-import Hledger.Data.Journal (nullctx)+import Hledger.Read.Common import Hledger.Read.JournalReader as JournalReader-import Hledger.Read.TimelogReader as TimelogReader+import Hledger.Read.TimedotReader as TimedotReader+import Hledger.Read.TimeclockReader as TimeclockReader import Hledger.Read.CsvReader as CsvReader import Hledger.Utils import Prelude hiding (getContents, writeFile)-import Hledger.Utils.UTF8IOCompat (hGetContents, writeFile)+import Hledger.Utils.UTF8IOCompat (writeFile)  -journalEnvVar           = "LEDGER_FILE"-journalEnvVar2          = "LEDGER"-journalDefaultFilename  = ".hledger.journal"- -- The available data file readers, each one handling a particular data -- format. The first is also used as the default for unknown formats. readers :: [Reader] readers = [   JournalReader.reader- ,TimelogReader.reader+ ,TimeclockReader.reader+ ,TimedotReader.reader  ,CsvReader.reader  ] --- | All the data formats we can read.--- formats = map rFormat readers---- | Get the default journal file path specified by the environment.--- Like ledger, we look first for the LEDGER_FILE environment--- variable, and if that does not exist, for the legacy LEDGER--- environment variable. If neither is set, or the value is blank,--- return the hard-coded default, which is @.hledger.journal@ in the--- users's home directory (or in the current directory, if we cannot--- determine a home directory).-defaultJournalPath :: IO String-defaultJournalPath = do-  s <- envJournalPath-  if null s then defaultJournalPath else return s-    where-      envJournalPath =-        getEnv journalEnvVar-         `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2-                                            `C.catch` (\(_::C.IOException) -> return ""))-      defaultJournalPath = do-                  home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")-                  return $ home </> journalDefaultFilename---- | Read the default journal file specified by the environment, or raise an error.-defaultJournal :: IO Journal-defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing True >>= either error' return---- | Read a journal from the given string, trying all known formats, or simply throw an error.-readJournal' :: String -> IO Journal-readJournal' s = readJournal Nothing Nothing True Nothing s >>= either error' return--tests_readJournal' = [-  "readJournal' parses sample journal" ~: do-     _ <- samplejournal-     assertBool "" True- ]--+readFormatNames :: [StorageFormat]+readFormatNames = map rFormat readers --- | Read a journal from this string, trying whatever readers seem appropriate:------ - if a format is specified, try that reader only------ - or if one or more readers recognises the file path and data, try those------ - otherwise, try them all.------ A CSV conversion rules file may also be specified for use by the CSV reader.--- Also there is a flag specifying whether to check or ignore balance assertions in the journal.-readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> String -> IO (Either String Journal)-readJournal format rulesfile assrt path s =-  tryReaders $ readersFor (format, path, s)-  where-    -- try each reader in turn, returning the error of the first if all fail-    tryReaders :: [Reader] -> IO (Either String Journal)-    tryReaders = firstSuccessOrBestError []-      where-        firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal)-        firstSuccessOrBestError [] []        = return $ Left "no readers found"-        firstSuccessOrBestError errs (r:rs) = do-          dbg1IO "trying reader" (rFormat r)-          result <- (runExceptT . (rParser r) rulesfile assrt path') s-          dbg1IO "reader result" $ either id show result-          case result of Right j -> return $ Right j                       -- success!-                         Left e  -> firstSuccessOrBestError (errs++[e]) rs -- keep trying-        firstSuccessOrBestError (e:_) []    = return $ Left e              -- none left, return first error-        path' = fromMaybe "(string)" path+journalEnvVar           = "LEDGER_FILE"+journalEnvVar2          = "LEDGER"+journalDefaultFilename  = ".hledger.journal"  -- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ?-readersFor :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader]-readersFor (format,path,s) =-    dbg1 ("possible readers for "++show (format,path,elideRight 30 s)) $+readersFor :: (Maybe StorageFormat, Maybe FilePath, Text) -> [Reader]+readersFor (format,path,t) =+    dbg1 ("possible readers for "++show (format,path,textElideRight 30 t)) $     case format of      Just f  -> case readerForStorageFormat f of Just r  -> [r]                                                  Nothing -> []      Nothing -> case path of Nothing  -> readers-                             Just p   -> case readersForPathAndData (p,s) of [] -> readers+                             Just p   -> case readersForPathAndData (p,t) of [] -> readers                                                                              rs -> rs  -- | Find the (first) reader which can handle the given format, if any.@@ -155,36 +98,65 @@       rs = filter ((s==).rFormat) readers :: [Reader]  -- | Find the readers which think they can handle the given file path and data, if any.-readersForPathAndData :: (FilePath,String) -> [Reader]-readersForPathAndData (f,s) = filter (\r -> (rDetector r) f s) readers+readersForPathAndData :: (FilePath,Text) -> [Reader]+readersForPathAndData (f,t) = filter (\r -> dbg1 ("try "++rFormat r++" format") $ (rDetector r) f t) readers +-- try each reader in turn, returning the error of the first if all fail+tryReaders :: [Reader] -> Maybe FilePath -> Bool -> Maybe FilePath -> Text -> IO (Either String Journal)+tryReaders readers mrulesfile assrt path t = firstSuccessOrBestError [] readers+  where+    firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal)+    firstSuccessOrBestError [] []        = return $ Left "no readers found"+    firstSuccessOrBestError errs (r:rs) = do+      dbg1IO "trying reader" (rFormat r)+      result <- (runExceptT . (rParser r) mrulesfile assrt path') t+      dbg1IO "reader result" $ either id show result+      case result of Right j -> return $ Right j                       -- success!+                     Left e  -> firstSuccessOrBestError (errs++[e]) rs -- keep trying+    firstSuccessOrBestError (e:_) []    = return $ Left e              -- none left, return first error+    path' = fromMaybe "(string)" path++-- | Read a journal from this string, trying whatever readers seem appropriate:+--+-- - if a format is specified, try that reader only+--+-- - or if one or more readers recognises the file path and data, try those+--+-- - otherwise, try them all.+--+-- A CSV conversion rules file may also be specified for use by the CSV reader.+-- Also there is a flag specifying whether to check or ignore balance assertions in the journal.+readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> Text -> IO (Either String Journal)+readJournal mformat mrulesfile assrt mpath t = tryReaders (readersFor (mformat, mpath, t)) mrulesfile assrt mpath t++-- | Call readJournalFile on each specified file path, and combine the+-- resulting journals into one. If there are any errors, the first is+-- returned, otherwise they are combined per Journal's monoid instance+-- (concatenated, basically). Parse context (eg directives & aliases)+-- is not maintained across file boundaries, it resets at the start of+-- each file (though the rfinal parse state saved in the resulting+-- journal is the combination of parse states from all files).+readJournalFiles :: Maybe StorageFormat -> Maybe FilePath -> Bool -> [FilePath] -> IO (Either String Journal)+readJournalFiles mformat mrulesfile assrt fs = do+  (either Left (Right . mconcat) . sequence)+    <$> mapM (readJournalFile mformat mrulesfile assrt) fs+ -- | Read a Journal from this file (or stdin if the filename is -) or give -- an error message, using the specified data format or trying all known -- formats. A CSV conversion rules file may be specified for better -- conversion of that format. Also there is a flag specifying whether -- to check or ignore balance assertions in the journal. readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> Bool -> FilePath -> IO (Either String Journal)-readJournalFile format rulesfile assrt f = readJournalFiles format rulesfile assrt [f]--readJournalFiles :: Maybe StorageFormat -> Maybe FilePath -> Bool -> [FilePath] -> IO (Either String Journal)-readJournalFiles format rulesfile assrt f = do-  contents <- fmap concat $ mapM readFileAnyNewline f-  readJournal format rulesfile assrt (listToMaybe f) contents- where-  readFileAnyNewline f = do-    requireJournalFileExists f-    h <- fileHandle f-    hSetNewlineMode h universalNewlineMode-    hGetContents h-  fileHandle "-" = return stdin-  fileHandle f = openFile f ReadMode+readJournalFile mformat mrulesfile assrt f = do+  requireJournalFileExists f+  readFileOrStdinAnyLineEnding f >>= readJournal mformat mrulesfile assrt (Just f)  -- | If the specified journal file does not exist, give a helpful error and quit. requireJournalFileExists :: FilePath -> IO () requireJournalFileExists "-" = return () requireJournalFileExists f = do   exists <- doesFileExist f-  when (not exists) $ do+  when (not exists) $ do  -- XXX might not be a journal file     hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f     hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"     hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"@@ -206,9 +178,43 @@   d <- getCurrentDay   return $ printf "; journal created %s by hledger\n" (show d) +-- | Get the default journal file path specified by the environment.+-- Like ledger, we look first for the LEDGER_FILE environment+-- variable, and if that does not exist, for the legacy LEDGER+-- environment variable. If neither is set, or the value is blank,+-- return the hard-coded default, which is @.hledger.journal@ in the+-- users's home directory (or in the current directory, if we cannot+-- determine a home directory).+defaultJournalPath :: IO String+defaultJournalPath = do+  s <- envJournalPath+  if null s then defaultJournalPath else return s+    where+      envJournalPath =+        getEnv journalEnvVar+         `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2+                                            `C.catch` (\(_::C.IOException) -> return ""))+      defaultJournalPath = do+                  home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")+                  return $ home </> journalDefaultFilename++-- | Read the default journal file specified by the environment, or raise an error.+defaultJournal :: IO Journal+defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing True >>= either error' return++-- | Read a journal from the given text, trying all known formats, or simply throw an error.+readJournal' :: Text -> IO Journal+readJournal' t = readJournal Nothing Nothing True Nothing t >>= either error' return++tests_readJournal' = [+  "readJournal' parses sample journal" ~: do+     _ <- samplejournal+     assertBool "" True+ ]+ -- tests -samplejournal = readJournal' $ unlines+samplejournal = readJournal' $ T.unlines  ["2008/01/01 income"  ,"    assets:bank:checking  $1"  ,"    income:salary"@@ -240,11 +246,12 @@   tests_readJournal'   ++ [    tests_Hledger_Read_JournalReader,-   tests_Hledger_Read_TimelogReader,+   tests_Hledger_Read_TimeclockReader,+   tests_Hledger_Read_TimedotReader,    tests_Hledger_Read_CsvReader,     "journal" ~: do-    r <- runExceptT $ parseWithCtx nullctx JournalReader.journalp ""+    r <- runExceptT $ parseWithState mempty JournalReader.journalp ""     assertBool "journalp should parse an empty file" (isRight $ r)     jE <- readJournal Nothing Nothing True 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

@@ -0,0 +1,828 @@+--- * doc+-- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,+-- (add-hook 'haskell-mode-hook+--   (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))+--   'orgstruct-mode)+-- and press TAB on nodes to expand/collapse.++{-|++Some common parsers and helpers used by several readers.+Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.++-}++--- * module+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections, OverloadedStrings #-}++module Hledger.Read.Common+where+--- * imports+import Prelude ()+import Prelude.Compat hiding (readFile)+import Control.Monad.Compat+import Control.Monad.Except (ExceptT(..), runExceptT, throwError) --, catchError)+import Control.Monad.State.Strict+import Data.Char (isNumber)+import Data.Functor.Identity+import Data.List.Compat+import Data.List.NonEmpty (NonEmpty(..))+import Data.List.Split (wordsBy)+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Calendar+import Data.Time.LocalTime+import Safe+import System.Time (getClockTime)+import Text.Megaparsec hiding (parse,State)+import Text.Megaparsec.Text++import Hledger.Data+import Hledger.Utils++-- $setup++--- * parsing utils++-- | Run a string parser with no state in the identity monad.+runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Dec) a+runTextParser p t =  runParser p "" t+rtp = runTextParser++-- | Run a journal parser with a null journal-parsing state.+runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char Dec) a)+runJournalParser p t = runParserT p "" t+rjp = runJournalParser++-- | Run an error-raising journal parser with a null journal-parsing state.+runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a)+runErroringJournalParser p t =+  runExceptT $+  runJournalParser (evalStateT p mempty)+                   t >>=+  either (throwError . parseErrorPretty) return+rejp = runErroringJournalParser++genericSourcePos :: SourcePos -> GenericSourcePos+genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)++-- | Given a parsec ParsedJournal parser, file path and data string,+-- parse and post-process a ready-to-use Journal, or give an error.+parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal+parseAndFinaliseJournal parser assrt f txt = do+  t <- liftIO getClockTime+  y <- liftIO getCurrentYear+  ep <- runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt+  case ep of+    Right pj -> case journalFinalise t f txt assrt pj of+                        Right j -> return j+                        Left e  -> throwError e+    Left e   -> throwError $ parseErrorPretty e++parseAndFinaliseJournal' :: JournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal+parseAndFinaliseJournal' parser assrt 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 -> case journalFinalise t f txt assrt pj of+                        Right j -> return j+                        Left e  -> throwError e+    Left e   -> throwError $ parseErrorPretty e++setYear :: Year -> JournalStateParser m ()+setYear y = modify' (\j -> j{jparsedefaultyear=Just y})++getYear :: JournalStateParser m (Maybe Year)+getYear = fmap jparsedefaultyear get++setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser ()+setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})++getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))+getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get++pushAccount :: AccountName -> ErroringJournalParser ()+pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})++pushParentAccount :: AccountName -> ErroringJournalParser ()+pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})++popParentAccount :: ErroringJournalParser ()+popParentAccount = do+  j <- get+  case jparseparentaccounts j of+    []       -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))+    (_:rest) -> put j{jparseparentaccounts=rest}++getParentAccount :: ErroringJournalParser AccountName+getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get++addAccountAlias :: MonadState Journal m => AccountAlias -> m ()+addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})++getAccountAliases :: MonadState Journal m => m [AccountAlias]+getAccountAliases = fmap jparsealiases get++clearAccountAliases :: MonadState Journal m => m ()+clearAccountAliases = modify' (\(j@Journal{..}) -> j{jparsealiases=[]})++-- getTransactionCount :: MonadState Journal m =>  m Integer+-- getTransactionCount = fmap jparsetransactioncount get+--+-- setTransactionCount :: MonadState Journal m => Integer -> m ()+-- setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})+--+-- -- | Increment the transaction index by one and return the new value.+-- incrementTransactionCount :: MonadState Journal m => m Integer+-- incrementTransactionCount = do+--   modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})+--   getTransactionCount++journalAddFile :: (FilePath,Text) -> Journal -> Journal+journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}+  -- append, unlike the other fields, even though we do a final reverse,+  -- to compensate for additional reversal due to including/monoid-concatting++-- -- | Terminate parsing entirely, returning the given error message+-- -- with the current parse position prepended.+-- parserError :: String -> ErroringJournalParser a+-- parserError s = do+--   pos <- getPosition+--   parserErrorAt pos s++-- | Terminate parsing entirely, returning the given error message+-- with the given parse position prepended.+parserErrorAt :: SourcePos -> String -> ErroringJournalParser a+parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s++--- * parsers+--- ** transaction bits++statusp :: TextParser m ClearedStatus+statusp =+  choice'+    [ many spacenonewline >> char '*' >> return Cleared+    , many spacenonewline >> char '!' >> return Pending+    , return Uncleared+    ]+    <?> "cleared status"++codep :: TextParser m String+codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""++descriptionp :: ErroringJournalParser String+descriptionp = many (noneOf (";\n" :: [Char]))++--- ** dates++-- | 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.+datep :: JournalStateParser m Day+datep = do+  -- hacky: try to ensure precise errors for invalid dates+  -- XXX reported error position is not too good+  -- pos <- genericSourcePos <$> getPosition+  datestr <- do+    c <- digitChar+    cs <- lift $ many $ choice' [digitChar, datesepchar]+    return $ c:cs+  let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr+  when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr+  let dateparts = wordsBy (`elem` datesepchars) datestr+  currentyear <- getYear+  [y,m,d] <- case (dateparts,currentyear) of+              ([m,d],Just y)  -> return [show y,m,d]+              ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"+              ([y,m,d],_)     -> return [y,m,d]+              _               -> fail $ "bad date: " ++ datestr+  let maybedate = fromGregorianValid (read y) (read m) (read d)+  case maybedate of+    Nothing   -> fail $ "bad date: " ++ datestr+    Just date -> return date+  <?> "full or partial date"++-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.+-- Hyphen (-) and period (.) are also allowed as date separators.+-- The year may be omitted if a default year has been set.+-- Seconds are optional.+-- The timezone is optional and ignored (the time is always interpreted as a local time).+-- Leading zeroes may be omitted (except in a timezone).+datetimep :: ErroringJournalParser LocalTime+datetimep = do+  day <- datep+  lift $ some spacenonewline+  h <- some digitChar+  let h' = read h+  guard $ h' >= 0 && h' <= 23+  char ':'+  m <- some digitChar+  let m' = read m+  guard $ m' >= 0 && m' <= 59+  s <- optional $ char ':' >> some digitChar+  let s' = case s of Just sstr -> read sstr+                     Nothing   -> 0+  guard $ s' >= 0 && s' <= 59+  {- tz <- -}+  optional $ do+                   plusminus <- oneOf ("-+" :: [Char])+                   d1 <- digitChar+                   d2 <- digitChar+                   d3 <- digitChar+                   d4 <- digitChar+                   return $ plusminus:d1:d2:d3:d4:""+  -- ltz <- liftIO $ getCurrentTimeZone+  -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz+  -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')+  return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')++secondarydatep :: Day -> ErroringJournalParser Day+secondarydatep primarydate = do+  char '='+  -- kludgy way to use primary date for default year+  let withDefaultYear d p = do+        y <- getYear+        let (y',_,_) = toGregorian d in setYear y'+        r <- p+        when (isJust y) $ setYear $ fromJust y -- XXX+        -- mapM setYear <$> y+        return r+  withDefaultYear primarydate datep++-- |+-- >> parsewith twoorthreepartdatestringp "2016/01/2"+-- Right "2016/01/2"+-- twoorthreepartdatestringp = do+--   n1 <- some digitChar+--   c <- datesepchar+--   n2 <- some digitChar+--   mn3 <- optional $ char c >> some digitChar+--   return $ n1 ++ c:n2 ++ maybe "" (c:) mn3++--- ** account names++-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.+modifiedaccountnamep :: ErroringJournalParser AccountName+modifiedaccountnamep = do+  parent <- getParentAccount+  aliases <- getAccountAliases+  a <- lift accountnamep+  return $+    accountNameApplyAliases aliases $+     -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference+    joinAccountNames parent+    a++-- | Parse an account name. Account names start with a non-space, may+-- have single spaces inside them, 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 char.+-- (This parser will also consume one following space, if present.)+accountnamep :: TextParser m AccountName+accountnamep = do+    astr <- do+      c <- nonspace+      cs <- striptrailingspace <$> many (nonspace <|> singlespace)+      return $ c:cs+    let a = T.pack astr+    when (accountNameFromComponents (accountNameComponents a) /= a)+         (fail $ "account name seems ill-formed: "++astr)+    return a+    where+      singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})+      striptrailingspace "" = ""+      striptrailingspace s  = if last s == ' ' then init s else s++-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace+--     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"++--- ** amounts++-- | Parse whitespace then an amount, with an optional left or right+-- currency symbol and optional price, or return the special+-- "missing" marker amount.+spaceandamountormissingp :: ErroringJournalParser MixedAmount+spaceandamountormissingp =+  try (do+        lift $ some spacenonewline+        (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt+      ) <|> return missingmixedamt++#ifdef TESTS+assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion+assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse++is' :: (Eq a, Show a) => a -> a -> Assertion+a `is'` e = assertEqual e a++test_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.+amountp :: Monad m => JournalStateParser m Amount+amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp++#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 =+  case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of+    Right amt -> amt+    Left err  -> error' $ show err -- XXX should throwError++-- | Parse a mixed amount from a string, or get an error.+mamountp' :: String -> MixedAmount+mamountp' = Mixed . (:[]) . amountp'++signp :: TextParser m String+signp = do+  sign <- optional $ oneOf ("+-" :: [Char])+  return $ case sign of Just '-' -> "-"+                        _        -> ""++leftsymbolamountp :: Monad m => JournalStateParser m Amount+leftsymbolamountp = do+  sign <- lift signp+  c <- lift commoditysymbolp+  sp <- lift $ many spacenonewline+  (q,prec,mdec,mgrps) <- lift numberp+  let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}+  p <- priceamountp+  let applysign = if sign=="-" then negate else id+  return $ applysign $ Amount c q p s+  <?> "left-symbol amount"++rightsymbolamountp :: Monad m => JournalStateParser m Amount+rightsymbolamountp = do+  (q,prec,mdec,mgrps) <- lift numberp+  sp <- lift $ many spacenonewline+  c <- lift commoditysymbolp+  p <- priceamountp+  let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}+  return $ Amount c q p s+  <?> "right-symbol amount"++nosymbolamountp :: Monad m => JournalStateParser m Amount+nosymbolamountp = do+  (q,prec,mdec,mgrps) <- lift numberp+  p <- priceamountp+  -- apply the most recently seen default commodity and style to this commodityless amount+  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})+  return $ Amount c q p s+  <?> "no-symbol amount"++commoditysymbolp :: TextParser m CommoditySymbol+commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"++quotedcommoditysymbolp :: TextParser m CommoditySymbol+quotedcommoditysymbolp = do+  char '"'+  s <- some $ noneOf (";\n\"" :: [Char])+  char '"'+  return $ T.pack s++simplecommoditysymbolp :: TextParser m CommoditySymbol+simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)++priceamountp :: Monad m => JournalStateParser m Price+priceamountp =+    try (do+          lift (many spacenonewline)+          char '@'+          try (do+                char '@'+                lift (many spacenonewline)+                a <- amountp -- XXX can parse more prices ad infinitum, shouldn't+                return $ TotalPrice a)+           <|> (do+            lift (many spacenonewline)+            a <- amountp -- XXX can parse more prices ad infinitum, shouldn't+            return $ UnitPrice a))+         <|> return NoPrice++partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount)+partialbalanceassertionp =+    try (do+          lift (many spacenonewline)+          char '='+          lift (many spacenonewline)+          a <- amountp -- XXX should restrict to a simple amount+          return $ Just $ Mixed [a])+         <|> return Nothing++-- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)+-- balanceassertion =+--     try (do+--           lift (many spacenonewline)+--           string "=="+--           lift (many spacenonewline)+--           a <- amountp -- XXX should restrict to a simple amount+--           return $ Just $ Mixed [a])+--          <|> return Nothing++-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices+fixedlotpricep :: ErroringJournalParser (Maybe Amount)+fixedlotpricep =+    try (do+          lift (many spacenonewline)+          char '{'+          lift (many spacenonewline)+          char '='+          lift (many spacenonewline)+          a <- amountp -- XXX should restrict to a simple amount+          lift (many spacenonewline)+          char '}'+          return $ Just a)+         <|> return Nothing++-- | Parse a string representation of a number for its value and display+-- attributes.+--+-- Some international number formats are accepted, eg either period or comma+-- may be used for the decimal point, and the other of these may be used for+-- separating digit groups in the integer part. See+-- http://en.wikipedia.org/wiki/Decimal_separator for more examples.+--+-- This returns: the parsed numeric value, the precision (number of digits+-- seen following the decimal point), the decimal point character used if any,+-- and the digit group style if any.+--+numberp :: TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)+numberp = do+  -- a number is an optional sign followed by a sequence of digits possibly+  -- interspersed with periods, commas, or both+  -- ptrace "numberp"+  sign <- signp+  parts <- some $ choice' [some digitChar, some $ char ',', some $ char '.']+  dbg8 "numberp parsed" (sign,parts) `seq` return ()++  -- check the number is well-formed and identify the decimal point and digit+  -- group separator characters used, if any+  let (numparts, puncparts) = partition numeric parts+      (ok, mdecimalpoint, mseparator) =+          case (numparts, puncparts) of+            ([],_)     -> (False, Nothing, Nothing)  -- no digits, not ok+            (_,[])     -> (True, Nothing, Nothing)   -- digits with no punctuation, ok+            (_,[[d]])  -> (True, Just d, Nothing)    -- just a single punctuation of length 1, assume it's a decimal point+            (_,[_])    -> (False, Nothing, Nothing)  -- a single punctuation of some other length, not ok+            (_,_:_:_)  ->                                       -- two or more punctuations+              let (s:ss, d) = (init puncparts, last puncparts)  -- the leftmost is a separator and the rightmost may be a decimal point+              in if any ((/=1).length) puncparts               -- adjacent punctuation chars, not ok+                    || any (s/=) ss                            -- separator chars vary, not ok+                    || head parts == s                        -- number begins with a separator char, not ok+                 then (False, Nothing, Nothing)+                 else if s == d+                      then (True, Nothing, Just $ head s)       -- just one kind of punctuation - must be separators+                      else (True, Just $ head d, Just $ head s) -- separator(s) and a decimal point+  unless ok $ fail $ "number seems ill-formed: "++concat parts++  -- get the digit group sizes and digit group style if any+  let (intparts',fracparts') = span ((/= mdecimalpoint) . Just . head) parts+      (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')+      groupsizes = reverse $ case map length intparts of+                               (a:b:cs) | a < b -> b:cs+                               gs               -> gs+      mgrps = (`DigitGroups` groupsizes) <$> mseparator++  -- put the parts back together without digit group separators, get the precision and parse the value+  let int = concat $ "":intparts+      frac = concat $ "":fracpart+      precision = length frac+      int' = if null int then "0" else int+      frac' = if null frac then "0" else frac+      quantity = read $ sign++int'++"."++frac' -- this read should never fail++  return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps)+  <?> "numberp"+  where+    numeric = isNumber . headDef '_'++-- 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 :: ErroringJournalParser ()+multilinecommentp = do+  string "comment" >> lift (many spacenonewline) >> newline+  go+  where+    go = try (eof <|> (string "end comment" >> newline >> return ()))+         <|> (anyLine >> go)+    anyLine = anyChar `manyTill` newline++emptyorcommentlinep :: ErroringJournalParser ()+emptyorcommentlinep = do+  lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))+  return ()++-- | Parse a possibly multi-line comment following a semicolon.+followingcommentp :: ErroringJournalParser Text+followingcommentp =+  -- ptrace "followingcommentp"+  do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))+     newlinecomments <- many (try (lift (some spacenonewline) >> semicoloncommentp))+     return $ T.unlines $ samelinecomment:newlinecomments++-- | Parse a possibly multi-line comment following a semicolon, and+-- any tags and/or posting dates within it. Posting dates can be+-- expressed with "date"/"date2" tags and/or bracketed dates.  The+-- dates are parsed in full here so that errors are reported in the+-- right position. Missing years can be inferred if a default date is+-- provided.+--+-- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; a:b, date:3/4, [=5/6]"+-- Right ("a:b, date:3/4, [=5/6]\n",[("a","b"),("date","3/4")],Just 2000-03-04,Just 2000-05-06)+--+-- Year unspecified and no default provided -> unknown year error, at correct position:+-- >>> rejp (followingcommentandtagsp Nothing) "  ;    xxx   date:3/4\n  ; second line"+-- Left ...1:22...partial date 3/4 found, but the current year is unknown...+--+-- Date tag value contains trailing text - forgot the comma, confused:+-- the syntaxes ?  We'll accept the leading date anyway+-- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; date:3/4=5/6"+-- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)+--+followingcommentandtagsp :: Maybe Day -> ErroringJournalParser (Text, [Tag], Maybe Day, Maybe Day)+followingcommentandtagsp mdefdate = do+  -- pdbg 0 "followingcommentandtagsp"++  -- Parse a single or multi-line comment, starting on this line or the next one.+  -- Save the starting position and preserve all whitespace for the subsequent re-parsing,+  -- to get good error positions.+  startpos <- getPosition+  commentandwhitespace :: String <- do+    let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof+    sp1 <- lift (many spacenonewline)+    l1  <- try (lift semicoloncommentp') <|> (newline >> return "")+    ls  <- lift . many $ try ((++) <$> some spacenonewline <*> semicoloncommentp')+    return $ unlines $ (sp1 ++ l1) : ls+  let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace+  -- pdbg 0 $ "commentws:"++show commentandwhitespace+  -- pdbg 0 $ "comment:"++show comment++  -- Reparse the comment for any tags.+  tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of+            Right ts -> return ts+            Left e   -> throwError $ parseErrorPretty e+  -- pdbg 0 $ "tags: "++show tags++  -- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.+  epdates <- liftIO $ rejp (setPosition startpos >> postingdatesp mdefdate) $ T.pack commentandwhitespace+  pdates <- case epdates of+              Right ds -> return ds+              Left e   -> throwError e+  -- pdbg 0 $ "pdates: "++show pdates+  let mdate  = headMay $ map snd $ filter ((=="date").fst)  pdates+      mdate2 = headMay $ map snd $ filter ((=="date2").fst) pdates++  return (comment, tags, mdate, mdate2)++commentp :: ErroringJournalParser Text+commentp = commentStartingWithp commentchars++commentchars :: [Char]+commentchars = "#;*"++semicoloncommentp :: ErroringJournalParser Text+semicoloncommentp = commentStartingWithp ";"++commentStartingWithp :: [Char] -> ErroringJournalParser Text+commentStartingWithp cs = do+  -- ptrace "commentStartingWith"+  oneOf cs+  lift (many spacenonewline)+  l <- anyChar `manyTill` (lift eolof)+  optional newline+  return $ T.pack l++--- ** tags++-- | Extract any tags (name:value ended by comma or newline) embedded in a string.+--+-- >>> commentTags "a b:, c:c d:d, e"+-- [("b",""),("c","c d:d")]+--+-- >>> commentTags "a [1/1/1] [1/1] [1], [=1/1/1] [=1/1] [=1] [1/1=1/1/1] [1=1/1/1] b:c"+-- [("b","c")]+--+-- --[("date","1/1/1"),("date","1/1"),("date2","1/1/1"),("date2","1/1"),("date","1/1"),("date2","1/1/1"),("date","1"),("date2","1/1/1")]+--+-- >>> commentTags "\na b:, \nd:e, f"+-- [("b",""),("d","e")]+--+commentTags :: Text -> [Tag]+commentTags s =+  case runTextParser tagsp s of+    Right r -> r+    Left _  -> [] -- shouldn't happen++-- | Parse all tags found in a string.+tagsp :: Parser [Tag]+tagsp = -- do+  -- pdbg 0 $ "tagsp"+  many (try (nontagp >> tagp))++-- | Parse everything up till the first tag.+--+-- >>> rtp nontagp "\na b:, \nd:e, f"+-- Right "\na "+nontagp :: Parser String+nontagp = -- do+  -- pdbg 0 "nontagp"+  -- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))+  anyChar `manyTill` lookAhead (try (void tagp) <|> eof)+  -- XXX costly ?++-- | Tags begin with a colon-suffixed tag name (a word beginning with+-- a letter) and are followed by a tag value (any text up to a comma+-- or newline, whitespace-stripped).+--+-- >>> rtp tagp "a:b b , c AuxDate: 4/2"+-- Right ("a","b b")+--+tagp :: Parser Tag+tagp = do+  -- pdbg 0 "tagp"+  n <- tagnamep+  v <- tagvaluep+  return (n,v)++-- |+-- >>> rtp tagnamep "a:"+-- Right "a"+tagnamep :: Parser Text+tagnamep = -- do+  -- pdbg 0 "tagnamep"+  T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':'++tagvaluep :: TextParser m Text+tagvaluep = do+  -- ptrace "tagvalue"+  v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)+  return $ T.pack $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v++--- ** posting dates++-- | Parse all posting dates found in a string. Posting dates can be+-- expressed with date/date2 tags and/or bracketed dates.  The dates+-- are parsed fully to give useful errors. Missing years can be+-- inferred only if a default date is provided.+--+postingdatesp :: Maybe Day -> ErroringJournalParser [(TagName,Day)]+postingdatesp mdefdate = do+  -- pdbg 0 $ "postingdatesp"+  let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate+      nonp =+         many (notFollowedBy p >> anyChar)+         -- anyChar `manyTill` (lookAhead (try (p >> return ()) <|> eof))+  concat <$> many (try (nonp >> p))++--- ** date tags++-- | Date tags are tags with name "date" or "date2". Their value is+-- parsed as a date, using the provided default date if any for+-- inferring a missing year if needed. Any error in date parsing is+-- reported and terminates parsing.+--+-- >>> rejp (datetagp Nothing) "date: 2000/1/2 "+-- Right ("date",2000-01-02)+--+-- >>> rejp (datetagp (Just $ fromGregorian 2001 2 3)) "date2:3/4"+-- Right ("date2",2001-03-04)+--+-- >>> rejp (datetagp Nothing) "date:  3/4"+-- Left ...1:9...partial date 3/4 found, but the current year is unknown...+--+datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day)+datetagp mdefdate = do+  -- pdbg 0 "datetagp"+  string "date"+  n <- T.pack . fromMaybe "" <$> optional (string "2")+  char ':'+  startpos <- getPosition+  v <- lift tagvaluep+  -- re-parse value as a date.+  j <- get+  let ep :: Either (ParseError Char Dec) Day+      ep = parseWithState'+             j{jparsedefaultyear=first3.toGregorian <$> mdefdate}+             -- The value extends to a comma, newline, or end of file.+             -- It seems like ignoring any extra stuff following a date+             -- gives better errors here.+             (do+                 setPosition startpos+                 datep) -- <* eof)+             v+  case ep+    of Left e  -> throwError $ parseErrorPretty e+       Right d -> return ("date"<>n, d)++--- ** bracketed dates++-- tagorbracketeddatetagsp :: Monad m => Maybe Day -> TextParser u m [Tag]+-- tagorbracketeddatetagsp mdefdate =+--   bracketeddatetagsp mdefdate <|> ((:[]) <$> tagp)++-- | Parse Ledger-style bracketed posting dates ([DATE=DATE2]), as+-- "date" and/or "date2" tags. Anything that looks like an attempt at+-- this (a square-bracketed sequence of 0123456789/-.= containing at+-- least one digit and one date separator) is also parsed, and will+-- throw an appropriate error.+--+-- The dates are parsed in full here so that errors are reported in+-- the right position. A missing year in DATE can be inferred if a+-- default date is provided. A missing year in DATE2 will be inferred+-- from DATE.+--+-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"+-- Right [("date",2016-01-02),("date2",2016-03-04)]+--+-- >>> rejp (bracketeddatetagsp Nothing) "[1]"+-- Left ...not a bracketed date...+--+-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]"+-- Left ...1:11:...bad date: 2016/1/32...+--+-- >>> rejp (bracketeddatetagsp Nothing) "[1/31]"+-- Left ...1:6:...partial date 1/31 found, but the current year is unknown...+--+-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"+-- Left ...1:15:...bad date, different separators...+--+bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]+bracketeddatetagsp mdefdate = do+  -- pdbg 0 "bracketeddatetagsp"+  char '['+  startpos <- getPosition+  let digits = "0123456789"+  s <- some (oneOf $ '=':digits++datesepchars)+  char ']'+  unless (any (`elem` s) digits && any (`elem` datesepchars) s) $+    fail "not a bracketed date"++  -- looks sufficiently like a bracketed date, now we+  -- re-parse as dates and throw any errors+  j <- get+  let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day)+      ep = parseWithState'+             j{jparsedefaultyear=first3.toGregorian <$> mdefdate}+             (do+               setPosition startpos+               md1 <- optional datep+               maybe (return ()) (setYear.first3.toGregorian) md1+               md2 <- optional $ char '=' >> datep+               eof+               return (md1,md2)+             )+             (T.pack s)+  case ep+    of Left e          -> throwError $ parseErrorPretty e+       Right (md1,md2) -> return $ catMaybes+         [("date",) <$> md1, ("date2",) <$> md2]+

@@ -6,6 +6,11 @@ -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}  module Hledger.Read.CsvReader (   -- * Reader@@ -25,11 +30,15 @@ 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.List.Compat import Data.Maybe import Data.Ord+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T import Data.Time.Calendar (Day) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (parseTimeM, defaultTimeLocale)@@ -41,17 +50,17 @@ import System.Directory (doesFileExist) import System.FilePath import System.IO (stderr)-import Test.HUnit+import Test.HUnit hiding (State) import Text.CSV (parseCSV, CSV)-import Text.Parsec hiding (parse)-import Text.Parsec.Pos-import Text.Parsec.Error+import Text.Megaparsec hiding (parse, State)+import Text.Megaparsec.Text+import qualified Text.Parsec as Parsec import Text.Printf (hPrintf,printf)  import Hledger.Data import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils-import Hledger.Read.JournalReader (amountp, statusp, genericSourcePos)+import Hledger.Read.Common (amountp, statusp, genericSourcePos)   reader :: Reader@@ -61,18 +70,19 @@ format = "csv"  -- | Does the given file path and data look like it might be CSV ?-detect :: FilePath -> String -> Bool-detect f s+detect :: FilePath -> Text -> Bool+detect f t   | f /= "-"  = takeExtension f == '.':format  -- from a file: yes if the extension is .csv-  | otherwise = length (filter (==',') s) >= 2 -- from stdin: yes if there are two or more commas+  | otherwise = T.length (T.filter (==',') t) >= 2 -- from stdin: yes if there are two or more commas  -- | Parse and post-process a "Journal" from CSV data, or give an error. -- XXX currently ignores the string and reads from the file path-parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal-parse rulesfile _ f s = do-  r <- liftIO $ readJournalFromCsv rulesfile f s+parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal+parse rulesfile _ f t = do+  r <- liftIO $ readJournalFromCsv rulesfile f t   case r of Left e -> throwError e-            Right j -> return j+            Right j -> return $ journalNumberAndTieTransactions j+-- XXX does not use parseAndFinaliseJournal like the other readers  -- | Read a Journal from the given CSV data (and filename, used for error -- messages), or return an error. Proceed as follows:@@ -85,7 +95,7 @@ -- 4. parse the rules file -- 5. convert the CSV records to a journal using the rules -- @-readJournalFromCsv :: Maybe FilePath -> FilePath -> String -> IO (Either String 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 =  handle (\e -> return $ Left $ show (e :: IOException)) $ do@@ -100,7 +110,7 @@   rules_ <- liftIO $ runExceptT $ parseRulesFile rulesfile   let rules = case rules_ of               Right (t::CsvRules) -> t-              Left err -> throwerr $ show err+              Left err -> throwerr err   dbg2IO "rules" rules    -- apply skip directive@@ -115,7 +125,7 @@   records <- (either throwerr id .               dbg2 "validateCsv" . validateCsv skip .               dbg2 "parseCsv")-             `fmap` parseCsv parsecfilename csvdata+             `fmap` parseCsv parsecfilename (T.unpack csvdata)   dbg1IO "first 3 csv records" $ take 3 records    -- identify header lines@@ -124,7 +134,12 @@    -- convert to transactions and return as a journal   let txns = snd $ mapAccumL-                     (\pos r -> (pos, transactionFromCsvRecord (incSourceLine pos 1) rules r))+                     (\pos r -> (pos,+                                 transactionFromCsvRecord+                                   (let SourcePos name line col =  pos in+                                    SourcePos name (unsafePos $ unPos line + 1) col)+                                   rules+                                    r))                      (initialPos parsecfilename) records    -- heuristic: if the records appear to have been in reverse date order,@@ -134,14 +149,14 @@             | otherwise = txns   return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'} -parseCsv :: FilePath -> String -> IO (Either ParseError CSV)+parseCsv :: FilePath -> String -> IO (Either Parsec.ParseError CSV) parseCsv path csvdata =   case path of     "-" -> liftM (parseCSV "(stdin)") getContents     _   -> return $ parseCSV path csvdata  -- | Return the cleaned up and validated CSV data, or an error.-validateCsv :: Int -> Either ParseError CSV -> Either String [CsvRecord]+validateCsv :: Int -> Either Parsec.ParseError CSV -> Either String [CsvRecord] validateCsv _ (Left e) = Left $ show e validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs   where@@ -296,6 +311,8 @@   rconditionalblocks :: [ConditionalBlock] } deriving (Show, Eq) +type CsvRulesParser a = StateT CsvRules Parser a+ type DirectiveName    = String type CsvFieldName     = String type CsvFieldIndex    = Int@@ -339,39 +356,42 @@ getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate getDirective directivename = lookup directivename . rdirectives +instance ShowErrorComponent String where+  showErrorComponent = id  parseRulesFile :: FilePath -> ExceptT String IO CsvRules parseRulesFile f = do   s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f))   let rules = parseCsvRules f s   case rules of-    Left e -> ExceptT $ return $ Left $ show e+    Left e -> ExceptT $ return $ Left $ parseErrorPretty e     Right r -> do                r_ <- liftIO $ runExceptT $ validateRules r                ExceptT $ case r_ of-                 Left e -> return $ Left $ show $ toParseError e+                 Left e -> return $ Left $ parseErrorPretty $ toParseError e                  Right r -> return $ Right r   where-    toParseError s = newErrorMessage (Message s) (initialPos "")+    toParseError :: forall s. Ord s => s -> ParseError Char s+    toParseError s = (mempty :: ParseError Char s) { errorCustom = S.singleton s}  -- | Pre-parse csv rules to interpolate included files, recursively. -- This is a cheap hack to avoid rewriting the existing parser.-expandIncludes :: FilePath -> String -> IO String+expandIncludes :: FilePath -> T.Text -> IO T.Text expandIncludes basedir content = do-  let (ls,rest) = break (isPrefixOf "include") $ lines content+  let (ls,rest) = break (T.isPrefixOf "include") $ T.lines content   case rest of-    [] -> return $ unlines ls-    (('i':'n':'c':'l':'u':'d':'e':f):ls') -> do-      let f'       = basedir </> dropWhile isSpace f+    [] -> return $ T.unlines ls+    ((T.stripPrefix "include" -> Just f):ls') -> do+      let f'       = basedir </> dropWhile isSpace (T.unpack f)           basedir' = takeDirectory f'-      included <- readFile f' >>= expandIncludes basedir'-      return $ unlines [unlines ls, included, unlines ls']-    ls' -> return $ unlines $ ls ++ ls'   -- should never get here+      included <- readFile' f' >>= expandIncludes basedir'+      return $ T.unlines [T.unlines ls, included, T.unlines ls']+    ls' -> return $ T.unlines $ ls ++ ls'   -- should never get here -parseCsvRules :: FilePath -> String -> Either ParseError CsvRules+parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Dec) CsvRules -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s parseCsvRules rulesfile s =-  runParser rulesp rules rulesfile s+  runParser (evalStateT rulesp rules) rulesfile s  -- | Return the validated rules, or an error. validateRules :: CsvRules -> ExceptT String IO CsvRules@@ -389,42 +409,42 @@  -- parsers -rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules+rulesp :: CsvRulesParser CsvRules rulesp = do-  many $ choice'-    [blankorcommentlinep                                                    <?> "blank or comment line"-    ,(directivep        >>= modifyState . addDirective)                     <?> "directive"-    ,(fieldnamelistp    >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"-    ,(fieldassignmentp  >>= modifyState . addAssignment)                    <?> "field assignment"-    ,(conditionalblockp >>= modifyState . addConditionalBlock)              <?> "conditional block"+  many $ choiceInState+    [blankorcommentlinep                                                <?> "blank or comment line"+    ,(directivep        >>= modify' . addDirective)                     <?> "directive"+    ,(fieldnamelistp    >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"+    ,(fieldassignmentp  >>= modify' . addAssignment)                    <?> "field assignment"+    ,(conditionalblockp >>= modify' . addConditionalBlock)              <?> "conditional block"     ]   eof-  r <- getState+  r <- get   return r{rdirectives=reverse $ rdirectives r           ,rassignments=reverse $ rassignments r           ,rconditionalblocks=reverse $ rconditionalblocks r           } -blankorcommentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-blankorcommentlinep = pdbg 3 "trying blankorcommentlinep" >> choice' [blanklinep, commentlinep]+blankorcommentlinep :: CsvRulesParser ()+blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep] -blanklinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-blanklinep = many spacenonewline >> newline >> return () <?> "blank line"+blanklinep :: CsvRulesParser ()+blanklinep = lift (many spacenonewline) >> newline >> return () <?> "blank line" -commentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-commentlinep = many spacenonewline >> commentcharp >> restofline >> return () <?> "comment line"+commentlinep :: CsvRulesParser ()+commentlinep = lift (many spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line" -commentcharp :: Stream [Char] m t => ParsecT [Char] CsvRules m Char-commentcharp = oneOf ";#*"+commentcharp :: CsvRulesParser Char+commentcharp = oneOf (";#*" :: [Char]) -directivep :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)-directivep = do-  pdbg 3 "trying directive"-  d <- choice' $ map string directives-  v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directivevalp)-       <|> (optional (char ':') >> many spacenonewline >> eolof >> return "")+directivep :: CsvRulesParser (DirectiveName, String)+directivep = (do+  lift $ pdbg 3 "trying directive"+  d <- choiceInState $ map string directives+  v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)+       <|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "")   return (d,v)-  <?> "directive"+  ) <?> "directive"  directives =   ["date-format"@@ -436,46 +456,46 @@    -- ,"base-currency"   ] -directivevalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-directivevalp = anyChar `manyTill` eolof+directivevalp :: CsvRulesParser String+directivevalp = anyChar `manyTill` lift eolof -fieldnamelistp :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]+fieldnamelistp :: CsvRulesParser [CsvFieldName] fieldnamelistp = (do-  pdbg 3 "trying fieldnamelist"+  lift $ pdbg 3 "trying fieldnamelist"   string "fields"   optional $ char ':'-  many1 spacenonewline-  let separator = many spacenonewline >> char ',' >> many spacenonewline-  f <- fromMaybe "" <$> optionMaybe fieldnamep-  fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldnamep)-  restofline+  lift (some spacenonewline)+  let separator = lift (many spacenonewline) >> char ',' >> lift (many spacenonewline)+  f <- fromMaybe "" <$> optional fieldnamep+  fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)+  lift restofline   return $ map (map toLower) $ f:fs   ) <?> "field name list" -fieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+fieldnamep :: CsvRulesParser String fieldnamep = quotedfieldnamep <|> barefieldnamep -quotedfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+quotedfieldnamep :: CsvRulesParser String quotedfieldnamep = do   char '"'-  f <- many1 $ noneOf "\"\n:;#~"+  f <- some $ noneOf ("\"\n:;#~" :: [Char])   char '"'   return f -barefieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-barefieldnamep = many1 $ noneOf " \t\n,;#~"+barefieldnamep :: CsvRulesParser String+barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char]) -fieldassignmentp :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)+fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate) fieldassignmentp = do-  pdbg 3 "trying fieldassignment"+  lift $ pdbg 3 "trying fieldassignmentp"   f <- journalfieldnamep   assignmentseparatorp   v <- fieldvalp   return (f,v)   <?> "field assignment" -journalfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-journalfieldnamep = pdbg 2 "trying journalfieldnamep" >> choice' (map string journalfieldnames)+journalfieldnamep :: CsvRulesParser String+journalfieldnamep = lift (pdbg 2 "trying journalfieldnamep") >> choiceInState (map string journalfieldnames)  journalfieldnames =   [-- pseudo fields:@@ -494,74 +514,74 @@   ,"comment"   ] -assignmentseparatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+assignmentseparatorp :: CsvRulesParser () assignmentseparatorp = do-  pdbg 3 "trying assignmentseparatorp"+  lift $ pdbg 3 "trying assignmentseparatorp"   choice [-    -- try (many spacenonewline >> oneOf ":="),-    try (many spacenonewline >> char ':'),-    space+    -- try (lift (many spacenonewline) >> oneOf ":="),+    try (lift (many spacenonewline) >> char ':'),+    spaceChar     ]-  _ <- many spacenonewline+  _ <- lift (many spacenonewline)   return () -fieldvalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+fieldvalp :: CsvRulesParser String fieldvalp = do-  pdbg 2 "trying fieldval"-  anyChar `manyTill` eolof+  lift $ pdbg 2 "trying fieldvalp"+  anyChar `manyTill` lift eolof -conditionalblockp :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock+conditionalblockp :: CsvRulesParser ConditionalBlock conditionalblockp = do-  pdbg 3 "trying conditionalblockp"-  string "if" >> many spacenonewline >> optional newline-  ms <- many1 recordmatcherp-  as <- many (many1 spacenonewline >> fieldassignmentp)+  lift $ pdbg 3 "trying conditionalblockp"+  string "if" >> lift (many spacenonewline) >> optional newline+  ms <- some recordmatcherp+  as <- many (lift (some spacenonewline) >> fieldassignmentp)   when (null as) $     fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"   return (ms, as)   <?> "conditional block" -recordmatcherp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]+recordmatcherp :: CsvRulesParser [String] recordmatcherp = do-  pdbg 2 "trying recordmatcherp"+  lift $ pdbg 2 "trying recordmatcherp"   -- pos <- currentPos-  _  <- optional (matchoperatorp >> many spacenonewline >> optional newline)+  _  <- optional (matchoperatorp >> lift (many spacenonewline) >> optional newline)   ps <- patternsp   when (null ps) $     fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"   return ps   <?> "record matcher" -matchoperatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-matchoperatorp = choice' $ map string+matchoperatorp :: CsvRulesParser String+matchoperatorp = choiceInState $ map string   ["~"   -- ,"!~"   -- ,"="   -- ,"!="   ] -patternsp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]+patternsp :: CsvRulesParser [String] patternsp = do-  pdbg 3 "trying patternsp"+  lift $ pdbg 3 "trying patternsp"   ps <- many regexp   return ps -regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+regexp :: CsvRulesParser String regexp = do-  pdbg 3 "trying regexp"+  lift $ pdbg 3 "trying regexp"   notFollowedBy matchoperatorp-  c <- nonspace-  cs <- anyChar `manyTill` eolof+  c <- lift nonspace+  cs <- anyChar `manyTill` lift eolof   return $ strip $ c:cs  -- fieldmatcher = do --   pdbg 2 "trying fieldmatcher"---   f <- fromMaybe "all" `fmap` (optionMaybe $ do+--   f <- fromMaybe "all" `fmap` (optional $ do --          f' <- fieldname---          many spacenonewline+--          lift (many spacenonewline) --          return f') --   char '~'---   many spacenonewline+--   lift (many spacenonewline) --   ps <- patterns --   let r = "(" ++ intercalate "|" ps ++ ")" --   return (f,r)@@ -605,7 +625,9 @@     status      =       case mfieldtemplate "status" of         Nothing  -> Uncleared-        Just str -> either statuserror id $ runParser (statusp <* eof) nullctx "" $ render str+        Just str -> either statuserror id .+                    runParser (statusp <* eof) "" .+                    T.pack $ render str           where             statuserror err = error' $ unlines               ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"@@ -617,7 +639,7 @@     precomment  = maybe "" render $ mfieldtemplate "precomment"     currency    = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"     amountstr   = (currency++) $ negateIfParenthesised $ getAmountStr rules record-    amount      = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) nullctx "" amountstr+    amount      = either amounterror (Mixed . (:[])) $ runParser (evalStateT (amountp <* eof) mempty) "" $ T.pack amountstr     amounterror err = error' $ unlines       ["error: could not parse \""++amountstr++"\" as an amount"       ,showRecord record@@ -638,8 +660,8 @@     defaccount2 = case isNegativeMixedAmount amount2 of                    Just True -> "income:unknown"                    _         -> "expenses:unknown"-    account1    = maybe "" render (mfieldtemplate "account1") `or` defaccount1-    account2    = maybe "" render (mfieldtemplate "account2") `or` defaccount2+    account1    = T.pack $ maybe "" render (mfieldtemplate "account1") `or` defaccount1+    account2    = T.pack $ maybe "" render (mfieldtemplate "account2") `or` defaccount2      -- build the transaction     t = nulltransaction{@@ -647,10 +669,10 @@       tdate                    = date',       tdate2                   = mdate2',       tstatus                  = status,-      tcode                    = code,-      tdescription             = description,-      tcomment                 = comment,-      tpreceding_comment_lines = precomment,+      tcode                    = T.pack code,+      tdescription             = T.pack description,+      tcomment                 = T.pack comment,+      tpreceding_comment_lines = T.pack precomment,       tpostings                =         [posting {paccount=account2, pamount=amount2, ptransaction=Just t}         ,posting {paccount=account1, pamount=amount1, ptransaction=Just t}@@ -780,20 +802,23 @@     assertParseEqual (parseCsvRules "unknown" "") rules    -- ,"convert rules parsing: accountrule" ~: do-  --    assertParseEqual (parseWithCtx rules accountrule "A\na\n") -- leading blank line required+  --    assertParseEqual (parseWithState rules accountrule "A\na\n") -- leading blank line required   --                ([("A",Nothing)], "a")    ,"convert rules parsing: trailing comments" ~: do-     assertParse (parseWithCtx rules rulesp "skip\n# \n#\n")+     assertParse (parseWithState' rules rulesp "skip\n# \n#\n")    ,"convert rules parsing: trailing blank lines" ~: do-     assertParse (parseWithCtx rules rulesp "skip\n\n  \n")+     assertParse (parseWithState' rules rulesp "skip\n\n  \n") +  ,"convert rules parsing: empty field value" ~: do+     assertParse (parseWithState' rules rulesp "account1 \nif foo\n  account2 foo\n")+   -- not supported   -- ,"convert rules parsing: no final newline" ~: do-  --    assertParse (parseWithCtx rules csvrulesfile "A\na")-  --    assertParse (parseWithCtx rules csvrulesfile "A\na\n# \n#")-  --    assertParse (parseWithCtx rules csvrulesfile "A\na\n\n  ")+  --    assertParse (parseWithState rules csvrulesfile "A\na")+  --    assertParse (parseWithState rules csvrulesfile "A\na\n# \n#")+  --    assertParse (parseWithState rules csvrulesfile "A\na\n\n  ")                   -- (rules{                  --   -- dateField=Maybe FieldPosition,

@@ -1,1201 +1,722 @@--- {-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-|--A reader for hledger's journal file format-(<http://hledger.org/MANUAL.html#the-journal-file>).  hledger's journal-format is a compatible subset of c++ ledger's-(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this-reader should handle many ledger files as well. Example:--@-2012\/3\/24 gift-    expenses:gifts  $10-    assets:cash-@---}--module Hledger.Read.JournalReader (-  -- * Reader-  reader,-  -- * Parsers used elsewhere-  parseAndFinaliseJournal,-  genericSourcePos,-  getParentAccount,-  journalp,-  directivep,-  defaultyeardirectivep,-  marketpricedirectivep,-  datetimep,-  codep,-  accountnamep,-  modifiedaccountnamep,-  postingp,-  amountp,-  amountp',-  mamountp',-  numberp,-  statusp,-  emptyorcommentlinep,-  followingcommentp,-  accountaliasp-  -- * Tests-  ,tests_Hledger_Read_JournalReader-#ifdef TESTS-  -- disabled by default, HTF not available on windows-  ,htf_thisModulesTests-  ,htf_Hledger_Read_JournalReader_importedTests-#endif-)-where-import Prelude ()-import Prelude.Compat hiding (readFile)-import qualified Control.Exception as C-import Control.Monad.Compat-import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError)-import Data.Char (isNumber)-import Data.List.Compat-import Data.List.Split (wordsBy)-import Data.Maybe-import Data.Time.Calendar-import Data.Time.LocalTime-import Safe (headDef, lastDef)-import Test.HUnit-#ifdef TESTS-import Test.Framework-import Text.Parsec.Error-#endif-import Text.Parsec hiding (parse)-import Text.Printf-import System.FilePath-import System.Time (getClockTime)--import Hledger.Data-import Hledger.Utils----- standard reader exports--reader :: Reader-reader = Reader format detect parse--format :: String-format = "journal"---- | Does the given file path and data look like it might be hledger's journal format ?-detect :: FilePath -> String -> Bool-detect f s-  | f /= "-"  = takeExtension f `elem` ['.':format, ".j"]  -- from a file: yes if the extension is .journal or .j-  -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)-  | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s---- | Parse and post-process a "Journal" from hledger's journal file--- format, or give an error.-parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal-parse _ = parseAndFinaliseJournal journalp---- parsing utils--genericSourcePos :: SourcePos -> GenericSourcePos-genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)---- | Flatten a list of JournalUpdate's (journal-transforming--- monadic actions which can do IO or raise an exception) into a--- single equivalent action.-combineJournalUpdates :: [JournalUpdate] -> JournalUpdate-combineJournalUpdates us = foldl' (flip (.)) id <$> sequence us--- XXX may be contributing to excessive stack use---- cf http://neilmitchell.blogspot.co.uk/2015/09/detecting-space-leaks.html--- $ ./devprof +RTS -K576K -xc--- *** Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace: ---   Hledger.Read.JournalReader.combineJournalUpdates.\,---   called from Hledger.Read.JournalReader.combineJournalUpdates,---   called from Hledger.Read.JournalReader.fixedlotprice,---   called from Hledger.Read.JournalReader.partialbalanceassertion,---   called from Hledger.Read.JournalReader.getDefaultCommodityAndStyle,---   called from Hledger.Read.JournalReader.priceamount,---   called from Hledger.Read.JournalReader.nosymbolamount,---   called from Hledger.Read.JournalReader.numberp,---   called from Hledger.Read.JournalReader.rightsymbolamount,---   called from Hledger.Read.JournalReader.simplecommoditysymbol,---   called from Hledger.Read.JournalReader.quotedcommoditysymbol,---   called from Hledger.Read.JournalReader.commoditysymbol,---   called from Hledger.Read.JournalReader.signp,---   called from Hledger.Read.JournalReader.leftsymbolamount,---   called from Hledger.Read.JournalReader.amountp,---   called from Hledger.Read.JournalReader.spaceandamountormissing,---   called from Hledger.Read.JournalReader.accountnamep.singlespace,---   called from Hledger.Utils.Parse.nonspace,---   called from Hledger.Read.JournalReader.accountnamep,---   called from Hledger.Read.JournalReader.getAccountAliases,---   called from Hledger.Read.JournalReader.getParentAccount,---   called from Hledger.Read.JournalReader.modifiedaccountnamep,---   called from Hledger.Read.JournalReader.postingp,---   called from Hledger.Read.JournalReader.postings,---   called from Hledger.Read.JournalReader.commentStartingWith,---   called from Hledger.Read.JournalReader.semicoloncomment,---   called from Hledger.Read.JournalReader.followingcommentp,---   called from Hledger.Read.JournalReader.descriptionp,---   called from Hledger.Read.JournalReader.codep,---   called from Hledger.Read.JournalReader.statusp,---   called from Hledger.Utils.Parse.spacenonewline,---   called from Hledger.Read.JournalReader.secondarydatep,---   called from Hledger.Data.Dates.datesepchar,---   called from Hledger.Read.JournalReader.datep,---   called from Hledger.Read.JournalReader.transaction,---   called from Hledger.Utils.Parse.choice',---   called from Hledger.Read.JournalReader.directive,---   called from Hledger.Read.JournalReader.emptyorcommentlinep,---   called from Hledger.Read.JournalReader.multilinecommentp,---   called from Hledger.Read.JournalReader.journal.journalItem,---   called from Hledger.Read.JournalReader.journal,---   called from Hledger.Read.JournalReader.parseJournalWith,---   called from Hledger.Read.readJournal.tryReaders.firstSuccessOrBestError,---   called from Hledger.Read.readJournal.tryReaders,---   called from Hledger.Read.readJournal,---   called from Main.main,---   called from Main.CAF--- Stack space overflow: current size 33568 bytes.---- | Given a JournalUpdate-generating parsec parser, file path and data string,--- parse and post-process a Journal so that it's ready to use, or give an error.-parseAndFinaliseJournal ::-  (ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext))-  -> Bool -> FilePath -> String -> ExceptT String IO Journal-parseAndFinaliseJournal parser assrt f s = do-  tc <- liftIO getClockTime-  tl <- liftIO getCurrentLocalTime-  y <- liftIO getCurrentYear-  r <- runParserT parser nullctx{ctxYear=Just y} f s-  case r of-    Right (updates,ctx) -> do-                           j <- ap updates (return nulljournal)-                           case journalFinalise tc tl f s ctx assrt j of-                             Right j'  -> return j'-                             Left estr -> throwError estr-    Left e -> throwError $ show e--setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()-setYear y = modifyState (\ctx -> ctx{ctxYear=Just y})--getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer)-getYear = liftM ctxYear getState--setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m ()-setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs})--getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle))-getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState--pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m ()-pushParentAccount parent = modifyState addParentAccount-    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }--popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()-popParentAccount = do ctx0 <- getState-                      case ctxAccount ctx0 of-                        [] -> unexpected "End of account block with no beginning"-                        (_:rest) -> setState $ ctx0 { ctxAccount = rest }--getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState--addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m ()-addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})--getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias]-getAccountAliases = liftM ctxAliases getState--clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()-clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})--getIndex :: Stream [Char] m Char => ParsecT s JournalContext m Integer-getIndex = liftM ctxTransactionIndex getState--setIndex :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()-setIndex i = modifyState (\ctx -> ctx{ctxTransactionIndex=i})---- parsers---- | Top-level journal parser. Returns a single composite, I/O performing,--- error-raising "JournalUpdate" (and final "JournalContext") which can be--- applied to an empty journal to get the final result.-journalp :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)-journalp = do-  journalupdates <- many journalItem-  eof-  finalctx <- getState-  return $ (combineJournalUpdates journalupdates, finalctx)-    where-      -- As all journal line types can be distinguished by the first-      -- character, excepting transactions versus empty (blank or-      -- comment-only) lines, can use choice w/o try-      journalItem = choice [ directivep-                           , liftM (return . addTransaction) transactionp-                           , liftM (return . addModifierTransaction) modifiertransactionp-                           , liftM (return . addPeriodicTransaction) periodictransactionp-                           , liftM (return . addMarketPrice) marketpricedirectivep-                           , emptyorcommentlinep >> return (return id)-                           , multilinecommentp >> return (return id)-                           ] <?> "journal transaction or directive"---- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives-directivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-directivep = do-  optional $ char '!'-  choice' [-    includedirectivep-   ,aliasdirectivep-   ,endaliasesdirectivep-   ,accountdirectivep-   ,enddirectivep-   ,tagdirectivep-   ,endtagdirectivep-   ,defaultyeardirectivep-   ,defaultcommoditydirectivep-   ,commodityconversiondirectivep-   ,ignoredpricecommoditydirectivep-   ]-  <?> "directive"--includedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-includedirectivep = do-  string "include"-  many1 spacenonewline-  filename <- restofline-  outerState <- getState-  outerPos <- getPosition-  let curdir = takeDirectory (sourceName outerPos)-  let (u::ExceptT String IO (Journal -> Journal, JournalContext)) = do-       filepath <- expandPath curdir filename-       txt <- readFileOrError outerPos filepath-       let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-       r <- runParserT journalp outerState filepath txt-       case r of-         Right (ju, ctx) -> do-                            u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)-                                                       , ju-                                                       ] `catchError` (throwError . (inIncluded ++))-                            return (u, ctx)-         Left err -> throwError $ inIncluded ++ show err-       where readFileOrError pos fp =-                ExceptT $ liftM Right (readFile' fp) `C.catch`-                  \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))-  r <- liftIO $ runExceptT u-  case r of-    Left err -> return $ throwError err-    Right (ju, _finalparsectx) -> return $ ExceptT $ return $ Right ju--journalAddFile :: (FilePath,String) -> Journal -> Journal-journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}- -- NOTE: first encountered file to left, to avoid a reverse--accountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-accountdirectivep = do-  string "account"-  many1 spacenonewline-  parent <- accountnamep-  newline-  pushParentAccount parent-  -- return $ return id-  return $ ExceptT $ return $ Right id--enddirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-enddirectivep = do-  string "end"-  popParentAccount-  -- return (return id)-  return $ ExceptT $ return $ Right id--aliasdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-aliasdirectivep = do-  string "alias"-  many1 spacenonewline-  alias <- accountaliasp-  addAccountAlias alias-  return $ return id--accountaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias-accountaliasp = regexaliasp <|> basicaliasp--basicaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias-basicaliasp = do-  -- pdbg 0 "basicaliasp"-  old <- rstrip <$> (many1 $ noneOf "=")-  char '='-  many spacenonewline-  new <- rstrip <$> anyChar `manyTill` eolof  -- don't require a final newline, good for cli options-  return $ BasicAlias old new--regexaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias-regexaliasp = do-  -- pdbg 0 "regexaliasp"-  char '/'-  re <- many1 $ noneOf "/\n\r" -- paranoid: don't try to read past line end-  char '/'-  many spacenonewline-  char '='-  many spacenonewline-  repl <- rstrip <$> anyChar `manyTill` eolof-  return $ RegexAlias re repl--endaliasesdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-endaliasesdirectivep = do-  string "end aliases"-  clearAccountAliases-  return (return id)--tagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-tagdirectivep = do-  string "tag" <?> "tag directive"-  many1 spacenonewline-  _ <- many1 nonspace-  restofline-  return $ return id--endtagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-endtagdirectivep = do-  (string "end tag" <|> string "pop") <?> "end tag or pop directive"-  restofline-  return $ return id--defaultyeardirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-defaultyeardirectivep = do-  char 'Y' <?> "default year"-  many spacenonewline-  y <- many1 digit-  let y' = read y-  failIfInvalidYear y-  setYear y'-  return $ return id--defaultcommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-defaultcommoditydirectivep = do-  char 'D' <?> "default commodity"-  many1 spacenonewline-  Amount{..} <- amountp-  setDefaultCommodityAndStyle (acommodity, astyle)-  restofline-  return $ return id--marketpricedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) MarketPrice-marketpricedirectivep = do-  char 'P' <?> "market price"-  many spacenonewline-  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored-  many1 spacenonewline-  symbol <- commoditysymbolp-  many spacenonewline-  price <- amountp-  restofline-  return $ MarketPrice date symbol price--ignoredpricecommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-ignoredpricecommoditydirectivep = do-  char 'N' <?> "ignored-price commodity"-  many1 spacenonewline-  commoditysymbolp-  restofline-  return $ return id--commodityconversiondirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-commodityconversiondirectivep = do-  char 'C' <?> "commodity conversion"-  many1 spacenonewline-  amountp-  many spacenonewline-  char '='-  many spacenonewline-  amountp-  restofline-  return $ return id--modifiertransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction-modifiertransactionp = do-  char '=' <?> "modifier transaction"-  many spacenonewline-  valueexpr <- restofline-  postings <- postingsp-  return $ ModifierTransaction valueexpr postings--periodictransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction-periodictransactionp = do-  char '~' <?> "periodic transaction"-  many spacenonewline-  periodexpr <- restofline-  postings <- postingsp-  return $ PeriodicTransaction periodexpr postings---- | Parse a (possibly unbalanced) transaction.-transactionp :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction-transactionp = do-  -- ptrace "transactionp"-  sourcepos <- genericSourcePos <$> getPosition-  date <- datep <?> "transaction"-  edate <- optionMaybe (secondarydatep date) <?> "secondary date"-  lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"-  status <- statusp <?> "cleared status"-  code <- codep <?> "transaction code"-  description <- descriptionp >>= return . strip-  comment <- try followingcommentp <|> (newline >> return "")-  let tags = tagsInComment comment-  postings <- postingsp-  i' <- (+1) <$> getIndex-  setIndex i'-  return $ txnTieKnot $ Transaction i' sourcepos date edate status code description comment tags postings ""--descriptionp = many (noneOf ";\n")--#ifdef TESTS-test_transactionp = do-    let s `gives` t = do-                        let p = parseWithCtx nullctx 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=Uncleared,-      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 $ parseWithCtx nullctx transactionp $ unlines-      ["2007/01/28 coopportunity"-      ,"    expenses:food:groceries                   $47.18"-      ,"    assets:checking                          $-47.18"-      ,""-      ]--    -- transactionp should not parse just a date-    assertLeft $ parseWithCtx nullctx transactionp "2009/1/1\n"--    -- transactionp should not parse just a date and description-    assertLeft $ parseWithCtx nullctx transactionp "2009/1/1 a\n"--    -- transactionp should not parse a following comment as part of the description-    let p = parseWithCtx nullctx 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 $ parseWithCtx nullctx transactionp $ unlines-        ["2012/1/1"-        ,"  a  1"-        ,"  b"-        ," "-        ]--    let p = parseWithCtx nullctx 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---- | 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.-datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day-datep = do-  -- hacky: try to ensure precise errors for invalid dates-  -- XXX reported error position is not too good-  -- pos <- genericSourcePos <$> getPosition-  datestr <- do-    c <- digit-    cs <- many $ choice' [digit, datesepchar]-    return $ c:cs-  let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr-  when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr-  let dateparts = wordsBy (`elem` datesepchars) datestr-  currentyear <- getYear-  [y,m,d] <- case (dateparts,currentyear) of-              ([m,d],Just y)  -> return [show y,m,d]-              ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"-              ([y,m,d],_)     -> return [y,m,d]-              _               -> fail $ "bad date: " ++ datestr-  let maybedate = fromGregorianValid (read y) (read m) (read d)-  case maybedate of-    Nothing   -> fail $ "bad date: " ++ datestr-    Just date -> return date-  <?> "full or partial date"---- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.--- Hyphen (-) and period (.) are also allowed as date separators.--- The year may be omitted if a default year has been set.--- Seconds are optional.--- The timezone is optional and ignored (the time is always interpreted as a local time).--- Leading zeroes may be omitted (except in a timezone).-datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime-datetimep = do-  day <- datep-  many1 spacenonewline-  h <- many1 digit-  let h' = read h-  guard $ h' >= 0 && h' <= 23-  char ':'-  m <- many1 digit-  let m' = read m-  guard $ m' >= 0 && m' <= 59-  s <- optionMaybe $ char ':' >> many1 digit-  let s' = case s of Just sstr -> read sstr-                     Nothing   -> 0-  guard $ s' >= 0 && s' <= 59-  {- tz <- -}-  optionMaybe $ do-                   plusminus <- oneOf "-+"-                   d1 <- digit-                   d2 <- digit-                   d3 <- digit-                   d4 <- digit-                   return $ plusminus:d1:d2:d3:d4:""-  -- ltz <- liftIO $ getCurrentTimeZone-  -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz-  -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')-  return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')--secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day-secondarydatep primarydate = do-  char '='-  -- kludgy way to use primary date for default year-  let withDefaultYear d p = do-        y <- getYear-        let (y',_,_) = toGregorian d in setYear y'-        r <- p-        when (isJust y) $ setYear $ fromJust y-        return r-  edate <- withDefaultYear primarydate datep-  return edate--statusp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ClearedStatus-statusp =-  choice'-    [ many spacenonewline >> char '*' >> return Cleared-    , many spacenonewline >> char '!' >> return Pending-    , return Uncleared-    ]-    <?> "cleared status"--codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""---- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments.-postingsp :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting]-postingsp = many (try postingp) <?> "postings"---- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String--- linebeginningwithspaces = do---   sp <- many1 spacenonewline---   c <- nonspace---   cs <- restofline---   return $ sp ++ (c:cs) ++ "\n"--postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting-postingp = do-  many1 spacenonewline-  status <- statusp-  many spacenonewline-  account <- modifiedaccountnamep-  let (ptype, account') = (accountNamePostingType account, unbracket account)-  amount <- spaceandamountormissingp-  massertion <- partialbalanceassertionp-  _ <- fixedlotpricep-  many spacenonewline-  ctx <- getState-  comment <- try followingcommentp <|> (newline >> return "")-  let tags = tagsInComment comment-  -- oh boy-  date <- case dateValueFromTags tags of-        Nothing -> return Nothing-        Just v -> case runParser (datep <* eof) ctx "" v of-                    Right d -> return $ Just d-                    Left err -> parserFail $ show err-  date2 <- case date2ValueFromTags tags of-        Nothing -> return Nothing-        Just v -> case runParser (datep <* eof) ctx "" v of-                    Right d -> return $ Just d-                    Left err -> parserFail $ show err-  return posting-   { pdate=date-   , pdate2=date2-   , pstatus=status-   , paccount=account'-   , pamount=amount-   , pcomment=comment-   , ptype=ptype-   , ptags=tags-   , pbalanceassertion=massertion-   }--#ifdef TESTS-test_postingp = do-    let s `gives` ep = do-                         let parse = parseWithCtx nullctx postingp s-                         assertBool -- "postingp parser"-                           $ isRight parse-                         let Right ap = parse-                             same f = assertEqual (f ep) (f ap)-                         same pdate-                         same pstatus-                         same paccount-                         same pamount-                         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")]}--    " 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"}--    " a  1 ; a:a, [=2012/11/28]\n" `gives`-      ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"-                        ,ptags=[("a","a"), ("date2","2012/11/28")]-                        ,pdate=Nothing}--    " a  1 ; a:a\n  ; [2012/11/28=2012/11/29],b:b\n" `gives`-      ("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"-                        ,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]-                        ,pdate=parsedateM "2012/11/28"}--    assertBool -- "postingp parses a quoted commodity with numbers"-      (isRight $ parseWithCtx nullctx postingp "  a  1 \"DE123\"\n")--  -- ,"postingp parses balance assertions and fixed lot prices" ~: do-    assertBool (isRight $ parseWithCtx nullctx postingp "  a  1 \"DE123\" =$1 { =2.2 EUR} \n")--    -- let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n"-    -- assertRight parse-    -- let Right p = parse-    -- assertEqual "next-line comment\n" (pcomment p)-    -- assertEqual (Just nullmixedamt) (pbalanceassertion p)-#endif---- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.-modifiedaccountnamep :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName-modifiedaccountnamep = do-  parent <- getParentAccount-  aliases <- getAccountAliases-  a <- accountnamep-  return $-    accountNameApplyAliases aliases $-     -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference-    joinAccountNames parent-    a---- | Parse an account name. Account names start with a non-space, may--- have single spaces inside them, 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 char.--- (This parser will also consume one following space, if present.)-accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName-accountnamep = do-    a <- do-      c <- nonspace-      cs <- striptrailingspace <$> many (nonspace <|> singlespace)-      return $ c:cs-    when (accountNameFromComponents (accountNameComponents a) /= a)-         (fail $ "account name seems ill-formed: "++a)-    return a-    where-      singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})-      striptrailingspace "" = ""-      striptrailingspace s  = if last s == ' ' then init s else s---- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace---     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"---- | Parse whitespace then an amount, with an optional left or right--- currency symbol and optional price, or return the special--- "missing" marker amount.-spaceandamountormissingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount-spaceandamountormissingp =-  try (do-        many1 spacenonewline-        (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt-      ) <|> return missingmixedamt--#ifdef TESTS-assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion-assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse--is' :: (Eq a, Show a) => a -> a -> Assertion-a `is'` e = assertEqual e a--test_spaceandamountormissingp = do-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp " $47.18") (Mixed [usd 47.18])-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp "$47.18") missingmixedamt-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissingp " ") missingmixedamt-    assertParseEqual' (parseWithCtx nullctx 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.-amountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp--#ifdef TESTS-test_amountp = do-    assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18)-    assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0)-  -- ,"amount with unit price" ~: do-    assertParseEqual'-     (parseWithCtx nullctx amountp "$10 @ €0.5")-     (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))-  -- ,"amount with total price" ~: do-    assertParseEqual'-     (parseWithCtx nullctx amountp "$10 @@ €5")-     (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))-#endif---- | Parse an amount from a string, or get an error.-amountp' :: String -> Amount-amountp' s =-  case runParser (amountp <* eof) nullctx "" s of-    Right t -> t-    Left err -> error' $ show err---- | Parse a mixed amount from a string, or get an error.-mamountp' :: String -> MixedAmount-mamountp' = Mixed . (:[]) . amountp'--signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String-signp = do-  sign <- optionMaybe $ oneOf "+-"-  return $ case sign of Just '-' -> "-"-                        _        -> ""--leftsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-leftsymbolamountp = do-  sign <- signp-  c <- commoditysymbolp-  sp <- many spacenonewline-  (q,prec,mdec,mgrps) <- numberp-  let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}-  p <- priceamountp-  let applysign = if sign=="-" then negate else id-  return $ applysign $ Amount c q p s-  <?> "left-symbol amount"--rightsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-rightsymbolamountp = do-  (q,prec,mdec,mgrps) <- numberp-  sp <- many spacenonewline-  c <- commoditysymbolp-  p <- priceamountp-  let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}-  return $ Amount c q p s-  <?> "right-symbol amount"--nosymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-nosymbolamountp = do-  (q,prec,mdec,mgrps) <- numberp-  p <- priceamountp-  -- apply the most recently seen default commodity and style to this commodityless amount-  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})-  return $ Amount c q p s-  <?> "no-symbol amount"--commoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String-commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"--quotedcommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String-quotedcommoditysymbolp = do-  char '"'-  s <- many1 $ noneOf ";\n\""-  char '"'-  return s--simplecommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String-simplecommoditysymbolp = many1 (noneOf nonsimplecommoditychars)--priceamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Price-priceamountp =-    try (do-          many spacenonewline-          char '@'-          try (do-                char '@'-                many spacenonewline-                a <- amountp -- XXX can parse more prices ad infinitum, shouldn't-                return $ TotalPrice a)-           <|> (do-            many spacenonewline-            a <- amountp -- XXX can parse more prices ad infinitum, shouldn't-            return $ UnitPrice a))-         <|> return NoPrice--partialbalanceassertionp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)-partialbalanceassertionp =-    try (do-          many spacenonewline-          char '='-          many spacenonewline-          a <- amountp -- XXX should restrict to a simple amount-          return $ Just $ Mixed [a])-         <|> return Nothing---- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount)--- balanceassertion =---     try (do---           many spacenonewline---           string "=="---           many spacenonewline---           a <- amountp -- XXX should restrict to a simple amount---           return $ Just $ Mixed [a])---          <|> return Nothing---- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices-fixedlotpricep :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount)-fixedlotpricep =-    try (do-          many spacenonewline-          char '{'-          many spacenonewline-          char '='-          many spacenonewline-          a <- amountp -- XXX should restrict to a simple amount-          many spacenonewline-          char '}'-          return $ Just a)-         <|> return Nothing---- | Parse a string representation of a number for its value and display--- attributes.------ Some international number formats are accepted, eg either period or comma--- may be used for the decimal point, and the other of these may be used for--- separating digit groups in the integer part. See--- http://en.wikipedia.org/wiki/Decimal_separator for more examples.------ This returns: the parsed numeric value, the precision (number of digits--- seen following the decimal point), the decimal point character used if any,--- and the digit group style if any.----numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)-numberp = do-  -- a number is an optional sign followed by a sequence of digits possibly-  -- interspersed with periods, commas, or both-  -- ptrace "numberp"-  sign <- signp-  parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']-  dbg8 "numberp parsed" (sign,parts) `seq` return ()--  -- check the number is well-formed and identify the decimal point and digit-  -- group separator characters used, if any-  let (numparts, puncparts) = partition numeric parts-      (ok, mdecimalpoint, mseparator) =-          case (numparts, puncparts) of-            ([],_)     -> (False, Nothing, Nothing)  -- no digits, not ok-            (_,[])     -> (True, Nothing, Nothing)   -- digits with no punctuation, ok-            (_,[[d]])  -> (True, Just d, Nothing)    -- just a single punctuation of length 1, assume it's a decimal point-            (_,[_])    -> (False, Nothing, Nothing)  -- a single punctuation of some other length, not ok-            (_,_:_:_)  ->                                       -- two or more punctuations-              let (s:ss, d) = (init puncparts, last puncparts)  -- the leftmost is a separator and the rightmost may be a decimal point-              in if (any ((/=1).length) puncparts               -- adjacent punctuation chars, not ok-                     || any (s/=) ss                            -- separator chars vary, not ok-                     || head parts == s)                        -- number begins with a separator char, not ok-                 then (False, Nothing, Nothing)-                 else if s == d-                      then (True, Nothing, Just $ head s)       -- just one kind of punctuation - must be separators-                      else (True, Just $ head d, Just $ head s) -- separator(s) and a decimal point-  when (not ok) (fail $ "number seems ill-formed: "++concat parts)--  -- get the digit group sizes and digit group style if any-  let (intparts',fracparts') = span ((/= mdecimalpoint) . Just . head) parts-      (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')-      groupsizes = reverse $ case map length intparts of-                               (a:b:cs) | a < b -> b:cs-                               gs               -> gs-      mgrps = maybe Nothing (Just . (`DigitGroups` groupsizes)) $ mseparator--  -- put the parts back together without digit group separators, get the precision and parse the value-  let int = concat $ "":intparts-      frac = concat $ "":fracpart-      precision = length frac-      int' = if null int then "0" else int-      frac' = if null frac then "0" else frac-      quantity = read $ sign++int'++"."++frac' -- this read should never fail--  return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps)-  <?> "numberp"-  where-    numeric = isNumber . headDef '_'---- test_numberp = do---       let s `is` n = assertParseEqual (parseWithCtx nullctx numberp s) n---           assertFails = assertBool . isLeft . parseWithCtx nullctx 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."---- comment parsers--multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()-multilinecommentp = do-  string "comment" >> many spacenonewline >> newline-  go-  where-    go = try (eof <|> (string "end comment" >> newline >> return ()))-         <|> (anyLine >> go)-    anyLine = anyChar `manyTill` newline--emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()-emptyorcommentlinep = do-  many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return ""))-  return ()--followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-followingcommentp =-  -- ptrace "followingcommentp"-  do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))-     newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))-     return $ unlines $ samelinecomment:newlinecomments--commentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-commentp = commentStartingWithp commentchars--commentchars :: [Char]-commentchars = "#;*"--semicoloncommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-semicoloncommentp = commentStartingWithp ";"--commentStartingWithp :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String-commentStartingWithp cs = do-  -- ptrace "commentStartingWith"-  oneOf cs-  many spacenonewline-  l <- anyChar `manyTill` eolof-  optional newline-  return l--tagsInComment :: String -> [Tag]-tagsInComment c = concatMap tagsInCommentLine $ lines c'-  where-    c' = ledgerDateSyntaxToTags c--tagsInCommentLine :: String -> [Tag]-tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','-  where-    maybetag s = case runParser (tagp <* eof) nullctx "" s of-                  Right t -> Just t-                  Left _ -> Nothing--tagp = do-  -- ptrace "tag"-  n <- tagnamep-  v <- tagvaluep-  return (n,v)--tagnamep = do-  -- ptrace "tagname"-  n <- many1 $ noneOf ": \t"-  char ':'-  return n--tagvaluep = do-  -- ptrace "tagvalue"-  v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)-  return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v--ledgerDateSyntaxToTags :: String -> String-ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace-  where-    replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s-    replace s = s--    replace' s | isdate s = datetag s-    replace' ('=':s) | isdate s = date2tag s-    replace' s | last s =='=' && isdate (init s) = datetag (init s)-    replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2-      where-        ds = splitAtElement '=' s-        d1 = headDef "" ds-        d2 = lastDef "" ds-    replace' s = s--    isdate = isJust . parsedateM-    datetag s = "date:"++s++", "-    date2tag s = "date2:"++s++", "--#ifdef TESTS-test_ledgerDateSyntaxToTags = do-     assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]"-#endif--dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String-dateValueFromTags  ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts-date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts---tests_Hledger_Read_JournalReader = TestList $ concat [-    -- test_numberp- ]--{- old hunit tests--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 (parseWithCtx nullctx modifiertransactionp "= (some value expr)\n some:postings  1\n")--  ,"periodictransactionp" ~: do-     assertParse (parseWithCtx nullctx periodictransactionp "~ (some period expr)\n some:postings  1\n")--  ,"directivep" ~: do-     assertParse (parseWithCtx nullctx directivep "!include /some/file.x\n")-     assertParse (parseWithCtx nullctx directivep "account some:account\n")-     assertParse (parseWithCtx nullctx (directivep >> directivep) "!account a\nend\n")--  ,"comment" ~: do-     assertParse (parseWithCtx nullctx comment "; some comment \n")-     assertParse (parseWithCtx nullctx comment " \t; x\n")-     assertParse (parseWithCtx nullctx comment "#x")--  ,"datep" ~: do-     assertParse (parseWithCtx nullctx datep "2011/1/1")-     assertParseFailure (parseWithCtx nullctx datep "1/1")-     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} datep "1/1")--  ,"datetimep" ~: do-      let p = do {t <- datetimep; eof; return t}-          bad = assertParseFailure . parseWithCtx nullctx p-          good = assertParse . parseWithCtx nullctx 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 (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday-      assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday--  ,"defaultyeardirectivep" ~: do-     assertParse (parseWithCtx nullctx defaultyeardirectivep "Y 2010\n")-     assertParse (parseWithCtx nullctx defaultyeardirectivep "Y 10001\n")--  ,"marketpricedirectivep" ~:-    assertParseEqual (parseWithCtx nullctx marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55)--  ,"ignoredpricecommoditydirectivep" ~: do-     assertParse (parseWithCtx nullctx ignoredpricecommoditydirectivep "N $\n")--  ,"defaultcommoditydirectivep" ~: do-     assertParse (parseWithCtx nullctx defaultcommoditydirectivep "D $1,000.0\n")--  ,"commodityconversiondirectivep" ~: do-     assertParse (parseWithCtx nullctx commodityconversiondirectivep "C 1h = $50.00\n")--  ,"tagdirectivep" ~: do-     assertParse (parseWithCtx nullctx tagdirectivep "tag foo \n")--  ,"endtagdirectivep" ~: do-     assertParse (parseWithCtx nullctx endtagdirectivep "end tag \n")-     assertParse (parseWithCtx nullctx endtagdirectivep "pop \n")--  ,"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:")--  ,"leftsymbolamountp" ~: do-    assertParseEqual (parseWithCtx nullctx leftsymbolamountp "$1")  (usd 1 `withPrecision` 0)-    assertParseEqual (parseWithCtx nullctx leftsymbolamountp "$-1") (usd (-1) `withPrecision` 0)-    assertParseEqual (parseWithCtx nullctx leftsymbolamountp "-$1") (usd (-1) `withPrecision` 0)--  ,"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 (parseWithCtx nullctx amountp "1 @ $2")-       (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0))-- ]]--}-+--- * doc+-- Lines beginning "--- *" are collapsible orgstruct nodes. Emacs users,+-- (add-hook 'haskell-mode-hook+--   (lambda () (set-variable 'orgstruct-heading-prefix-regexp "--- " t))+--   'orgstruct-mode)+-- and press TAB on nodes to expand/collapse.++{-|++A reader for hledger's journal file format+(<http://hledger.org/MANUAL.html#the-journal-file>).  hledger's journal+format is a compatible subset of c++ ledger's+(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this+reader should handle many ledger files as well. Example:++@+2012\/3\/24 gift+    expenses:gifts  $10+    assets:cash+@++Journal format supports the include directive which can read files in+other formats, so the other file format readers need to be importable+here.  Some low-level journal syntax parsers which those readers also+use are therefore defined separately in Hledger.Read.Common, avoiding+import cycles.++-}++--- * module++{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections, OverloadedStrings #-}++module Hledger.Read.JournalReader (+--- * exports++  -- * Reader+  reader,++  -- * Parsing utils+  genericSourcePos,+  parseAndFinaliseJournal,+  runJournalParser,+  rjp,+  runErroringJournalParser,+  rejp,++  -- * Parsers used elsewhere+  getParentAccount,+  journalp,+  directivep,+  defaultyeardirectivep,+  marketpricedirectivep,+  datetimep,+  datep,+  -- codep,+  -- accountnamep,+  modifiedaccountnamep,+  postingp,+  -- amountp,+  -- amountp',+  -- mamountp',+  -- numberp,+  statusp,+  emptyorcommentlinep,+  followingcommentp,+  accountaliasp++  -- * Tests+  ,tests_Hledger_Read_JournalReader++)+where+--- * imports+import Prelude ()+import Prelude.Compat hiding (readFile)+import qualified Control.Exception as C+import Control.Monad+import Control.Monad.Except (ExceptT(..), runExceptT, throwError)+import Control.Monad.State.Strict+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+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.Printf+import System.FilePath++import Hledger.Data+import Hledger.Read.Common+import Hledger.Read.TimeclockReader (timeclockfilep)+import Hledger.Read.TimedotReader (timedotfilep)+import Hledger.Utils++-- $setup+-- >>> :set -XOverloadedStrings++--- * reader++reader :: Reader+reader = Reader format detect parse++format :: String+format = "journal"++-- | Does the given file path and data look like it might be hledger's journal format ?+detect :: FilePath -> Text -> Bool+detect f _t+  | f /= "-"  = takeExtension f `elem` ['.':format, ".j"] -- from a known file name: yes if the extension is this format's name or .j+  | otherwise = True                                      -- from stdin: yes, always attempt to parse stdin as journal data+  -- otherwise = regexMatches "(^|\n)[0-9]+.*\n[ \t]+" $ T.unpack t   -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)++-- | Parse and post-process a "Journal" from hledger's journal file+-- format, or give an error.+parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal+parse _ = parseAndFinaliseJournal journalp++--- * parsers+--- ** journal++-- | A journal parser. Accumulates and returns a "ParsedJournal",+-- which should be finalised/validated before use.+--+-- >>> rejp (journalp <* eof) "2015/1/1\n a  0\n"+-- Right Journal  with 1 transactions, 1 accounts+--+journalp :: ErroringJournalParser ParsedJournal+journalp = do+  many addJournalItemP+  eof+  get++-- | A side-effecting parser; parses any kind of journal item+-- and updates the parse state accordingly.+addJournalItemP :: ErroringJournalParser ()+addJournalItemP =+  -- all journal line types can be distinguished by the first+  -- character, can use choice without backtracking+  choice [+      directivep+    , transactionp          >>= modify' . addTransaction+    , modifiertransactionp  >>= modify' . addModifierTransaction+    , periodictransactionp  >>= modify' . addPeriodicTransaction+    , marketpricedirectivep >>= modify' . addMarketPrice+    , void emptyorcommentlinep+    , void multilinecommentp+    ] <?> "transaction or directive"++--- ** directives++-- | Parse any journal directive and update the parse state accordingly.+-- Cf http://hledger.org/manual.html#directives,+-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives+directivep :: ErroringJournalParser ()+directivep = (do+  optional $ char '!'+  choiceInState [+    includedirectivep+   ,aliasdirectivep+   ,endaliasesdirectivep+   ,accountdirectivep+   ,applyaccountdirectivep+   ,commoditydirectivep+   ,endapplyaccountdirectivep+   ,tagdirectivep+   ,endtagdirectivep+   ,defaultyeardirectivep+   ,defaultcommoditydirectivep+   ,commodityconversiondirectivep+   ,ignoredpricecommoditydirectivep+   ]+  ) <?> "directive"++includedirectivep :: ErroringJournalParser ()+includedirectivep = do+  string "include"+  lift (some spacenonewline)+  filename  <- lift restofline+  parentpos <- getPosition+  parentj   <- get+  let childj = newJournalWithParseStateFrom parentj+  (ej :: Either String ParsedJournal) <-+    liftIO $ runExceptT $ do+      let curdir = takeDirectory (sourceName parentpos)+      filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)+      txt      <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)+      (ej1::Either (ParseError Char Dec) ParsedJournal) <-+        runParserT+           (evalStateT+              (choiceInState+                 [journalp+                 ,timeclockfilep+                 ,timedotfilep+                 -- can't include a csv file yet, that reader is special+                 ])+              childj)+           filepath txt+      either+        (throwError+          . ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)+          . show)+        (return . journalAddFile (filepath, txt))+        ej1+  case ej of+    Left e       -> throwError e+    Right childj -> modify' (\parentj -> childj <> parentj)+    -- discard child's parse info, prepend its (reversed) list data, combine other fields++newJournalWithParseStateFrom :: Journal -> Journal+newJournalWithParseStateFrom j = mempty{+   jparsedefaultyear      = jparsedefaultyear j+  ,jparsedefaultcommodity = jparsedefaultcommodity j+  ,jparseparentaccounts   = jparseparentaccounts j+  ,jparsealiases          = jparsealiases j+  -- ,jparsetransactioncount = jparsetransactioncount j+  ,jparsetimeclockentries = jparsetimeclockentries j+  }++-- | Lift an IO action into the exception monad, rethrowing any IO+-- error with the given message prepended.+orRethrowIOError :: IO a -> String -> ExceptT String IO a+orRethrowIOError io msg =+  ExceptT $+    (Right <$> io)+    `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)++accountdirectivep :: ErroringJournalParser ()+accountdirectivep = do+  string "account"+  lift (some spacenonewline)+  acct <- lift accountnamep+  newline+  _ <- many indentedlinep+  modify' (\j -> j{jaccounts = acct : jaccounts j})++indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)++-- | Parse a one-line or multi-line commodity directive.+--+-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00"+-- >>> Right _ <- rejp commoditydirectivep "commodity $\n  format $1.00"+-- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format+-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n  format $1.00" -- both, what happens ?+commoditydirectivep :: ErroringJournalParser ()+commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep++-- | Parse a one-line commodity directive.+--+-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"+-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"+commoditydirectiveonelinep :: ErroringJournalParser ()+commoditydirectiveonelinep = do+  string "commodity"+  lift (some spacenonewline)+  Amount{acommodity,astyle} <- amountp+  lift (many spacenonewline)+  _ <- followingcommentp <|> (lift eolof >> return "")+  let comm = Commodity{csymbol=acommodity, cformat=Just astyle}+  modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})++-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.+--+-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n  format $1.00 ; blah"+commoditydirectivemultilinep :: ErroringJournalParser ()+commoditydirectivemultilinep = do+  string "commodity"+  lift (some spacenonewline)+  sym <- lift commoditysymbolp+  _ <- followingcommentp <|> (lift eolof >> return "")+  mformat <- lastMay <$> many (indented $ formatdirectivep sym)+  let comm = Commodity{csymbol=sym, cformat=mformat}+  modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})+  where+    indented = (lift (some spacenonewline) >>)++-- | Parse a format (sub)directive, throwing a parse error if its+-- symbol does not match the one given.+formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle+formatdirectivep expectedsym = do+  string "format"+  lift (some spacenonewline)+  pos <- getPosition+  Amount{acommodity,astyle} <- amountp+  _ <- followingcommentp <|> (lift eolof >> return "")+  if acommodity==expectedsym+    then return astyle+    else parserErrorAt pos $+         printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity++applyaccountdirectivep :: ErroringJournalParser ()+applyaccountdirectivep = do+  string "apply" >> lift (some spacenonewline) >> string "account"+  lift (some spacenonewline)+  parent <- lift accountnamep+  newline+  pushParentAccount parent++endapplyaccountdirectivep :: ErroringJournalParser ()+endapplyaccountdirectivep = do+  string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"+  popParentAccount++aliasdirectivep :: ErroringJournalParser ()+aliasdirectivep = do+  string "alias"+  lift (some spacenonewline)+  alias <- lift accountaliasp+  addAccountAlias alias++accountaliasp :: TextParser m AccountAlias+accountaliasp = regexaliasp <|> basicaliasp++basicaliasp :: TextParser m AccountAlias+basicaliasp = do+  -- pdbg 0 "basicaliasp"+  old <- rstrip <$> (some $ noneOf ("=" :: [Char]))+  char '='+  many spacenonewline+  new <- rstrip <$> anyChar `manyTill` eolof  -- don't require a final newline, good for cli options+  return $ BasicAlias (T.pack old) (T.pack new)++regexaliasp :: TextParser m AccountAlias+regexaliasp = do+  -- pdbg 0 "regexaliasp"+  char '/'+  re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end+  char '/'+  many spacenonewline+  char '='+  many spacenonewline+  repl <- rstrip <$> anyChar `manyTill` eolof+  return $ RegexAlias re repl++endaliasesdirectivep :: ErroringJournalParser ()+endaliasesdirectivep = do+  string "end aliases"+  clearAccountAliases++tagdirectivep :: ErroringJournalParser ()+tagdirectivep = do+  string "tag" <?> "tag directive"+  lift (some spacenonewline)+  _ <- lift $ some nonspace+  lift restofline+  return ()++endtagdirectivep :: ErroringJournalParser ()+endtagdirectivep = do+  (string "end tag" <|> string "pop") <?> "end tag or pop directive"+  lift restofline+  return ()++defaultyeardirectivep :: ErroringJournalParser ()+defaultyeardirectivep = do+  char 'Y' <?> "default year"+  lift (many spacenonewline)+  y <- some digitChar+  let y' = read y+  failIfInvalidYear y+  setYear y'++defaultcommoditydirectivep :: ErroringJournalParser ()+defaultcommoditydirectivep = do+  char 'D' <?> "default commodity"+  lift (some spacenonewline)+  Amount{..} <- amountp+  lift restofline+  setDefaultCommodityAndStyle (acommodity, astyle)++marketpricedirectivep :: ErroringJournalParser MarketPrice+marketpricedirectivep = do+  char 'P' <?> "market price"+  lift (many spacenonewline)+  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored+  lift (some spacenonewline)+  symbol <- lift commoditysymbolp+  lift (many spacenonewline)+  price <- amountp+  lift restofline+  return $ MarketPrice date symbol price++ignoredpricecommoditydirectivep :: ErroringJournalParser ()+ignoredpricecommoditydirectivep = do+  char 'N' <?> "ignored-price commodity"+  lift (some spacenonewline)+  lift commoditysymbolp+  lift restofline+  return ()++commodityconversiondirectivep :: ErroringJournalParser ()+commodityconversiondirectivep = do+  char 'C' <?> "commodity conversion"+  lift (some spacenonewline)+  amountp+  lift (many spacenonewline)+  char '='+  lift (many spacenonewline)+  amountp+  lift restofline+  return ()++--- ** transactions++modifiertransactionp :: ErroringJournalParser ModifierTransaction+modifiertransactionp = do+  char '=' <?> "modifier transaction"+  lift (many spacenonewline)+  valueexpr <- T.pack <$> lift restofline+  postings <- postingsp Nothing+  return $ ModifierTransaction valueexpr postings++periodictransactionp :: ErroringJournalParser PeriodicTransaction+periodictransactionp = do+  char '~' <?> "periodic transaction"+  lift (many spacenonewline)+  periodexpr <- T.pack <$> lift restofline+  postings <- postingsp Nothing+  return $ PeriodicTransaction periodexpr postings++-- | Parse a (possibly unbalanced) transaction.+transactionp :: ErroringJournalParser Transaction+transactionp = do+  -- ptrace "transactionp"+  sourcepos <- genericSourcePos <$> getPosition+  date <- datep <?> "transaction"+  edate <- optional (secondarydatep date) <?> "secondary date"+  lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"+  status <- lift statusp <?> "cleared status"+  code <- T.pack <$> lift codep <?> "transaction code"+  description <- T.pack . strip <$> descriptionp+  comment <- try followingcommentp <|> (newline >> return "")+  let tags = commentTags comment+  postings <- postingsp (Just date)+  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=Uncleared,+      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+-- tags, and/or comments (inferring year, if needed, from the given date).+postingsp :: Maybe Day -> ErroringJournalParser [Posting]+postingsp mdate = many (try $ postingp mdate) <?> "postings"++-- linebeginningwithspaces :: Monad m => JournalParser m String+-- linebeginningwithspaces = do+--   sp <- lift (some spacenonewline)+--   c <- nonspace+--   cs <- lift restofline+--   return $ sp ++ (c:cs) ++ "\n"++postingp :: Maybe Day -> ErroringJournalParser Posting+postingp mtdate = do+  -- pdbg 0 "postingp"+  lift (some spacenonewline)+  status <- lift statusp+  lift (many spacenonewline)+  account <- modifiedaccountnamep+  let (ptype, account') = (accountNamePostingType account, textUnbracket account)+  amount <- spaceandamountormissingp+  massertion <- partialbalanceassertionp+  _ <- fixedlotpricep+  lift (many spacenonewline)+  (comment,tags,mdate,mdate2) <-+    try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))+  return posting+   { pdate=mdate+   , pdate2=mdate2+   , pstatus=status+   , paccount=account'+   , pamount=amount+   , pcomment=comment+   , ptype=ptype+   , ptags=tags+   , 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")]}++    " 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"}++    " a  1 ; a:a, [=2012/11/28]\n" `gives`+      ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"+                        ,ptags=[("a","a"), ("date2","2012/11/28")]+                        ,pdate=Nothing}++    " a  1 ; a:a\n  ; [2012/11/28=2012/11/29],b:b\n" `gives`+      ("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"+                        ,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]+                        ,pdate=parsedateM "2012/11/28"}++    assertBool -- "postingp parses a quoted commodity with numbers"+      (isRight $ parseWithState mempty (postingp Nothing) "  a  1 \"DE123\"\n")++  -- ,"postingp parses balance assertions and fixed lot prices" ~: do+    assertBool (isRight $ parseWithState mempty (postingp Nothing) "  a  1 \"DE123\" =$1 { =2.2 EUR} \n")++    -- 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++--- * more tests++tests_Hledger_Read_JournalReader = TestList $ concat [+    -- test_numberp+ ]++{- old hunit tests++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")++  ,"periodictransactionp" ~: do+     assertParse (parseWithState mempty periodictransactionp "~ (some period expr)\n some:postings  1\n")++  ,"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")++  ,"comment" ~: do+     assertParse (parseWithState mempty comment "; some comment \n")+     assertParse (parseWithState mempty comment " \t; x\n")+     assertParse (parseWithState mempty comment "#x")++  ,"datep" ~: do+     assertParse (parseWithState mempty datep "2011/1/1")+     assertParseFailure (parseWithState mempty datep "1/1")+     assertParse (parseWithState mempty{jpsYear=Just 2011} datep "1/1")++  ,"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++  ,"defaultyeardirectivep" ~: do+     assertParse (parseWithState mempty defaultyeardirectivep "Y 2010\n")+     assertParse (parseWithState mempty defaultyeardirectivep "Y 10001\n")++  ,"marketpricedirectivep" ~:+    assertParseEqual (parseWithState mempty marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55)++  ,"ignoredpricecommoditydirectivep" ~: do+     assertParse (parseWithState mempty ignoredpricecommoditydirectivep "N $\n")++  ,"defaultcommoditydirectivep" ~: do+     assertParse (parseWithState mempty defaultcommoditydirectivep "D $1,000.0\n")++  ,"commodityconversiondirectivep" ~: do+     assertParse (parseWithState mempty commodityconversiondirectivep "C 1h = $50.00\n")++  ,"tagdirectivep" ~: do+     assertParse (parseWithState mempty tagdirectivep "tag foo \n")++  ,"endtagdirectivep" ~: do+     assertParse (parseWithState mempty endtagdirectivep "end tag \n")+     assertParse (parseWithState mempty endtagdirectivep "pop \n")++  ,"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:")++  ,"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)++  ,"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))++ ]]+-}