hledger-lib 0.26 → 0.27

raw patch · 29 files changed

+1635/−1014 lines, 29 filesdep +deepseqdep +uglymemodep ~cmdargsdep ~regex-tdfadep ~safePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, uglymemo

Dependency ranges changed: cmdargs, regex-tdfa, safe, split, transformers

API changes (from Hackage documentation)

Files

• CHANGES +23/−1
• Hledger/Data.hs +4/−0
• Hledger/Data/Account.hs +2/−2
• Hledger/Data/AccountName.hs +26/−4
• Hledger/Data/Amount.hs +23/−14
• Hledger/Data/Journal.hs +60/−26
• Hledger/Data/OutputFormat.hs +0/−121
• Hledger/Data/Posting.hs +9/−4
• Hledger/Data/StringFormat.hs +180/−0
• Hledger/Data/TimeLog.hs +1/−0
• Hledger/Data/Transaction.hs +56/−46
• Hledger/Data/Types.hs +90/−63
• Hledger/Query.hs +8/−2
• Hledger/Read.hs +3/−3
• Hledger/Read/CsvReader.hs +58/−58
• Hledger/Read/JournalReader.hs +251/−176
• Hledger/Read/TimelogReader.hs +16/−16
• Hledger/Reports/BalanceReport.hs +41/−1
• Hledger/Reports/MultiBalanceReports.hs +16/−1
• Hledger/Reports/ReportOptions.hs +18/−3
• Hledger/Reports/TransactionsReports.hs +14/−5
• Hledger/Utils.hs +22/−340
• Hledger/Utils/Debug.hs +1/−1
• Hledger/Utils/Parse.hs +45/−0
• Hledger/Utils/Regex.hs +20/−3
• Hledger/Utils/String.hs +392/−0
• Hledger/Utils/Test.hs +41/−0
• Hledger/Utils/Tree.hs +87/−0
• hledger-lib.cabal +128/−124

@@ -1,6 +1,28 @@ API-ish changes in hledger-lib.-User-visible changes appear in hledger's change log.+For user-visible changes, see hledger's change log. +0.27 (unreleased)++- The main hledger types now derive NFData, which makes it easier to+  time things with criterion.++- Utils has been split up more.++- Utils.Regex: regular expression compilation has been memoized, and+  memoizing versions of regexReplace[CI] have been added, since+  compiling regular expressions every time seems to be quite+  expensive (#244).+ +- Utils.String: strWidth is now aware of multi-line strings (#242).++- Read: parsers now use a consistent p suffix.++- New dependencies: deepseq, uglymemo.++- All the hledger packages' cabal files are now generated from+  simpler, less redundant yaml files by hpack, in principle. In+  practice, manual fixups are still needed until hpack gets better,+  but it's still a win.  0.26 (2015/7/12) 

@@ -17,6 +17,7 @@                module Hledger.Data.Ledger,                module Hledger.Data.Posting,                module Hledger.Data.RawOptions,+               module Hledger.Data.StringFormat,                module Hledger.Data.TimeLog,                module Hledger.Data.Transaction,                module Hledger.Data.Types,@@ -34,6 +35,7 @@ import Hledger.Data.Ledger import Hledger.Data.Posting import Hledger.Data.RawOptions+import Hledger.Data.StringFormat import Hledger.Data.TimeLog import Hledger.Data.Transaction import Hledger.Data.Types@@ -49,6 +51,8 @@     ,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_Transaction     -- ,tests_Hledger_Data_Types

@@ -169,10 +169,10 @@  -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the--- account tree remains intact and can still be used. It's a tree/list!+-- tree's structure remains intact and can still be used. It's a tree/list! flattenAccounts :: Account -> [Account] flattenAccounts a = squish a []-  where squish a as = a:Prelude.foldr squish as (asubs a)+  where squish a as = a : Prelude.foldr squish as (asubs a)  -- | Filter an account tree (to a list). filterAccounts :: (Account -> Bool) -> Account -> [Account]

@@ -10,6 +10,7 @@ module Hledger.Data.AccountName where import Data.List+import Data.List.Split (splitOn) import Data.Tree import Test.HUnit import Text.Printf@@ -31,6 +32,16 @@ accountLeafName :: AccountName -> String accountLeafName = last . accountNameComponents +-- | Truncate all account name components but the last to two characters.+accountSummarisedName :: AccountName -> String+accountSummarisedName a+  --   length cs > 1 = take 2 (head cs) ++ ":" ++ a'+  | length cs > 1 = intercalate ":" (map (take 2) $ init cs) ++ ":" ++ a'+  | otherwise     = a'+    where+      cs = accountNameComponents a+      a' = accountLeafName a+ accountNameLevel :: AccountName -> Int accountNameLevel "" = 0 accountNameLevel a = length (filter (==acctsepchar) a) + 1@@ -100,13 +111,24 @@ --     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided! -- @ elideAccountName :: Int -> AccountName -> AccountName-elideAccountName width s =-    elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s+elideAccountName width s+  -- XXX special case for transactions register's multi-account pseudo-names+  | " (split)" `isSuffixOf` s =+    let+      names = splitOn ", " $ take (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 ", " $+     [accountNameFromComponents $ elideparts widthpername [] $ accountNameComponents s' | s' <- names]+  | otherwise =+    fitString Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where         elideparts :: Int -> [String] -> [String] -> [String]         elideparts width done ss-          | length (accountNameFromComponents $ done++ss) <= width = done++ss-          | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)+          | strWidth (accountNameFromComponents $ done++ss) <= width = done++ss+          | length ss > 1 = elideparts width (done++[takeWidth 2 $ head ss]) (tail ss)           | otherwise = done++ss  -- | Keep only the first n components of an account name, where n

@@ -87,6 +87,7 @@   isReallyZeroMixedAmountCost,   -- ** rendering   showMixedAmount,+  showMixedAmountOneLine,   showMixedAmountDebug,   showMixedAmountWithoutPrice,   showMixedAmountOneLineWithoutPrice,@@ -118,7 +119,7 @@ import Hledger.Utils  -deriving instance Show HistoricalPrice+deriving instance Show MarketPrice  amountstyle = AmountStyle L False 0 (Just '.') Nothing @@ -377,10 +378,12 @@ -- -- * amounts in the same commodity are combined unless they have different prices or total prices ----- * multiple zero amounts are replaced by just one. If they had the same commodity, it is preserved.+-- * multiple zero amounts, all with the same non-null commodity, are replaced by just the last of them, preserving the commodity and amount style (all but the last zero amount are discarded) ----- * an empty amount list is replaced with a single commodityless zero+-- * multiple zero amounts with multiple commodities, or no commodities, are replaced by one commodity-less zero amount --+-- * an empty amount list is replaced by one commodity-less zero amount+-- -- * the special "missing" mixed amount remains unchanged -- normaliseMixedAmount :: MixedAmount -> MixedAmount@@ -393,7 +396,7 @@   | otherwise            = Mixed nonzeros   where     newzero = case filter (/= "") (map acommodity zeros) of-               [c] -> nullamt{acommodity=c}+               _:_ -> last zeros                _   -> nullamt     (zeros, nonzeros) = partition isReallyZeroAmount $                         map sumSimilarAmountsUsingFirstPrice $@@ -517,19 +520,25 @@ -- normalising it to one amount per commodity. Assumes amounts have -- no or similar prices, otherwise this can show misleading prices. showMixedAmount :: MixedAmount -> String-showMixedAmount = showMixedAmountHelper False+showMixedAmount = showMixedAmountHelper False False  -- | Like showMixedAmount, but zero amounts are shown with their -- commodity if they have one. showMixedAmountWithZeroCommodity :: MixedAmount -> String-showMixedAmountWithZeroCommodity = showMixedAmountHelper True+showMixedAmountWithZeroCommodity = showMixedAmountHelper True False -showMixedAmountHelper :: Bool -> MixedAmount -> String-showMixedAmountHelper showzerocommodity m =-  vConcatRightAligned $ map showw $ amounts $ normaliseMixedAmountSquashPricesForDisplay m+-- | Get the one-line string representation of a mixed amount.+showMixedAmountOneLine :: MixedAmount -> String+showMixedAmountOneLine = showMixedAmountHelper False True++showMixedAmountHelper :: Bool -> Bool -> MixedAmount -> String+showMixedAmountHelper showzerocommodity useoneline m =+  join $ map showamt $ amounts $ normaliseMixedAmountSquashPricesForDisplay m   where-    showw | showzerocommodity = showAmountWithZeroCommodity-          | otherwise         = showAmount+    join | useoneline = intercalate ", "+         | otherwise  = vConcatRightAligned+    showamt | showzerocommodity = showAmountWithZeroCommodity+            | otherwise         = showAmount  -- | Compact labelled trace of a mixed amount, for debugging. ltraceamount :: String -> MixedAmount -> MixedAmount@@ -622,13 +631,13 @@    -- MixedAmount -  ,"adding mixed amounts, preserving minimum precision and a single commodity on zero" ~: do+  ,"adding mixed amounts to zero, the commodity and amount style are preserved" ~: do     (sum $ map (Mixed . (:[]))              [usd 1.25-             ,usd (-1) `withPrecision` 0+             ,usd (-1) `withPrecision` 3              ,usd (-0.25)              ])-      `is` Mixed [usd 0 `withPrecision` 0]+      `is` Mixed [usd 0 `withPrecision` 3]    ,"adding mixed amounts with total prices" ~: do     (sum $ map (Mixed . (:[]))

@@ -9,7 +9,7 @@  module Hledger.Data.Journal (   -- * Parsing helpers-  addHistoricalPrice,+  addMarketPrice,   addModifierTransaction,   addPeriodicTransaction,   addTimeLogEntry,@@ -35,6 +35,9 @@   journalDescriptions,   journalFilePath,   journalFilePaths,+  journalTransactionAt,+  journalNextTransaction,+  journalPrevTransaction,   journalPostings,   -- * Standard account types   journalBalanceSheetAccountQuery,@@ -114,7 +117,7 @@ --                      ,show (jmodifiertxns j) --                      ,show (jperiodictxns j) --                      ,show $ open_timelog_entries j---                      ,show $ historical_prices j+--                      ,show $ jmarketprices j --                      ,show $ final_comment_lines j --                      ,show $ jContext j --                      ,show $ map fst $ files j@@ -125,7 +128,7 @@                       , jperiodictxns = []                       , jtxns = []                       , open_timelog_entries = []-                      , historical_prices = []+                      , jmarketprices = []                       , final_comment_lines = []                       , jContext = nullctx                       , files = []@@ -134,7 +137,7 @@                       }  nullctx :: JournalContext-nullctx = Ctx { ctxYear = Nothing, ctxDefaultCommodityAndStyle = Nothing, ctxAccount = [], ctxAliases = [] }+nullctx = Ctx{ctxYear=Nothing, ctxDefaultCommodityAndStyle=Nothing, ctxAccount=[], ctxAliases=[], ctxTransactionIndex=0}  journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile@@ -154,12 +157,26 @@ addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j } -addHistoricalPrice :: HistoricalPrice -> Journal -> Journal-addHistoricalPrice h j = j { historical_prices = h : historical_prices j }+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 =+  -- it's probably ts !! (i+1), but we won't assume+  headMay [t | t <- ts, tindex t == i]++-- | 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 = nub . sort . map tdescription . jtxns@@ -411,7 +428,7 @@      , jtxns=reverse $ jtxns j -- NOTE: see addTransaction      , jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction      , jperiodictxns=reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction-     , historical_prices=reverse $ historical_prices j -- NOTE: see addHistoricalPrice+     , jmarketprices=reverse $ jmarketprices j -- NOTE: see addMarketPrice      , open_timelog_entries=reverse $ open_timelog_entries j -- NOTE: see addTimeLogEntry      })   >>= if assrt then journalCheckBalanceAssertions else return@@ -487,17 +504,19 @@                                     Left e    -> Left e       where balance = balanceTransaction (Just ss) --- | Convert all the journal's posting amounts (not 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.+-- | 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} = j''+journalCanonicaliseAmounts j@Journal{jtxns=ts, jmarketprices=mps} = j''     where-      j'' = j'{jtxns=map fixtransaction ts}+      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} @@ -528,8 +547,8 @@ journalCommodityStyle j c = M.findWithDefault amountstyle c $ jcommoditystyles j  -- -- | Apply this journal's historical price records to unpriced amounts where possible.--- journalApplyHistoricalPrices :: Journal -> Journal--- journalApplyHistoricalPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}+-- journalApplyMarketPrices :: Journal -> Journal+-- journalApplyMarketPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} --     where --       fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps} --        where@@ -537,14 +556,14 @@ --         fixmixedamount (Mixed as) = Mixed $ map fixamount as --         fixamount = fixprice --         fixprice a@Amount{price=Just _} = a---         fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalHistoricalPriceFor j d c}+--         fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalMarketPriceFor j d c}  -- -- | 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.--- journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount--- journalHistoricalPriceFor j d Commodity{symbol=s} = do---   let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j---   case ps of (HistoricalPrice{hamount=a}:_) -> Just a+-- journalMarketPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount+-- journalMarketPriceFor j d Commodity{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.@@ -581,13 +600,23 @@ --               Just (UnitPrice ma)  -> c:(concatMap amountCommodities $ amounts ma) --               Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma) --- | Get all this journal's (mixed) amounts, in the order parsed.-journalMixedAmounts :: Journal -> [MixedAmount]-journalMixedAmounts = map pamount . journalPostings---- | Get all this journal's component amounts, roughly in the order parsed.+-- | Get an ordered list of the amounts in this journal which will+-- influence amount style canonicalisation. These are:+--+-- * amounts in market price directives (in parse order)+-- * amounts in postings (in parse order)+--+-- Amounts in default commodity directives also influence+-- canonicalisation, but earlier, as amounts are parsed.+-- Amounts in posting prices are not used for canonicalisation.+-- journalAmounts :: Journal -> [Amount]-journalAmounts = concatMap flatten . journalMixedAmounts where flatten (Mixed as) = as+journalAmounts j =+  concat+   [map mpamount $ jmarketprices j+   ,concatMap flatten $ map pamount $ journalPostings j+   ]+  where flatten (Mixed as) = as  -- | The fully specified date span enclosing the dates (primary or secondary) -- of all this journal's transactions and postings, or DateSpan Nothing Nothing@@ -671,6 +700,7 @@          nulljournal          {jtxns = [            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/01/01",              tdate2=Nothing,@@ -687,6 +717,7 @@            }           ,            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/01",              tdate2=Nothing,@@ -703,6 +734,7 @@            }           ,            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/02",              tdate2=Nothing,@@ -719,6 +751,7 @@            }           ,            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/03",              tdate2=Nothing,@@ -735,6 +768,7 @@            }           ,            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/12/31",              tdate2=Nothing,

@@ -1,121 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Hledger.Data.OutputFormat (-          parseStringFormat-        , formatsp-        , formatValue-        , OutputFormat(..)-        , HledgerFormatField(..)-        , tests-        ) where--import Prelude ()-import Prelude.Compat-import Numeric-import Data.Char (isPrint)-import Data.Maybe-import Test.HUnit-import Text.Parsec-import Text.Printf--import Hledger.Data.Types---formatValue :: Bool -> Maybe Int -> Maybe Int -> String -> String-formatValue leftJustified min max value = printf formatS value-    where-      l = if leftJustified then "-" else ""-      min' = maybe "" show min-      max' = maybe "" (\i -> "." ++ (show i)) max-      formatS = "%" ++ l ++ min' ++ max' ++ "s"--parseStringFormat :: String -> Either String [OutputFormat]-parseStringFormat input = case (runParser (formatsp <* eof) () "(unknown)") input of-    Left y -> Left $ show y-    Right x -> Right x--{--Parsers--}--field :: Stream [Char] m Char => ParsecT [Char] st m HledgerFormatField-field = 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))--formatField :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat-formatField = do-    char '%'-    leftJustified <- optionMaybe (char '-')-    minWidth <- optionMaybe (many1 $ digit)-    maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)-    char '('-    f <- field-    char ')'-    return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f-    where-      parseDec s = case s of-        Just text -> Just m where ((m,_):_) = readDec text-        _ -> Nothing--formatLiteral :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat-formatLiteral = do-    s <- many1 c-    return $ FormatLiteral s-    where-      isPrintableButNotPercentage x = isPrint x && (not $ x == '%')-      c =     (satisfy isPrintableButNotPercentage <?> "printable character")-          <|> try (string "%%" >> return '%')--formatp :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat-formatp =-        formatField-    <|> formatLiteral--formatsp :: Stream [Char] m Char => ParsecT [Char] st m [OutputFormat]-formatsp = many formatp--testFormat :: OutputFormat -> String -> String -> Assertion-testFormat fs value expected = assertEqual name expected actual-    where-        (name, actual) = case fs of-            FormatLiteral l -> ("literal", formatValue False Nothing Nothing l)-            FormatField leftJustify min max _ -> ("field", formatValue leftJustify min max value)--testParser :: String -> [OutputFormat] -> Assertion-testParser s expected = case (parseStringFormat s) of-    Left  error -> assertFailure $ show error-    Right actual -> assertEqual ("Input: " ++ s) expected actual--tests = test [ formattingTests ++ parserTests ]--formattingTests = [-      testFormat (FormatLiteral " ")                                ""            " "-    , testFormat (FormatField False Nothing Nothing DescriptionField)    "description" "description"-    , testFormat (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"-    , testFormat (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"-    , testFormat (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"-    , testFormat (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "-    , testFormat (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "-    , testFormat (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"-    ]--parserTests = [-      testParser ""                             []-    , testParser "D"                            [FormatLiteral "D"]-    , testParser "%(date)"                      [FormatField False Nothing Nothing DescriptionField]-    , testParser "%(total)"                     [FormatField False Nothing Nothing TotalField]-    , testParser "Hello %(date)!"               [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]-    , testParser "%-(date)"                     [FormatField True Nothing Nothing DescriptionField]-    , testParser "%20(date)"                    [FormatField False (Just 20) Nothing DescriptionField]-    , testParser "%.10(date)"                   [FormatField False Nothing (Just 10) DescriptionField]-    , testParser "%20.10(date)"                 [FormatField False (Just 20) (Just 10) DescriptionField]-    , testParser "%20(account) %.10(total)\n"   [ FormatField False (Just 20) Nothing AccountField-                                                , FormatLiteral " "-                                                , FormatField False Nothing (Just 10) TotalField-                                                , FormatLiteral "\n"-                                                ]-  ]

@@ -37,6 +37,7 @@   joinAccountNames,   concatAccountNames,   accountNameApplyAliases,+  accountNameApplyAliasesMemo,   -- * arithmetic   sumPostings,   -- * rendering@@ -48,11 +49,11 @@ where import Data.List import Data.Maybe+import Data.MemoUgly (memo) import Data.Ord import Data.Time.Calendar import Safe import Test.HUnit-import Text.Printf  import Hledger.Utils import Hledger.Data.Types@@ -88,12 +89,12 @@     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22-      showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width+      showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . elideAccountName width       (bracket,width) = case t of                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmount+      showamount = padLeftWide 12 . showMixedAmount   showComment :: String -> String@@ -230,6 +231,10 @@              aname              aliases +-- | Memoising version of accountNameApplyAliases, maybe overkill.+accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> AccountName+accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)+ -- aliasMatches :: AccountAlias -> AccountName -> Bool -- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a -- aliasMatches (RegexAlias re  _) a = regexMatchesCI re a@@ -238,7 +243,7 @@ aliasReplace (BasicAlias old new) a   | old `isAccountNamePrefixOf` a || old == a = new ++ drop (length old) a   | otherwise = a-aliasReplace (RegexAlias re repl) a = regexReplaceCI re repl a+aliasReplace (RegexAlias re repl) a = regexReplaceCIMemo re repl a   tests_Hledger_Data_Posting = TestList [

@@ -0,0 +1,180 @@+-- | Parse format strings provided by --format, with awareness of+-- hledger's report item fields. The formats are used by+-- report-specific renderers like renderBalanceReportItem.++{-# LANGUAGE FlexibleContexts #-}++module Hledger.Data.StringFormat (+          parseStringFormat+        , defaultStringFormatStyle+        , StringFormat(..)+        , StringFormatComponent(..)+        , ReportItemField(..)+        , tests+        ) where++import Prelude ()+import Prelude.Compat+import Numeric+import Data.Char (isPrint)+import Data.Maybe+import Test.HUnit+import Text.Parsec++import Hledger.Utils.String (formatString)++-- | A format specification/template to use when rendering a report line item as text.+--+-- A format is a sequence of components; each is either a literal+-- string, or a hledger report item field with specified width and+-- justification whose value will be interpolated at render time.+--+-- A component's value may be a multi-line string (or a+-- multi-commodity amount), in which case the final string will be+-- either single-line or a top or bottom-aligned multi-line string+-- depending on the StringFormat variant used.+--+-- Currently this is only used in the balance command's single-column+-- mode, which provides a limited StringFormat renderer.+--+data StringFormat =+    OneLine [StringFormatComponent]       -- ^ multi-line values will be rendered on one line, comma-separated+  | TopAligned [StringFormatComponent]    -- ^ values will be top-aligned (and bottom-padded to the same height)+  | BottomAligned [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded)+  deriving (Show, Eq)++data StringFormatComponent =+    FormatLiteral String        -- ^ Literal text to be rendered as-is+  | FormatField Bool+                (Maybe Int)+                (Maybe Int)+                ReportItemField -- ^ A data field to be formatted and interpolated. Parameters:+                                --+                                -- - Left justify ? Right justified if false+                                -- - Minimum width ? Will be space-padded if narrower than this+                                -- - Maximum width ? Will be clipped if wider than this+                                -- - Which of the standard hledger report item fields to interpolate+  deriving (Show, Eq)++-- | An id identifying which report item field to interpolate.  These+-- are drawn from several hledger report types, so are not all+-- applicable for a given report.+data ReportItemField =+    AccountField      -- ^ A posting or balance report item's account name+  | DefaultDateField  -- ^ A posting or register or entry report item's date+  | DescriptionField  -- ^ A posting or register or entry report item's description+  | TotalField        -- ^ A balance or posting report item's balance or running total.+                      --   Always rendered right-justified.+  | DepthSpacerField  -- ^ A balance report item's indent level (which may be different from the account name depth).+                      --   Rendered as this number of spaces, multiplied by the minimum width spec if any.+  | FieldNo Int       -- ^ A report item's nth field. May be unimplemented.+    deriving (Show, Eq)++----------------------------------------------------------------------++-- renderStringFormat :: StringFormat -> Map String String -> String+-- renderStringFormat fmt params =++----------------------------------------------------------------------++-- | Parse a string format specification, or return a parse error.+parseStringFormat :: String -> Either String StringFormat+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 = do+  alignspec <- optionMaybe (try $ char '%' >> oneOf "^_,")+  let constructor =+        case alignspec of+          Just '^' -> TopAligned+          Just '_' -> BottomAligned+          Just ',' -> OneLine+          _        -> defaultStringFormatStyle+  constructor <$> many componentp++componentp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent+componentp = formatliteralp <|> formatfieldp++formatliteralp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent+formatliteralp = do+    s <- many1 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 = do+    char '%'+    leftJustified <- optionMaybe (char '-')+    minWidth <- optionMaybe (many1 $ digit)+    maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)+    char '('+    f <- fieldp+    char ')'+    return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f+    where+      parseDec s = case s of+        Just text -> Just m where ((m,_):_) = readDec text+        _ -> Nothing++fieldp :: Stream [Char] m Char => ParsecT [Char] st m 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))++----------------------------------------------------------------------++testFormat :: StringFormatComponent -> String -> String -> Assertion+testFormat fs value expected = assertEqual name expected actual+    where+        (name, actual) = case fs of+            FormatLiteral l -> ("literal", formatString False Nothing Nothing l)+            FormatField leftJustify min max _ -> ("field", formatString leftJustify min max value)++testParser :: String -> StringFormat -> Assertion+testParser s expected = case (parseStringFormat s) of+    Left  error -> assertFailure $ show error+    Right actual -> assertEqual ("Input: " ++ s) expected actual++tests = test [ formattingTests ++ parserTests ]++formattingTests = [+      testFormat (FormatLiteral " ")                                ""            " "+    , testFormat (FormatField False Nothing Nothing DescriptionField)    "description" "description"+    , testFormat (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"+    , testFormat (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"+    , testFormat (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"+    , testFormat (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "+    , testFormat (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "+    , testFormat (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"+    ]++parserTests = [+      testParser ""                             (defaultStringFormatStyle [])+    , testParser "D"                            (defaultStringFormatStyle [FormatLiteral "D"])+    , testParser "%(date)"                      (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])+    , testParser "%(total)"                     (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField])+    , testParser "^%(total)"                    (TopAligned [FormatField False Nothing Nothing TotalField])+    , testParser "_%(total)"                    (BottomAligned [FormatField False Nothing Nothing TotalField])+    , testParser ",%(total)"                    (OneLine [FormatField False Nothing Nothing TotalField])+    , testParser "Hello %(date)!"               (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])+    , testParser "%-(date)"                     (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField])+    , testParser "%20(date)"                    (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])+    , testParser "%.10(date)"                   (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField])+    , testParser "%20.10(date)"                 (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])+    , testParser "%20(account) %.10(total)\n"   (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField+                                                , FormatLiteral " "+                                                , FormatField False Nothing (Just 10) TotalField+                                                , FormatLiteral "\n"+                                                ])+  ]

@@ -79,6 +79,7 @@         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,

@@ -30,6 +30,7 @@   -- * rendering   showTransaction,   showTransactionUnelided,+  showTransactionUnelidedOneLineAmounts,   -- * misc.   tests_Hledger_Data_Transaction )@@ -40,7 +41,6 @@ import Test.HUnit import Text.Printf import qualified Data.Map as Map-import Text.Parsec.Pos  import Hledger.Utils import Hledger.Data.Types@@ -56,11 +56,12 @@ instance Show PeriodicTransaction where     show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) -nullsourcepos :: SourcePos-nullsourcepos = initialPos ""+nullsourcepos :: GenericSourcePos+nullsourcepos = GenericSourcePos "" 1 1  nulltransaction :: Transaction nulltransaction = Transaction {+                    tindex=0,                     tsourcepos=nullsourcepos,                     tdate=nulldate,                     tdate2=Nothing,@@ -90,10 +91,10 @@ @ -} showTransaction :: Transaction -> String-showTransaction = showTransaction' True+showTransaction = showTransactionHelper True False  showTransactionUnelided :: Transaction -> String-showTransactionUnelided = showTransaction' False+showTransactionUnelided = showTransactionHelper False False  tests_showTransactionUnelided = [    "showTransactionUnelided" ~: do@@ -128,18 +129,19 @@       ]  ] +showTransactionUnelidedOneLineAmounts :: Transaction -> String+showTransactionUnelidedOneLineAmounts = showTransactionHelper False True+ -- cf showPosting-showTransaction' :: Bool -> Transaction -> String-showTransaction' elide t =+showTransactionHelper :: Bool -> Bool -> Transaction -> String+showTransactionHelper elide onelineamounts t =     unlines $ [descriptionline]               ++ newlinecomments-              ++ (postingsAsLines elide t (tpostings t))+              ++ (postingsAsLines elide onelineamounts t (tpostings t))               ++ [""]     where       descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment]-      date = showdate (tdate t) ++ maybe "" showedate (tdate2 t)-      showdate = printf "%-10s" . showDate-      showedate = printf "=%s" . showdate+      date = showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t)       status | tstatus t == Cleared = " *"              | tstatus t == Pending = " !"              | otherwise            = ""@@ -167,33 +169,41 @@ --       ls = lines s --       prefix = indent . (";"++) -postingsAsLines :: Bool -> Transaction -> [Posting] -> [String]-postingsAsLines elide t ps+postingsAsLines :: Bool -> Bool -> Transaction -> [Posting] -> [String]+postingsAsLines elide onelineamounts t ps     | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check-       = (concatMap (postingAsLines False ps) $ init ps) ++ postingAsLines True ps (last ps)-    | otherwise = concatMap (postingAsLines False ps) ps+       = (concatMap (postingAsLines False onelineamounts ps) $ init ps) ++ postingAsLines True onelineamounts ps (last ps)+    | otherwise = concatMap (postingAsLines False onelineamounts ps) ps -postingAsLines :: Bool -> [Posting] -> Posting -> [String]-postingAsLines elideamount ps p =+postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [String]+postingAsLines elideamount onelineamounts ps p =     postinglines     ++ newlinecomments   where-    postinglines = map rstrip $ lines $ concatTopPadded [showacct p, "  ", amount, samelinecomment]-    amount = if elideamount then "" else showamt (pamount p)+    postinglines = map rstrip $ lines $ concatTopPadded [account, "  ", amount, samelinecomment]++    account =+      indent $+        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++    -- currently prices are considered part of the amount string when right-aligning amounts+    amount+      | elideamount    = ""+      | onelineamounts = fitString (Just amtwidth) Nothing False False $ showMixedAmountOneLine $ pamount p+      | otherwise      = fitStringMulti (Just amtwidth) Nothing False False $ showMixedAmount $ pamount p+      where+        amtwidth = maximum $ 12 : map (strWidth . showMixedAmount . pamount) ps  -- min. 12 for backwards compatibility+     (samelinecomment, newlinecomments) =       case renderCommentLines (pcomment p) of []   -> ("",[])                                               c:cs -> (c,cs)-    showacct p =-      indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))-        where-          showstatus p = if pstatus p == Cleared then "* " else ""-          w = maximum $ map (length . paccount) ps-    showamt =-        padleft 12 . showMixedAmount  tests_postingAsLines = [    "postingAsLines" ~: do-    let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p)+    let p `gives` ls = assertEqual "" ls (postingAsLines False False [p] p)     posting `gives` ["                 0"]     posting{       pstatus=Cleared,@@ -410,7 +420,7 @@         ,"    assets:checking"         ,""         ])-       (let t = Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []+       (let t = Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []                 [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}                 ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t}                 ] ""@@ -424,7 +434,7 @@         ,"    assets:checking               $-47.18"         ,""         ])-       (let t = Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []+       (let t = Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []                 [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}                 ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t}                 ] ""@@ -440,7 +450,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []+        (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.19)]}          ] ""))@@ -453,7 +463,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []+        (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ] "")) @@ -465,7 +475,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []+        (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=missingmixedamt}          ] "")) @@ -478,7 +488,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction nullsourcepos (parsedate "2010/01/01") Nothing Uncleared "" "x" "" []+        (txnTieKnot $ Transaction 0 nullsourcepos (parsedate "2010/01/01") Nothing Uncleared "" "x" "" []          [posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}          ,posting{paccount="b", pamount= missingmixedamt}          ] ""))@@ -486,19 +496,19 @@   ,"balanceTransaction" ~: do      assertBool "detect unbalanced entry, sign error"                     (isLeft $ balanceTransaction Nothing-                           (Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []+                           (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []                             [posting{paccount="a", pamount=Mixed [usd 1]}                             ,posting{paccount="b", pamount=Mixed [usd 1]}                             ] ""))       assertBool "detect unbalanced entry, multiple missing amounts"                     (isLeft $ balanceTransaction Nothing-                           (Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []+                           (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" []                             [posting{paccount="a", pamount=missingmixedamt}                             ,posting{paccount="b", pamount=missingmixedamt}                             ] "")) -     let e = balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "" "" []+     let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1]}                            ,posting{paccount="b", pamount=missingmixedamt}                            ] "")@@ -509,7 +519,7 @@                         Right e' -> (pamount $ last $ tpostings e')                         Left _ -> error' "should not happen") -     let e = balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []+     let e = balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1.35]}                            ,posting{paccount="b", pamount=Mixed [eur (-1)]}                            ] "")@@ -521,49 +531,49 @@                         Left _ -> error' "should not happen")       assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $-       balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []+       balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1 `at` eur 2]}                            ,posting{paccount="a", pamount=Mixed [usd (-2) `at` eur 1]}                            ] ""))       assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $-       balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []+       balanceTransaction Nothing (Transaction 0 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1    @@ eur 1]}                            ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]}                            ] ""))    ,"isTransactionBalanced" ~: do-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ] ""      assertBool "detect balanced" (isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.01)], ptransaction=Just t}              ] ""      assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ] ""      assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t}              ] ""      assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting, ptransaction=Just t}              ] ""      assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}              ] ""      assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)-     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []+     let t = Transaction 0 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-} {-|  Most data types are defined here to avoid import cycles.@@ -7,7 +7,7 @@ > Journal                  -- a journal is read from one or more data files. It contains.. >  [Transaction]           -- journal transactions (aka entries), which have date, cleared status, code, description and.. >   [Posting]              -- multiple account postings, which have account name and amount->  [HistoricalPrice]       -- historical commodity prices+>  [MarketPrice]           -- historical market prices for commodities > > Ledger                   -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. >  Journal                 -- a filtered copy of the original journal, containing only the transactions and postings we are interested in@@ -19,6 +19,9 @@  module Hledger.Data.Types where++import GHC.Generics (Generic)+import Control.DeepSeq (NFData) import Control.Monad.Except (ExceptT) import Data.Data #ifndef DOUBLE@@ -29,7 +32,6 @@ import Data.Time.Calendar import Data.Time.LocalTime import System.Time (ClockTime(..))-import Text.Parsec.Pos  import Hledger.Utils.Regex @@ -38,29 +40,30 @@  data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Typeable)+data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,Typeable) +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,Typeable)+                deriving (Eq,Show,Ord,Data,Generic,Typeable) +instance NFData Interval+ type AccountName = String  data AccountAlias = BasicAlias AccountName AccountName                   | RegexAlias Regexp Replacement-  deriving (-  Eq-  ,Read-  ,Show-  ,Ord-  ,Data-  ,Typeable-  )+  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) -data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data)+instance NFData AccountAlias +data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic)++instance NFData Side+ type Commodity = String  -- | The basic numeric type used in amounts. Different implementations@@ -74,7 +77,7 @@ deriving instance Data (Quantity) -- The following is for hledger-web, and requires blaze-markup. -- Doing it here avoids needing a matching flag on the hledger-web package.-instance ToMarkup (Quantity) +instance ToMarkup (Quantity)  where    toMarkup = toMarkup . show numberRepresentation = "Decimal"@@ -82,8 +85,10 @@  -- | An amount's price (none, per unit, or total) in another commodity. -- Note the price should be a positive number, although this is not enforced.-data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data)+data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data,Generic) +instance NFData Price+ -- | Display style for an amount. data AmountStyle = AmountStyle {       ascommodityside :: Side,       -- ^ does the symbol appear on the left or the right ?@@ -91,8 +96,10 @@       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)+} deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) +instance NFData AmountStyle+ -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to -- separate groups (comma or period, whichever is not used as decimal@@ -100,25 +107,35 @@ -- the decimal point. The last group size is assumed to repeat. Eg, -- comma between thousands is DigitGroups ',' [3]. data DigitGroupStyle = DigitGroups Char [Int]-  deriving (Eq,Ord,Read,Show,Typeable,Data)+  deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) +instance NFData DigitGroupStyle+ data Amount = Amount {       acommodity :: Commodity,       aquantity :: Quantity,       aprice :: Price,                -- ^ the (fixed) price for this amount, if any       astyle :: AmountStyle-    } deriving (Eq,Ord,Typeable,Data)+    } deriving (Eq,Ord,Typeable,Data,Generic) -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data)+instance NFData Amount +newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic)++instance NFData MixedAmount+ data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting-                   deriving (Eq,Show,Typeable,Data)+                   deriving (Eq,Show,Typeable,Data,Generic) +instance NFData PostingType+ type Tag = (String, String)  -- ^ A tag name and (possibly empty) value.  data ClearedStatus = Uncleared | Pending | Cleared-                   deriving (Eq,Ord,Typeable,Data)+                   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@@ -136,15 +153,25 @@       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)+    } deriving (Typeable,Data,Generic) +instance NFData Posting+ -- The equality test for postings ignores the parent transaction's -- identity, to avoid infinite loops. instance Eq Posting where     (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2 +-- | The position of parse errors (eg), like parsec's SourcePos but generic.+-- File name, 1-based line number and 1-based column number.+data GenericSourcePos = GenericSourcePos FilePath Int Int+  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)++instance NFData GenericSourcePos+ data Transaction = Transaction {-      tsourcepos :: SourcePos,+      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,@@ -154,34 +181,46 @@       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-    } deriving (Eq,Typeable,Data)+    } deriving (Eq,Typeable,Data,Generic) +instance NFData Transaction+ data ModifierTransaction = ModifierTransaction {       mtvalueexpr :: String,       mtpostings :: [Posting]-    } deriving (Eq,Typeable,Data)+    } deriving (Eq,Typeable,Data,Generic) +instance NFData ModifierTransaction+ data PeriodicTransaction = PeriodicTransaction {       ptperiodicexpr :: String,       ptpostings :: [Posting]-    } deriving (Eq,Typeable,Data)+    } deriving (Eq,Typeable,Data,Generic) -data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data)+instance NFData PeriodicTransaction +data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)++instance NFData TimeLogCode+ data TimeLogEntry = TimeLogEntry {-      tlsourcepos :: SourcePos,+      tlsourcepos :: GenericSourcePos,       tlcode :: TimeLogCode,       tldatetime :: LocalTime,       tlaccount :: String,       tldescription :: String-    } deriving (Eq,Ord,Typeable,Data)+    } deriving (Eq,Ord,Typeable,Data,Generic) -data HistoricalPrice = HistoricalPrice {-      hdate :: Day,-      hcommodity :: Commodity,-      hamount :: Amount-    } deriving (Eq,Typeable,Data) -- & Show (in Amount.hs)+instance NFData TimeLogEntry +data MarketPrice = MarketPrice {+      mpdate :: Day,+      mpcommodity :: Commodity,+      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@@ -195,17 +234,23 @@                                         --   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-    } deriving (Read, Show, Eq, Data, Typeable)+    , ctxTransactionIndex   :: !Integer -- ^ the number of transactions read so far+    } deriving (Read, Show, Eq, Data, Typeable, Generic) +instance NFData JournalContext+ 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],-      historical_prices :: [HistoricalPrice],+      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@@ -214,17 +259,20 @@                                             -- 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)+    } deriving (Eq, Typeable, Data, Generic) +instance NFData Journal+ -- | A JournalUpdate is some transformation of a Journal. It can do I/O or--- raise an error.+-- raise an exception. type JournalUpdate = ExceptT String IO (Journal -> Journal)  -- | The id of a data format understood by hledger, eg @journal@ or @csv@.+-- The --output-format option selects one of these for output. type StorageFormat = String --- | A hledger journal reader is a triple of format name, format-detecting--- predicate, and a parser to Journal.+-- | A hledger journal reader is a triple of storage format name, a+-- detector of that format, and a parser from that format to Journal. data Reader = Reader {      -- name of the format this reader handles      rFormat   :: StorageFormat@@ -236,26 +284,6 @@  instance Show Reader where show r = rFormat r ++ " reader" --- format strings--data HledgerFormatField =-    AccountField-  | DefaultDateField-  | DescriptionField-  | TotalField-  | DepthSpacerField-  | FieldNo Int-    deriving (Show, Eq)--data OutputFormat =-    FormatLiteral String-  | FormatField Bool        -- Left justified ?-                (Maybe Int) -- Min width-                (Maybe Int) -- Max width-                HledgerFormatField       -- Field-  deriving (Show, Eq)-- -- | An account, with name, balances and links to parent/subaccounts -- which let you walk up or down the account tree. data Account = Account {@@ -269,8 +297,6 @@   aboring :: Bool           -- ^ used in the accounts report to label elidable parents   } -- -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and -- tree-wise, since each one knows its parent and subs; the first@@ -279,3 +305,4 @@   ljournal :: Journal,   laccounts :: [Account] }+

@@ -78,7 +78,9 @@            | Sym Regexp       -- ^ match if the entire commodity symbol is matched by this regexp            | Empty Bool       -- ^ if true, show zero-amount postings/accounts which are usually not shown                               --   more of a query option than a query criteria ?-           | Depth Int        -- ^ match if account depth is less than or equal to this value+           | Depth Int        -- ^ match if account depth is less than or equal to this value.+                              --   Depth is sometimes used like a query (for filtering report data)+                              --   and sometimes like a query option (for controlling display)            | Tag Regexp (Maybe Regexp)  -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps                                         -- matching the regexp if provided, exists     deriving (Eq,Data,Typeable)@@ -254,7 +256,11 @@ 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) = Left $ Depth $ readDef 0 s+parseQueryTerm _ ('d':'e':'p':'t':'h':':':s)+  | n >= 0    = Left $ Depth n+  | otherwise = error' "depth: should have a positive number"+  where n = readDef 0 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 _ "" = Left $ Any

@@ -244,9 +244,9 @@    tests_Hledger_Read_CsvReader,     "journal" ~: do-    r <- runExceptT $ parseWithCtx nullctx JournalReader.journal ""-    assertBool "journal should parse an empty file" (isRight $ r)+    r <- runExceptT $ parseWithCtx nullctx 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 "journal parsing an empty file should give an empty journal" . null . jtxns) jE+    either error' (assertBool "journalp parsing an empty file should give an empty journal" . null . jtxns) jE    ]

@@ -51,7 +51,7 @@ import Hledger.Data import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils-import Hledger.Read.JournalReader (amountp, statusp)+import Hledger.Read.JournalReader (amountp, statusp, genericSourcePos)   reader :: Reader@@ -392,11 +392,11 @@ rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules rulesp = do   many $ choice'-    [blankorcommentline                                                    <?> "blank or comment line"-    ,(directive        >>= modifyState . addDirective)                     <?> "directive"-    ,(fieldnamelist    >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"-    ,(fieldassignment  >>= modifyState . addAssignment)                    <?> "field assignment"-    ,(conditionalblock >>= modifyState . addConditionalBlock)              <?> "conditional block"+    [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"     ]   eof   r <- getState@@ -405,23 +405,23 @@           ,rconditionalblocks=reverse $ rconditionalblocks r           } -blankorcommentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline]+blankorcommentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+blankorcommentlinep = pdbg 3 "trying blankorcommentlinep" >> choice' [blanklinep, commentlinep] -blankline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-blankline = many spacenonewline >> newline >> return () <?> "blank line"+blanklinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+blanklinep = many spacenonewline >> newline >> return () <?> "blank line" -commentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line"+commentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+commentlinep = many spacenonewline >> commentcharp >> restofline >> return () <?> "comment line" -commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char-commentchar = oneOf ";#*"+commentcharp :: Stream [Char] m t => ParsecT [Char] CsvRules m Char+commentcharp = oneOf ";#*" -directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)-directive = do+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) >> directiveval)+  v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directivevalp)        <|> (optional (char ':') >> many spacenonewline >> eolof >> return "")   return (d,v)   <?> "directive"@@ -436,46 +436,46 @@    -- ,"base-currency"   ] -directiveval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-directiveval = anyChar `manyTill` eolof+directivevalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+directivevalp = anyChar `manyTill` eolof -fieldnamelist :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]-fieldnamelist = (do+fieldnamelistp :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]+fieldnamelistp = (do   pdbg 3 "trying fieldnamelist"   string "fields"   optional $ char ':'   many1 spacenonewline   let separator = many spacenonewline >> char ',' >> many spacenonewline-  f <- fromMaybe "" <$> optionMaybe fieldname-  fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldname)+  f <- fromMaybe "" <$> optionMaybe fieldnamep+  fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldnamep)   restofline   return $ map (map toLower) $ f:fs   ) <?> "field name list" -fieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-fieldname = quotedfieldname <|> barefieldname+fieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+fieldnamep = quotedfieldnamep <|> barefieldnamep -quotedfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-quotedfieldname = do+quotedfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+quotedfieldnamep = do   char '"'   f <- many1 $ noneOf "\"\n:;#~"   char '"'   return f -barefieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-barefieldname = many1 $ noneOf " \t\n,;#~"+barefieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+barefieldnamep = many1 $ noneOf " \t\n,;#~" -fieldassignment :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)-fieldassignment = do+fieldassignmentp :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)+fieldassignmentp = do   pdbg 3 "trying fieldassignment"-  f <- journalfieldname-  assignmentseparator-  v <- fieldval+  f <- journalfieldnamep+  assignmentseparatorp+  v <- fieldvalp   return (f,v)   <?> "field assignment" -journalfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames)+journalfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+journalfieldnamep = pdbg 2 "trying journalfieldnamep" >> choice' (map string journalfieldnames)  journalfieldnames =   [-- pseudo fields:@@ -494,9 +494,9 @@   ,"comment"   ] -assignmentseparator :: Stream [Char] m t => ParsecT [Char] CsvRules m ()-assignmentseparator = do-  pdbg 3 "trying assignmentseparator"+assignmentseparatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+assignmentseparatorp = do+  pdbg 3 "trying assignmentseparatorp"   choice [     -- try (many spacenonewline >> oneOf ":="),     try (many spacenonewline >> char ':'),@@ -505,51 +505,51 @@   _ <- many spacenonewline   return () -fieldval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-fieldval = do+fieldvalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+fieldvalp = do   pdbg 2 "trying fieldval"   anyChar `manyTill` eolof -conditionalblock :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock-conditionalblock = do-  pdbg 3 "trying conditionalblock"+conditionalblockp :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock+conditionalblockp = do+  pdbg 3 "trying conditionalblockp"   string "if" >> many spacenonewline >> optional newline-  ms <- many1 recordmatcher-  as <- many (many1 spacenonewline >> fieldassignment)+  ms <- many1 recordmatcherp+  as <- many (many1 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" -recordmatcher :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]-recordmatcher = do-  pdbg 2 "trying recordmatcher"+recordmatcherp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]+recordmatcherp = do+  pdbg 2 "trying recordmatcherp"   -- pos <- currentPos-  _  <- optional (matchoperator >> many spacenonewline >> optional newline)-  ps <- patterns+  _  <- optional (matchoperatorp >> 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" -matchoperator :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]-matchoperator = choice' $ map string+matchoperatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]+matchoperatorp = choice' $ map string   ["~"   -- ,"!~"   -- ,"="   -- ,"!="   ] -patterns :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]-patterns = do-  pdbg 3 "trying patterns"+patternsp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]+patternsp = do+  pdbg 3 "trying patternsp"   ps <- many regexp   return ps  regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] regexp = do   pdbg 3 "trying regexp"-  notFollowedBy matchoperator+  notFollowedBy matchoperatorp   c <- nonspace   cs <- anyChar `manyTill` eolof   return $ strip $ c:cs@@ -643,7 +643,7 @@      -- build the transaction     t = nulltransaction{-      tsourcepos               = sourcepos,+      tsourcepos               = genericSourcePos sourcepos,       tdate                    = date',       tdate2                   = mdate2',       tstatus                  = status,

@@ -21,16 +21,17 @@   -- * Reader   reader,   -- * Parsers used elsewhere-  parseJournalWith,+  parseAndFinaliseJournal,+  genericSourcePos,   getParentAccount,-  journal,-  directive,-  defaultyeardirective,-  historicalpricedirective,+  journalp,+  directivep,+  defaultyeardirectivep,+  marketpricedirectivep,   datetimep,   codep,   accountnamep,-  modifiedaccountname,+  modifiedaccountnamep,   postingp,   amountp,   amountp',@@ -93,25 +94,85 @@ -- | 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 _ = parseJournalWith journal+parse _ = parseAndFinaliseJournal journalp  -- parsing utils --- | Flatten a list of JournalUpdate's into a single equivalent one.+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 = liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence us+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.-parseJournalWith :: (ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ExceptT String IO Journal-parseJournalWith p assrt f s = do+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 p nullctx{ctxYear=Just y} f s+  r <- runParserT parser nullctx{ctxYear=Just y} f s   case r of     Right (updates,ctx) -> do-                           j <- updates `ap` return nulljournal+                           j <- ap updates (return nulljournal)                            case journalFinalise tc tl f s ctx assrt j of                              Right j'  -> return j'                              Left estr -> throwError estr@@ -151,13 +212,19 @@ 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.-journal :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)-journal = do+journalp :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)+journalp = do   journalupdates <- many journalItem   eof   finalctx <- getState@@ -166,36 +233,36 @@       -- 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 [ directive-                           , liftM (return . addTransaction) transaction-                           , liftM (return . addModifierTransaction) modifiertransaction-                           , liftM (return . addPeriodicTransaction) periodictransaction-                           , liftM (return . addHistoricalPrice) historicalpricedirective+      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-directive :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-directive = do+directivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+directivep = do   optional $ char '!'   choice' [-    includedirective-   ,aliasdirective-   ,endaliasesdirective-   ,accountdirective-   ,enddirective-   ,tagdirective-   ,endtagdirective-   ,defaultyeardirective-   ,defaultcommoditydirective-   ,commodityconversiondirective-   ,ignoredpricecommoditydirective+    includedirectivep+   ,aliasdirectivep+   ,endaliasesdirectivep+   ,accountdirectivep+   ,enddirectivep+   ,tagdirectivep+   ,endtagdirectivep+   ,defaultyeardirectivep+   ,defaultcommoditydirectivep+   ,commodityconversiondirectivep+   ,ignoredpricecommoditydirectivep    ]   <?> "directive" -includedirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-includedirective = do+includedirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+includedirectivep = do   string "include"   many1 spacenonewline   filename <- restofline@@ -206,7 +273,7 @@        filepath <- expandPath curdir filename        txt <- readFileOrError outerPos filepath        let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-       r <- runParserT journal outerState filepath txt+       r <- runParserT journalp outerState filepath txt        case r of          Right (ju, ctx) -> do                             u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)@@ -226,8 +293,8 @@ journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}  -- NOTE: first encountered file to left, to avoid a reverse -accountdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-accountdirective = do+accountdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+accountdirectivep = do   string "account"   many1 spacenonewline   parent <- accountnamep@@ -236,15 +303,15 @@   -- return $ return id   return $ ExceptT $ return $ Right id -enddirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-enddirective = do+enddirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+enddirectivep = do   string "end"   popParentAccount   -- return (return id)   return $ ExceptT $ return $ Right id -aliasdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-aliasdirective = do+aliasdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+aliasdirectivep = do   string "alias"   many1 spacenonewline   alias <- accountaliasp@@ -275,28 +342,28 @@   repl <- rstrip <$> anyChar `manyTill` eolof   return $ RegexAlias re repl -endaliasesdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-endaliasesdirective = do+endaliasesdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+endaliasesdirectivep = do   string "end aliases"   clearAccountAliases   return (return id) -tagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-tagdirective = do+tagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+tagdirectivep = do   string "tag" <?> "tag directive"   many1 spacenonewline   _ <- many1 nonspace   restofline   return $ return id -endtagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-endtagdirective = do+endtagdirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+endtagdirectivep = do   (string "end tag" <|> string "pop") <?> "end tag or pop directive"   restofline   return $ return id -defaultyeardirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-defaultyeardirective = do+defaultyeardirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+defaultyeardirectivep = do   char 'Y' <?> "default year"   many spacenonewline   y <- many1 digit@@ -305,8 +372,8 @@   setYear y'   return $ return id -defaultcommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-defaultcommoditydirective = do+defaultcommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+defaultcommoditydirectivep = do   char 'D' <?> "default commodity"   many1 spacenonewline   Amount{..} <- amountp@@ -314,28 +381,28 @@   restofline   return $ return id -historicalpricedirective :: ParsecT [Char] JournalContext (ExceptT String IO) HistoricalPrice-historicalpricedirective = do-  char 'P' <?> "historical price"+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 <- commoditysymbol+  symbol <- commoditysymbolp   many spacenonewline   price <- amountp   restofline-  return $ HistoricalPrice date symbol price+  return $ MarketPrice date symbol price -ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-ignoredpricecommoditydirective = do+ignoredpricecommoditydirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+ignoredpricecommoditydirectivep = do   char 'N' <?> "ignored-price commodity"   many1 spacenonewline-  commoditysymbol+  commoditysymbolp   restofline   return $ return id -commodityconversiondirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate-commodityconversiondirective = do+commodityconversiondirectivep :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate+commodityconversiondirectivep = do   char 'C' <?> "commodity conversion"   many1 spacenonewline   amountp@@ -346,27 +413,27 @@   restofline   return $ return id -modifiertransaction :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction-modifiertransaction = do+modifiertransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction+modifiertransactionp = do   char '=' <?> "modifier transaction"   many spacenonewline   valueexpr <- restofline-  postings <- postings+  postings <- postingsp   return $ ModifierTransaction valueexpr postings -periodictransaction :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction-periodictransaction = do+periodictransactionp :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction+periodictransactionp = do   char '~' <?> "periodic transaction"   many spacenonewline   periodexpr <- restofline-  postings <- postings+  postings <- postingsp   return $ PeriodicTransaction periodexpr postings  -- | Parse a (possibly unbalanced) transaction.-transaction :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction-transaction = do-  -- ptrace "transaction"-  sourcepos <- getPosition+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"@@ -375,15 +442,17 @@   description <- descriptionp >>= return . strip   comment <- try followingcommentp <|> (newline >> return "")   let tags = tagsInComment comment-  postings <- postings-  return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags postings ""+  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_transaction = do+test_transactionp = do     let s `gives` t = do-                        let p = parseWithCtx nullctx transaction s+                        let p = parseWithCtx nullctx transactionp s                         assertBool $ isRight p                         let Right t2 = p                             -- same f = assertEqual (f t) (f t2)@@ -436,33 +505,33 @@       tdate=parsedate "2015/01/01",       } -    assertRight $ parseWithCtx nullctx transaction $ unlines+    assertRight $ parseWithCtx nullctx transactionp $ unlines       ["2007/01/28 coopportunity"       ,"    expenses:food:groceries                   $47.18"       ,"    assets:checking                          $-47.18"       ,""       ] -    -- transaction should not parse just a date-    assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n"+    -- transactionp should not parse just a date+    assertLeft $ parseWithCtx nullctx transactionp "2009/1/1\n" -    -- transaction should not parse just a date and description-    assertLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n"+    -- transactionp should not parse just a date and description+    assertLeft $ parseWithCtx nullctx transactionp "2009/1/1 a\n" -    -- transaction should not parse a following comment as part of the description-    let p = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n"+    -- 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 transaction $ unlines+    assertRight $ parseWithCtx nullctx transactionp $ unlines         ["2012/1/1"         ,"  a  1"         ,"  b"         ," "         ] -    let p = parseWithCtx nullctx transaction $ unlines+    let p = parseWithCtx nullctx transactionp $ unlines              ["2009/1/1 x  ; transaction comment"              ," a  1  ; posting 1 comment"              ," ; posting 1 comment 2"@@ -481,8 +550,11 @@ datep = do   -- hacky: try to ensure precise errors for invalid dates   -- XXX reported error position is not too good-  -- pos <- getPosition-  datestr <- many1 $ choice' [digit, datesepchar]+  -- 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@@ -558,8 +630,8 @@ 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.-postings :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting]-postings = many (try postingp) <?> "postings"+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@@ -573,11 +645,11 @@   many1 spacenonewline   status <- statusp   many spacenonewline-  account <- modifiedaccountname+  account <- modifiedaccountnamep   let (ptype, account') = (accountNamePostingType account, unbracket account)-  amount <- spaceandamountormissing-  massertion <- partialbalanceassertion-  _ <- fixedlotprice+  amount <- spaceandamountormissingp+  massertion <- partialbalanceassertionp+  _ <- fixedlotpricep   many spacenonewline   ctx <- getState   comment <- try followingcommentp <|> (newline >> return "")@@ -653,13 +725,16 @@ #endif  -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.-modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName-modifiedaccountname = do-  a <- accountnamep-  prefix <- getParentAccount-  let prefixed = prefix `joinAccountNames` a+modifiedaccountnamep :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName+modifiedaccountnamep = do+  parent <- getParentAccount   aliases <- getAccountAliases-  return $ accountNameApplyAliases aliases prefixed+  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@@ -686,8 +761,8 @@ -- | Parse whitespace then an amount, with an optional left or right -- currency symbol and optional price, or return the special -- "missing" marker amount.-spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount-spaceandamountormissing =+spaceandamountormissingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount+spaceandamountormissingp =   try (do         many1 spacenonewline         (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt@@ -700,18 +775,18 @@ is' :: (Eq a, Show a) => a -> a -> Assertion a `is'` e = assertEqual e a -test_spaceandamountormissing = do-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18])-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt-    assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt+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 leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount+amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp  #ifdef TESTS test_amountp = do@@ -744,32 +819,32 @@   return $ case sign of Just '-' -> "-"                         _        -> "" -leftsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-leftsymbolamount = do+leftsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount+leftsymbolamountp = do   sign <- signp-  c <- commoditysymbol+  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 <- priceamount+  p <- priceamountp   let applysign = if sign=="-" then negate else id   return $ applysign $ Amount c q p s   <?> "left-symbol amount" -rightsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-rightsymbolamount = do+rightsymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount+rightsymbolamountp = do   (q,prec,mdec,mgrps) <- numberp   sp <- many spacenonewline-  c <- commoditysymbol-  p <- priceamount+  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" -nosymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount-nosymbolamount = do+nosymbolamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount+nosymbolamountp = do   (q,prec,mdec,mgrps) <- numberp-  p <- priceamount+  p <- priceamountp   -- apply the most recently seen default commodity and style to this commodityless amount   defcs <- getDefaultCommodityAndStyle   let (c,s) = case defcs of@@ -778,21 +853,21 @@   return $ Amount c q p s   <?> "no-symbol amount" -commoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String-commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"+commoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String+commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol" -quotedcommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String-quotedcommoditysymbol = do+quotedcommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String+quotedcommoditysymbolp = do   char '"'   s <- many1 $ noneOf ";\n\""   char '"'   return s -simplecommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String-simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)+simplecommoditysymbolp :: Stream [Char] m t => ParsecT [Char] JournalContext m String+simplecommoditysymbolp = many1 (noneOf nonsimplecommoditychars) -priceamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Price-priceamount =+priceamountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Price+priceamountp =     try (do           many spacenonewline           char '@'@@ -807,8 +882,8 @@             return $ UnitPrice a))          <|> return NoPrice -partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)-partialbalanceassertion =+partialbalanceassertionp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)+partialbalanceassertionp =     try (do           many spacenonewline           char '='@@ -828,8 +903,8 @@ --          <|> return Nothing  -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices-fixedlotprice :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount)-fixedlotprice =+fixedlotpricep :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount)+fixedlotpricep =     try (do           many spacenonewline           char '{'@@ -933,33 +1008,33 @@   string "comment" >> many spacenonewline >> newline   go   where-    go = try (string "end comment" >> newline >> return ())+    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 >> (comment <|> (many spacenonewline >> newline >> return ""))+  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 semicoloncomment <|> (newline >> return ""))-     newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))+  do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))+     newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))      return $ unlines $ samelinecomment:newlinecomments -comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-comment = commentStartingWith commentchars+commentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String+commentp = commentStartingWithp commentchars  commentchars :: [Char] commentchars = "#;*" -semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String-semicoloncomment = commentStartingWith ";"+semicoloncommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String+semicoloncommentp = commentStartingWithp ";" -commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String-commentStartingWith cs = do+commentStartingWithp :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String+commentStartingWithp cs = do   -- ptrace "commentStartingWith"   oneOf cs   many spacenonewline@@ -975,23 +1050,23 @@ tagsInCommentLine :: String -> [Tag] tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','   where-    maybetag s = case runParser (tag <* eof) nullctx "" s of+    maybetag s = case runParser (tagp <* eof) nullctx "" s of                   Right t -> Just t                   Left _ -> Nothing -tag = do+tagp = do   -- ptrace "tag"-  n <- tagname-  v <- tagvalue+  n <- tagnamep+  v <- tagvaluep   return (n,v) -tagname = do+tagnamep = do   -- ptrace "tagname"   n <- many1 $ noneOf ": \t"   char ':'   return n -tagvalue = do+tagvaluep = do   -- ptrace "tagvalue"   v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)   return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v@@ -1035,24 +1110,24 @@ tests_Hledger_Read_JournalReader = TestList $ concat [     test_numberp,     test_amountp,-    test_spaceandamountormissing,+    test_spaceandamountormissingp,     test_tagcomment,     test_inlinecomment,     test_comments,     test_ledgerDateSyntaxToTags,     test_postingp,-    test_transaction,+    test_transactionp,     [-   "modifiertransaction" ~: do-     assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings  1\n")+   "modifiertransactionp" ~: do+     assertParse (parseWithCtx nullctx modifiertransactionp "= (some value expr)\n some:postings  1\n") -  ,"periodictransaction" ~: do-     assertParse (parseWithCtx nullctx periodictransaction "~ (some period expr)\n some:postings  1\n")+  ,"periodictransactionp" ~: do+     assertParse (parseWithCtx nullctx periodictransactionp "~ (some period expr)\n some:postings  1\n") -  ,"directive" ~: do-     assertParse (parseWithCtx nullctx directive "!include /some/file.x\n")-     assertParse (parseWithCtx nullctx directive "account some:account\n")-     assertParse (parseWithCtx nullctx (directive >> directive) "!account a\nend\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")@@ -1080,28 +1155,28 @@       assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday       assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday -  ,"defaultyeardirective" ~: do-     assertParse (parseWithCtx nullctx defaultyeardirective "Y 2010\n")-     assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n")+  ,"defaultyeardirectivep" ~: do+     assertParse (parseWithCtx nullctx defaultyeardirectivep "Y 2010\n")+     assertParse (parseWithCtx nullctx defaultyeardirectivep "Y 10001\n") -  ,"historicalpricedirective" ~:-    assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ usd 55)+  ,"marketpricedirectivep" ~:+    assertParseEqual (parseWithCtx nullctx marketpricedirectivep "P 2004/05/01 XYZ $55.00\n") (MarketPrice (parsedate "2004/05/01") "XYZ" $ usd 55) -  ,"ignoredpricecommoditydirective" ~: do-     assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n")+  ,"ignoredpricecommoditydirectivep" ~: do+     assertParse (parseWithCtx nullctx ignoredpricecommoditydirectivep "N $\n") -  ,"defaultcommoditydirective" ~: do-     assertParse (parseWithCtx nullctx defaultcommoditydirective "D $1,000.0\n")+  ,"defaultcommoditydirectivep" ~: do+     assertParse (parseWithCtx nullctx defaultcommoditydirectivep "D $1,000.0\n") -  ,"commodityconversiondirective" ~: do-     assertParse (parseWithCtx nullctx commodityconversiondirective "C 1h = $50.00\n")+  ,"commodityconversiondirectivep" ~: do+     assertParse (parseWithCtx nullctx commodityconversiondirectivep "C 1h = $50.00\n") -  ,"tagdirective" ~: do-     assertParse (parseWithCtx nullctx tagdirective "tag foo \n")+  ,"tagdirectivep" ~: do+     assertParse (parseWithCtx nullctx tagdirectivep "tag foo \n") -  ,"endtagdirective" ~: do-     assertParse (parseWithCtx nullctx endtagdirective "end tag \n")-     assertParse (parseWithCtx nullctx endtagdirective "pop \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")@@ -1109,10 +1184,10 @@     assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c")     assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:") -  ,"leftsymbolamount" ~: do-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")  (usd 1 `withPrecision` 0)-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") (usd (-1) `withPrecision` 0)-    assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1") (usd (-1) `withPrecision` 0)+  ,"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

@@ -60,8 +60,8 @@ import Hledger.Data -- XXX too much reuse ? import Hledger.Read.JournalReader (-  directive, historicalpricedirective, defaultyeardirective, emptyorcommentlinep, datetimep,-  parseJournalWith, modifiedaccountname+  directivep, marketpricedirectivep, defaultyeardirectivep, emptyorcommentlinep, datetimep,+  parseAndFinaliseJournal, modifiedaccountnamep, genericSourcePos   ) import Hledger.Utils @@ -82,32 +82,32 @@ -- format, saving the provided file path and the current time, or give an -- error. parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal-parse _ = parseJournalWith timelogFile+parse _ = parseAndFinaliseJournal timelogfilep -timelogFile :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate, JournalContext)-timelogFile = do items <- many timelogItem-                 eof-                 ctx <- getState-                 return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, ctx)+timelogfilep :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate, JournalContext)+timelogfilep = do items <- many timelogitemp+                  eof+                  ctx <- getState+                  return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, ctx)     where       -- As all ledger line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try-      timelogItem = choice [ directive-                          , liftM (return . addHistoricalPrice) historicalpricedirective-                          , defaultyeardirective+      timelogitemp = choice [ directivep+                          , liftM (return . addMarketPrice) marketpricedirectivep+                          , defaultyeardirectivep                           , emptyorcommentlinep >> return (return id)-                          , liftM (return . addTimeLogEntry)  timelogentry+                          , liftM (return . addTimeLogEntry)  timelogentryp                           ] <?> "timelog entry, or default year or historical price directive"  -- | Parse a timelog entry.-timelogentry :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry-timelogentry = do-  sourcepos <- getPosition+timelogentryp :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry+timelogentryp = do+  sourcepos <- genericSourcePos <$> getPosition   code <- oneOf "bhioO"   many1 spacenonewline   datetime <- datetimep-  account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountname)+  account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountnamep)   description <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> restofline)   return $ TimeLogEntry sourcepos (read [code]) datetime account description 

@@ -10,6 +10,8 @@   BalanceReportItem,   RenderableAccountName,   balanceReport,+  balanceReportValue,+  mixedAmountValue,   flatShowsExclusiveBalance,    -- * Tests@@ -17,7 +19,9 @@ ) where +import Data.List (sort) import Data.Maybe+import Data.Time.Calendar import Test.HUnit  import Hledger.Data@@ -123,6 +127,41 @@ --     items = [(a,a',n, headDef 0 bs) | ((a,a',n), bs) <- mbrrows] --     total = headDef 0 mbrtotals +-- | Convert all the amounts in a single-column balance report to+-- their value on the given date in their default valuation+-- commodities.+balanceReportValue :: Journal -> Day -> BalanceReport -> BalanceReport+balanceReportValue j d r = r'+  where+    (items,total) = r+    r' = ([(n, mixedAmountValue j d a) |(n,a) <- items], mixedAmountValue j d total)++mixedAmountValue :: Journal -> Day -> MixedAmount -> MixedAmount+mixedAmountValue j d (Mixed as) = Mixed $ map (amountValue j d) as++-- | Find the market value of this amount on the given date, in it's+-- default valuation commodity, based on historical prices. If no+-- default valuation commodity can be found, the amount is left+-- unchanged.+amountValue :: Journal -> Day -> Amount -> Amount+amountValue j d a =+  case commodityValue j d (acommodity a) of+    Just v  -> v{aquantity=aquantity v * aquantity a+                ,aprice=aprice a+                }+    Nothing -> a++-- | Find the market value, if known, of one unit of this commodity on+-- the given date, in the commodity in which it has most recently been+-- market-priced (ie the commodity mentioned in the most recent+-- applicable historical price directive before this date).+commodityValue :: Journal -> Day -> Commodity -> Maybe Amount+commodityValue j d c+    | null applicableprices = Nothing+    | otherwise             = Just $ mpamount $ last applicableprices+  where+    applicableprices = [p | p <- sort $ jmarketprices j, mpcommodity p == c, mpdate p <= d]+ tests_balanceReport =   let     (opts,journal) `gives` r = do@@ -131,7 +170,7 @@           showw (acct,amt) = (acct, showMixedAmountDebug amt)       assertEqual "items" (map showw eitems) (map showw aitems)       assertEqual "total" (showMixedAmountDebug etotal) (showMixedAmountDebug atotal)-    usd0 = nullamt{acommodity="$"}+    usd0 = usd 0   in [     "balanceReport with no args on null journal" ~: do@@ -329,6 +368,7 @@          nulljournal          {jtxns = [            txnTieKnot $ Transaction {+             tindex=0,              tsourcepos=nullsourcepos,              tdate=parsedate "2008/01/01",              tdate2=Just $ parsedate "2009/01/01",

@@ -8,7 +8,8 @@ module Hledger.Reports.MultiBalanceReports (   MultiBalanceReport(..),   MultiBalanceReportRow,-  multiBalanceReport+  multiBalanceReport,+  multiBalanceReportValue    -- -- * Tests   -- tests_Hledger_Reports_MultiBalanceReport@@ -18,6 +19,7 @@ import Data.List import Data.Maybe import Data.Ord+import Data.Time.Calendar import Safe -- import Test.HUnit @@ -176,4 +178,17 @@        dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s)  -- add prefix in this function's debug output       -- dbg1 = const id  -- exclude this function from debug output++-- | Convert all the amounts in a multi-column balance report to their+-- value on the given date in their default valuation commodities+-- (which are determined as of that date, not the report interval dates).+multiBalanceReportValue :: Journal -> Day -> MultiBalanceReport -> MultiBalanceReport+multiBalanceReportValue j d r = r'+  where+    MultiBalanceReport (spans, rows, (coltotals, rowtotaltotal, rowavgtotal)) = r+    r' = MultiBalanceReport+         (spans,+          [(n, map convert rowamts, convert rowtotal, convert rowavg) | (n, rowamts, rowtotal, rowavg) <- rows],+          (map convert coltotals, convert rowtotaltotal, convert rowavgtotal))+    convert = mixedAmountValue j d 

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+{-# LANGUAGE CPP, RecordWildCards, DeriveDataTypeable #-} {-|  Options common to most hledger reports.@@ -12,6 +12,7 @@   FormatStr,   defreportopts,   rawOptsToReportOpts,+  checkReportOpts,   flat_,   tree_,   dateSpanFromOpts,@@ -30,6 +31,9 @@ where  import Data.Data (Data)+#if !MIN_VERSION_base(4,8,0)+import Data.Functor.Compat ((<$>))+#endif import Data.Typeable (Typeable) import Data.Time.Calendar import System.Console.CmdArgs.Default  -- some additional default stuff@@ -88,6 +92,7 @@     ,drop_           :: Int     ,row_total_      :: Bool     ,no_total_       :: Bool+    ,value_          :: Bool  } deriving (Show, Data, Typeable)  instance Default ReportOpts where def = defreportopts@@ -121,9 +126,10 @@     def     def     def+    def  rawOptsToReportOpts :: RawOpts -> IO ReportOpts-rawOptsToReportOpts rawopts = do+rawOptsToReportOpts rawopts = checkReportOpts <$> do   d <- getCurrentDay   return defreportopts{      begin_       = maybesmartdateopt d "begin" rawopts@@ -144,7 +150,7 @@     ,monthly_     = boolopt "monthly" rawopts     ,quarterly_   = boolopt "quarterly" rawopts     ,yearly_      = boolopt "yearly" rawopts-    ,format_      = maybestringopt "format" rawopts+    ,format_      = maybestringopt "format" rawopts -- XXX move to CliOpts or move validation from Cli.CliOptions to here     ,query_       = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right     ,average_     = boolopt "average" rawopts     ,related_     = boolopt "related" rawopts@@ -153,7 +159,16 @@     ,drop_        = intopt "drop" rawopts     ,row_total_   = boolopt "row-total" rawopts     ,no_total_    = boolopt "no-total" rawopts+    ,value_       = boolopt "value" rawopts     }++-- | Do extra validation of opts, raising an error if there is trouble.+checkReportOpts :: ReportOpts -> ReportOpts+checkReportOpts ropts@ReportOpts{..} =+  either optserror (const ropts) $ do+    case depth_ of+      Just d | d < 0 -> Left "--depth should have a positive number"+      _              -> Right ()  accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt rawopts =

@@ -11,6 +11,8 @@ module Hledger.Reports.TransactionsReports (   TransactionsReport,   TransactionsReportItem,+  AccountTransactionsReport,+  AccountTransactionsReportItem,   triOrigTransaction,   triDate,   triAmount,@@ -78,15 +80,16 @@  -- | An account transactions report represents transactions affecting -- a particular account (or possibly several accounts, but we don't--- use that). It is used by hledger-web's account register view, where--- we want to show one row per journal transaction, with:+-- use that). It is used by hledger-web's (and hledger-ui's) account+-- register view, where we want to show one row per journal+-- transaction, with: -- -- - the total increase/decrease to the current account -- -- - the names of the other account(s) posted to/from ----- - transaction dates adjusted to the date of the earliest posting to---   the current account, if those postings have their own dates+-- - transaction dates, adjusted to the date of the earliest posting to+--   the current account if those postings have their own dates -- -- Currently, reporting intervals are not supported, and report items -- are most recent first.@@ -198,8 +201,14 @@ --       (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps  -- | Generate a simplified summary of some postings' accounts.+-- To reduce noise, if there are both real and virtual postings, show only the real ones. summarisePostingAccounts :: [Posting] -> String-summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount+summarisePostingAccounts ps =+  (intercalate ", " . map accountSummarisedName . nub . map paccount) displayps+  where+    realps = filter isReal ps+    displayps | null realps = ps+              | otherwise   = realps  filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}

@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} {-|  Standard imports and utilities which are useful everywhere, or needed low@@ -20,7 +19,11 @@                           ---- all of this one:                           module Hledger.Utils,                           module Hledger.Utils.Debug,+                          module Hledger.Utils.Parse,                           module Hledger.Utils.Regex,+                          module Hledger.Utils.String,+                          module Hledger.Utils.Test,+                          module Hledger.Utils.Tree,                           -- Debug.Trace.trace,                           -- module Data.PPrint,                           -- module Hledger.Utils.UTF8IOCompat@@ -30,205 +33,29 @@ where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Char-import Data.List-import qualified Data.Map as M+-- import Data.Char+-- import Data.List -- import Data.Maybe -- import Data.PPrint import Data.Time.Clock import Data.Time.LocalTime-import Data.Tree import System.Directory (getHomeDirectory) import System.FilePath((</>), isRelative) import System.IO-import Test.HUnit-import Text.Parsec-import Text.Printf+-- import Text.Printf -- import qualified Data.Map as Map  import Hledger.Utils.Debug+import Hledger.Utils.Parse import Hledger.Utils.Regex+import Hledger.Utils.String+import Hledger.Utils.Test+import Hledger.Utils.Tree -- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) -- import Hledger.Utils.UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') --- strings -lowercase, uppercase :: String -> String-lowercase = map toLower-uppercase = map toUpper---- | Remove leading and trailing whitespace.-strip :: String -> String-strip = lstrip . rstrip---- | Remove leading whitespace.-lstrip :: String -> String-lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ?---- | Remove trailing whitespace.-rstrip :: String -> String-rstrip = reverse . lstrip . reverse---- | Remove trailing newlines/carriage returns.-chomp :: String -> String-chomp = reverse . dropWhile (`elem` "\r\n") . reverse--stripbrackets :: String -> String-stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String--elideLeft :: Int -> String -> String-elideLeft width s =-    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s--elideRight :: Int -> String -> String-elideRight width s =-    if length s > width then take (width - 2) s ++ ".." else s--underline :: String -> String-underline s = s' ++ replicate (length s) '-' ++ "\n"-    where s'-            | last s == '\n' = s-            | otherwise = s ++ "\n"---- | Wrap a string in double quotes, and \-prefix any embedded single--- quotes, if it contains whitespace and is not already single- or--- double-quoted.-quoteIfSpaced :: String -> String-quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s-                | not $ any (`elem` s) whitespacechars = s-                | otherwise = "'"++escapeSingleQuotes s++"'"---- | Double-quote this string if it contains whitespace, single quotes--- or double-quotes, escaping the quotes as needed.-quoteIfNeeded :: String -> String-quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""-                | otherwise = s---- | Single-quote this string if it contains whitespace or double-quotes.--- No good for strings containing single quotes.-singleQuoteIfNeeded :: String -> String-singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"-                      | otherwise = s--quotechars, whitespacechars :: [Char]-quotechars      = "'\""-whitespacechars = " \t\n\r"--escapeDoubleQuotes :: String -> String-escapeDoubleQuotes = regexReplace "\"" "\""--escapeSingleQuotes :: String -> String-escapeSingleQuotes = regexReplace "'" "\'"--escapeQuotes :: String -> String-escapeQuotes = regexReplace "([\"'])" "\\1"---- | Quote-aware version of words - don't split on spaces which are inside quotes.--- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.-words' :: String -> [String]-words' "" = []-words' s  = map stripquotes $ fromparse $ parsewith p s-    where-      p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline-             -- eof-             return ss-      pattern = many (noneOf whitespacechars)-      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")-      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")---- | Quote-aware version of unwords - single-quote strings which contain whitespace-unwords' :: [String] -> String-unwords' = unwords . map quoteIfNeeded---- | Strip one matching pair of single or double quotes on the ends of a string.-stripquotes :: String -> String-stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s--isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''-isSingleQuoted _ = False--isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'-isDoubleQuoted _ = False--unbracket :: String -> String-unbracket s-    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s-    | otherwise = s---- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.-concatTopPadded :: [String] -> String-concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = replicate (difforzero h (length ls)) "" ++ ls-      xpad ls = map (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.-concatBottomPadded :: [String] -> String-concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = ls ++ replicate (difforzero h (length ls)) ""-      xpad ls = map (padright w) ls where w | null ls = 0-                                            | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Compose strings vertically and right-aligned.-vConcatRightAligned :: [String] -> String-vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss-    where-      showfixedwidth = printf (printf "%%%ds" width)-      width = maximum $ map length ss---- | Convert a multi-line string to a rectangular string top-padded to the specified height.-padtop :: Int -> String -> String-padtop h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = replicate (difforzero h sh) "" ++ ls-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.-padbottom :: Int -> String -> String-padbottom h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = ls ++ replicate (difforzero h sh) ""-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string left-padded to the specified width.-padleft :: Int -> String -> String-padleft w "" = concat $ replicate w " "-padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s---- | Convert a multi-line string to a rectangular string right-padded to the specified width.-padright :: Int -> String -> String-padright w "" = concat $ replicate w " "-padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s---- | Clip a multi-line string to the specified width and height from the top left.-cliptopleft :: Int -> Int -> String -> String-cliptopleft w h = intercalate "\n" . take h . map (take w) . lines---- | Clip and pad a multi-line string to fill the specified width and height.-fitto :: Int -> Int -> String -> String-fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline-    where-      rows = map (fit w) $ lines s-      fit w = take w . (++ repeat ' ')-      blankline = replicate w ' '- -- tuples  first3  (x,_,_) = x@@ -246,10 +73,12 @@ fourth5 (_,_,_,x,_) = x fifth5  (_,_,_,_,x) = x --- math--difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]+first6  (x,_,_,_,_,_) = x+second6 (_,x,_,_,_,_) = x+third6  (_,_,x,_,_,_) = x+fourth6 (_,_,_,x,_,_) = x+fifth6  (_,_,_,_,x,_) = x+sixth6  (_,_,_,_,_,x) = x  -- lists @@ -263,120 +92,6 @@     split es = let (first,rest) = break (x==) es                in first : splitAtElement x rest --- trees---- standard tree helpers--root = rootLabel-subs = subForest-branches = subForest---- | List just the leaf nodes of a tree-leaves :: Tree a -> [a]-leaves (Node v []) = [v]-leaves (Node _ branches) = concatMap leaves branches---- | get the sub-tree rooted at the first (left-most, depth-first) occurrence--- of the specified node value-subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)-subtreeat v t-    | root t == v = Just t-    | otherwise = subtreeinforest v $ subs t---- | get the sub-tree for the specified node value in the first tree in--- forest in which it occurs.-subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)-subtreeinforest _ [] = Nothing-subtreeinforest v (t:ts) = case (subtreeat v t) of-                             Just t' -> Just t'-                             Nothing -> subtreeinforest v ts---- | remove all nodes past a certain depth-treeprune :: Int -> Tree a -> Tree a-treeprune 0 t = Node (root t) []-treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)---- | apply f to all tree nodes-treemap :: (a -> b) -> Tree a -> Tree b-treemap f t = Node (f $ root t) (map (treemap f) $ branches t)---- | remove all subtrees whose nodes do not fulfill predicate-treefilter :: (a -> Bool) -> Tree a -> Tree a-treefilter f t = Node-                 (root t)-                 (map (treefilter f) $ filter (treeany f) $ branches t)---- | is predicate true in any node of tree ?-treeany :: (a -> Bool) -> Tree a -> Bool-treeany f t = f (root t) || any (treeany f) (branches t)---- treedrop -- remove the leaves which do fulfill predicate.--- treedropall -- do this repeatedly.---- | show a compact ascii representation of a tree-showtree :: Show a => Tree a -> String-showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show---- | show a compact ascii representation of a forest-showforest :: Show a => Forest a -> String-showforest = concatMap showtree----- | An efficient-to-build tree suggested by Cale Gibbard, probably--- better than accountNameTreeFrom.-newtype FastTree a = T (M.Map a (FastTree a))-  deriving (Show, Eq, Ord)--emptyTree = T M.empty--mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a-mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')--treeFromPath :: [a] -> FastTree a-treeFromPath []     = T M.empty-treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs))--treeFromPaths :: (Ord a) => [[a]] -> FastTree a-treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath----- parsing---- | Backtracking choice, use this when alternatives share a prefix.--- Consumes no input if all choices fail.-choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a-choice' = choice . map Text.Parsec.try--parsewith :: Parsec [Char] () a -> String -> Either ParseError a-parsewith p = runParser p () ""--parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)-parseWithCtx ctx p = runParserT p ctx ""--fromparse :: Either ParseError a -> a-fromparse = either parseerror id--parseerror :: ParseError -> a-parseerror e = error' $ showParseError e--showParseError :: ParseError -> String-showParseError e = "parse error at " ++ show e--showDateParseError :: ParseError -> String-showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)--nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char-nonspace = satisfy (not . isSpace)--spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char-spacenonewline = satisfy (`elem` " \v\f\t")--restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String-restofline = anyChar `manyTill` newline--eolof :: (Stream [Char] m Char) => ParsecT [Char] st m ()-eolof = (newline >> return ()) <|> eof- -- time  getCurrentLocalTime :: IO LocalTime@@ -385,44 +100,6 @@   tz <- getCurrentTimeZone   return $ utcToLocalTime tz t --- testing---- | Get a Test's label, or the empty string.-testName :: Test -> String-testName (TestLabel n _) = n-testName _ = ""---- | Flatten a Test containing TestLists into a list of single tests.-flattenTests :: Test -> [Test]-flattenTests (TestLabel _ t@(TestList _)) = flattenTests t-flattenTests (TestList ts) = concatMap flattenTests ts-flattenTests t = [t]---- | Filter TestLists in a Test, recursively, preserving the structure.-filterTests :: (Test -> Bool) -> Test -> Test-filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts)-filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts-filterTests _ t = t---- | Simple way to assert something is some expected value, with no label.-is :: (Eq a, Show a) => a -> a -> Assertion-a `is` e = assertEqual "" e a---- | Assert a parse result is successful, printing the parse error on failure.-assertParse :: (Either ParseError a) -> Assertion-assertParse parse = either (assertFailure.show) (const (return ())) parse---- | Assert a parse result is successful, printing the parse error on failure.-assertParseFailure :: (Either ParseError a) -> Assertion-assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse---- | Assert a parse result is some expected value, printing the parse error on failure.-assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion-assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse--printParseError :: (Show a) => a -> IO ()-printParseError e = do putStr "parse error at "; print e- -- misc  isLeft :: Either a b -> Bool@@ -457,3 +134,8 @@   h <- openFile name ReadMode   hSetNewlineMode h universalNewlineMode   hGetContents h++-- | Total version of maximum, for integral types, giving 0 for an empty list.+maximum' :: Integral a => [a] -> a+maximum' [] = 0+maximum' xs = maximum xs

@@ -71,7 +71,7 @@ -- a higher value (note: not @--debug N@ for some reason).  This uses -- unsafePerformIO and can be accessed from anywhere and before normal -- command-line processing. After command-line processing, it is also--- available as the @debug_@ field of 'Hledger.Cli.Options.CliOpts'.+-- available as the @debug_@ field of 'Hledger.Cli.CliOptions.CliOpts'. -- {-# OPTIONS_GHC -fno-cse #-}  -- {-# NOINLINE debugLevel #-} debugLevel :: Int

@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+module Hledger.Utils.Parse where++import Data.Char+import Data.List+import Text.Parsec+import Text.Printf++import Hledger.Utils.UTF8IOCompat (error')++-- | Backtracking choice, use this when alternatives share a prefix.+-- Consumes no input if all choices fail.+choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a+choice' = choice . map Text.Parsec.try++parsewith :: Parsec [Char] () a -> String -> Either ParseError a+parsewith p = runParser p () ""++parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)+parseWithCtx ctx p = runParserT p ctx ""++fromparse :: Either ParseError a -> a+fromparse = either parseerror id++parseerror :: ParseError -> a+parseerror e = error' $ showParseError e++showParseError :: ParseError -> String+showParseError e = "parse error at " ++ show e++showDateParseError :: ParseError -> String+showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)++nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char+nonspace = satisfy (not . isSpace)++spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char+spacenonewline = satisfy (`elem` " \v\f\t")++restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String+restofline = anyChar `manyTill` newline++eolof :: (Stream [Char] m Char) => ParsecT [Char] st m ()+eolof = (newline >> return ()) <|> eof+

@@ -17,8 +17,14 @@  - have simple monomorphic types -- work with strings+- work with simple strings +Regex strings are automatically compiled into regular expressions the+first time they are seen, and these are cached. If you use a huge+number of unique regular expressions this might lead to increased+memory usage. Several functions have memoised variants (*Memo), which+also trade space for time.+ Current limitations:  - (?i) and similar are not supported@@ -34,6 +40,8 @@   ,regexMatchesCI   ,regexReplace   ,regexReplaceCI+  ,regexReplaceMemo+  ,regexReplaceCIMemo   ,regexReplaceBy   ,regexReplaceByCI   )@@ -42,6 +50,7 @@ import Data.Array import Data.Char import Data.List (foldl')+import Data.MemoUgly (memo) import Text.Regex.TDFA (   Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt,   makeRegexOpts, AllMatches(getAllMatches), match, (=~), MatchText@@ -60,10 +69,10 @@ -- | Convert our string-based regexps to real ones. Can fail if the -- string regexp is malformed. toRegex :: Regexp -> Regex-toRegex = makeRegexOpts compOpt execOpt+toRegex = memo (makeRegexOpts compOpt execOpt)  toRegexCI :: Regexp -> Regex-toRegexCI = makeRegexOpts compOpt{caseSensitive=False} execOpt+toRegexCI = memo (makeRegexOpts compOpt{caseSensitive=False} execOpt)  compOpt :: CompOption compOpt = defaultCompOpt@@ -95,6 +104,14 @@  regexReplaceCI :: Regexp -> Replacement -> String -> String regexReplaceCI re = replaceRegex (toRegexCI re)++-- | A memoising version of regexReplace. Caches the result for each+-- search pattern, replacement pattern, target string tuple.+regexReplaceMemo :: Regexp -> Replacement -> String -> String+regexReplaceMemo re repl = memo (regexReplace re repl)++regexReplaceCIMemo :: Regexp -> Replacement -> String -> String+regexReplaceCIMemo re repl = memo (regexReplaceCI re repl)  -- 

@@ -0,0 +1,392 @@+-- | String formatting helpers, starting to get a bit out of control.++module Hledger.Utils.String (+ -- * misc+ lowercase,+ uppercase,+ underline,+ stripbrackets,+ unbracket,+ -- quoting+ quoteIfSpaced,+ quoteIfNeeded,+ singleQuoteIfNeeded,+ -- quotechars,+ -- whitespacechars,+ escapeDoubleQuotes,+ escapeSingleQuotes,+ escapeQuotes,+ words',+ unwords',+ stripquotes,+ isSingleQuoted,+ isDoubleQuoted,+ -- * single-line layout+ strip,+ lstrip,+ rstrip,+ chomp,+ elideLeft,+ elideRight,+ formatString,+ -- * multi-line layout+ concatTopPadded,+ concatBottomPadded,+ concatOneLine,+ vConcatLeftAligned,+ vConcatRightAligned,+ padtop,+ padbottom,+ padleft,+ padright,+ cliptopleft,+ fitto,+ -- * wide-character-aware layout+ strWidth,+ takeWidth,+ fitString,+ fitStringMulti,+ padLeftWide,+ padRightWide+ ) where+++import Data.Char+import Data.List+import Text.Parsec+import Text.Printf (printf)++import Hledger.Utils.Parse+import Hledger.Utils.Regex++lowercase, uppercase :: String -> String+lowercase = map toLower+uppercase = map toUpper++-- | Remove leading and trailing whitespace.+strip :: String -> String+strip = lstrip . rstrip++-- | Remove leading whitespace.+lstrip :: String -> String+lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ?++-- | Remove trailing whitespace.+rstrip :: String -> String+rstrip = reverse . lstrip . reverse++-- | Remove trailing newlines/carriage returns.+chomp :: String -> String+chomp = reverse . dropWhile (`elem` "\r\n") . reverse++stripbrackets :: String -> String+stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String++elideLeft :: Int -> String -> String+elideLeft width s =+    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s++elideRight :: Int -> String -> String+elideRight width s =+    if length s > width then take (width - 2) s ++ ".." else s++-- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.+-- Works on multi-line strings too (but will rewrite non-unix line endings).+formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String+formatString leftJustified minwidth maxwidth s = intercalate "\n" $ map (printf fmt) $ lines s+    where+      justify = if leftJustified then "-" else ""+      minwidth' = maybe "" show minwidth+      maxwidth' = maybe "" (("."++).show) maxwidth+      fmt = "%" ++ justify ++ minwidth' ++ maxwidth' ++ "s"++underline :: String -> String+underline s = s' ++ replicate (length s) '-' ++ "\n"+    where s'+            | last s == '\n' = s+            | otherwise = s ++ "\n"++-- | Wrap a string in double quotes, and \-prefix any embedded single+-- quotes, if it contains whitespace and is not already single- or+-- double-quoted.+quoteIfSpaced :: String -> String+quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s+                | not $ any (`elem` s) whitespacechars = s+                | otherwise = "'"++escapeSingleQuotes s++"'"++-- | Double-quote this string if it contains whitespace, single quotes+-- or double-quotes, escaping the quotes as needed.+quoteIfNeeded :: String -> String+quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""+                | otherwise = s++-- | Single-quote this string if it contains whitespace or double-quotes.+-- No good for strings containing single quotes.+singleQuoteIfNeeded :: String -> String+singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"+                      | otherwise = s++quotechars, whitespacechars :: [Char]+quotechars      = "'\""+whitespacechars = " \t\n\r"++escapeDoubleQuotes :: String -> String+escapeDoubleQuotes = regexReplace "\"" "\""++escapeSingleQuotes :: String -> String+escapeSingleQuotes = regexReplace "'" "\'"++escapeQuotes :: String -> String+escapeQuotes = regexReplace "([\"'])" "\\1"++-- | Quote-aware version of words - don't split on spaces which are inside quotes.+-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.+words' :: String -> [String]+words' "" = []+words' s  = map stripquotes $ fromparse $ parsewith p s+    where+      p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline+             -- eof+             return ss+      pattern = many (noneOf whitespacechars)+      singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")+      doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")++-- | Quote-aware version of unwords - single-quote strings which contain whitespace+unwords' :: [String] -> String+unwords' = unwords . map quoteIfNeeded++-- | Strip one matching pair of single or double quotes on the ends of a string.+stripquotes :: String -> String+stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s++isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''+isSingleQuoted _ = False++isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'+isDoubleQuoted _ = False++unbracket :: String -> String+unbracket s+    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s+    | otherwise = s++-- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.+-- Treats wide characters as double width.+concatTopPadded :: [String] -> String+concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded+    where+      lss = map lines strs+      h = maximum $ map length lss+      ypad ls = replicate (difforzero h (length ls)) "" ++ ls+      xpad ls = map (padLeftWide w) ls where w | null ls = 0+                                               | otherwise = maximum $ map strWidth ls+      padded = map (xpad . ypad) lss++-- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.+-- Treats wide characters as double width.+concatBottomPadded :: [String] -> String+concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded+    where+      lss = map lines strs+      h = maximum $ map length lss+      ypad ls = ls ++ replicate (difforzero h (length ls)) ""+      xpad ls = map (padRightWide w) ls where w | null ls = 0+                                                | otherwise = maximum $ map strWidth ls+      padded = map (xpad . ypad) lss+++-- | Join multi-line strings horizontally, after compressing each of+-- them to a single line with a comma and space between each original line.+concatOneLine :: [String] -> String+concatOneLine strs = concat $ map ((intercalate ", ").lines) strs++-- | Join strings vertically, left-aligned and right-padded.+vConcatLeftAligned :: [String] -> String+vConcatLeftAligned ss = intercalate "\n" $ map showfixedwidth ss+    where+      showfixedwidth = printf (printf "%%-%ds" width)+      width = maximum $ map length ss++-- | Join strings vertically, right-aligned and left-padded.+vConcatRightAligned :: [String] -> String+vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss+    where+      showfixedwidth = printf (printf "%%%ds" width)+      width = maximum $ map length ss++-- | Convert a multi-line string to a rectangular string top-padded to the specified height.+padtop :: Int -> String -> String+padtop h s = intercalate "\n" xpadded+    where+      ls = lines s+      sh = length ls+      sw | null ls = 0+         | otherwise = maximum $ map length ls+      ypadded = replicate (difforzero h sh) "" ++ ls+      xpadded = map (padleft sw) ypadded++-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.+padbottom :: Int -> String -> String+padbottom h s = intercalate "\n" xpadded+    where+      ls = lines s+      sh = length ls+      sw | null ls = 0+         | otherwise = maximum $ map length ls+      ypadded = ls ++ replicate (difforzero h sh) ""+      xpadded = map (padleft sw) ypadded++difforzero :: (Num a, Ord a) => a -> a -> a+difforzero a b = maximum [(a - b), 0]++-- | Convert a multi-line string to a rectangular string left-padded to the specified width.+-- Treats wide characters as double width.+padleft :: Int -> String -> String+padleft w "" = concat $ replicate w " "+padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s++-- | Convert a multi-line string to a rectangular string right-padded to the specified width.+-- Treats wide characters as double width.+padright :: Int -> String -> String+padright w "" = concat $ replicate w " "+padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s++-- | Clip a multi-line string to the specified width and height from the top left.+cliptopleft :: Int -> Int -> String -> String+cliptopleft w h = intercalate "\n" . take h . map (take w) . lines++-- | Clip and pad a multi-line string to fill the specified width and height.+fitto :: Int -> Int -> String -> String+fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline+    where+      rows = map (fit w) $ lines s+      fit w = take w . (++ repeat ' ')+      blankline = replicate w ' '++-- Functions below treat wide (eg CJK) characters as double-width.++-- | General-purpose wide-char-aware single-line string layout function.+-- It can left- or right-pad a short string to a minimum width.+-- It can left- or right-clip a long string to a maximum width, optionally inserting an ellipsis (the third argument).+-- It clips and pads on the right when the fourth argument is true, otherwise on the left.+-- It treats wide characters as double width.+fitString :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String+fitString mminwidth mmaxwidth ellipsify rightside s = (clip . pad) s+  where+    clip :: String -> String+    clip s =+      case mmaxwidth of+        Just w+          | strWidth s > w ->+            case rightside of+              True  -> takeWidth (w - length ellipsis) s ++ ellipsis+              False -> ellipsis ++ reverse (takeWidth (w - length ellipsis) $ reverse s)+          | otherwise -> s+          where+            ellipsis = if ellipsify then ".." else ""+        Nothing -> s+    pad :: String -> String+    pad s =+      case mminwidth of+        Just w+          | sw < w ->+            case rightside of+              True  -> s ++ replicate (w - sw) ' '+              False -> replicate (w - sw) ' ' ++ s+          | otherwise -> s+        Nothing -> s+      where sw = strWidth s++-- | A version of fitString that works on multi-line strings,+-- separate for now to avoid breakage.+-- This will rewrite any line endings to unix newlines.+fitStringMulti :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String+fitStringMulti mminwidth mmaxwidth ellipsify rightside s =+  (intercalate "\n" . map (fitString mminwidth mmaxwidth ellipsify rightside) . lines) s++-- | Left-pad a string to the specified width.+-- Treats wide characters as double width.+-- Works on multi-line strings too (but will rewrite non-unix line endings).+padLeftWide :: Int -> String -> String+padLeftWide w "" = replicate w ' '+padLeftWide w s  = intercalate "\n" $ map (fitString (Just w) Nothing False False) $ lines s+-- XXX not yet replaceable by+-- padLeftWide w = fitStringMulti (Just w) Nothing False False++-- | Right-pad a string to the specified width.+-- Treats wide characters as double width.+-- Works on multi-line strings too (but will rewrite non-unix line endings).+padRightWide :: Int -> String -> String+padRightWide w "" = replicate w ' '+padRightWide w s  = intercalate "\n" $ map (fitString (Just w) Nothing False True) $ lines s+-- XXX not yet replaceable by+-- padRightWide w = fitStringMulti (Just w) Nothing False True++-- | Double-width-character-aware string truncation. Take as many+-- characters as possible from a string without exceeding the+-- specified width. Eg takeWidth 3 "りんご" = "り".+takeWidth :: Int -> String -> String+takeWidth _ ""     = ""+takeWidth 0 _      = ""+takeWidth w (c:cs) | cw <= w   = c:takeWidth (w-cw) cs+                   | otherwise = ""+  where cw = charWidth c++-- from Pandoc (copyright John MacFarlane, GPL)+-- see also http://unicode.org/reports/tr11/#Description++-- | Calculate the designated render width of a string, taking into+-- account wide characters and line breaks (the longest line within a+-- multi-line string determines the width ).+strWidth :: String -> Int+strWidth "" = 0+strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s++-- | Get the designated render width of a character: 0 for a combining+-- character, 1 for a regular character, 2 for a wide character.+-- (Wide characters are rendered as exactly double width in apps and+-- fonts that support it.) (From Pandoc.)+charWidth :: Char -> Int+charWidth c =+  case c of+      _ | c <  '\x0300'                    -> 1+        | c >= '\x0300' && c <= '\x036F'   -> 0  -- combining+        | c >= '\x0370' && c <= '\x10FC'   -> 1+        | c >= '\x1100' && c <= '\x115F'   -> 2+        | c >= '\x1160' && c <= '\x11A2'   -> 1+        | c >= '\x11A3' && c <= '\x11A7'   -> 2+        | c >= '\x11A8' && c <= '\x11F9'   -> 1+        | c >= '\x11FA' && c <= '\x11FF'   -> 2+        | c >= '\x1200' && c <= '\x2328'   -> 1+        | c >= '\x2329' && c <= '\x232A'   -> 2+        | c >= '\x232B' && c <= '\x2E31'   -> 1+        | c >= '\x2E80' && c <= '\x303E'   -> 2+        | c == '\x303F'                    -> 1+        | c >= '\x3041' && c <= '\x3247'   -> 2+        | c >= '\x3248' && c <= '\x324F'   -> 1 -- ambiguous+        | c >= '\x3250' && c <= '\x4DBF'   -> 2+        | c >= '\x4DC0' && c <= '\x4DFF'   -> 1+        | c >= '\x4E00' && c <= '\xA4C6'   -> 2+        | c >= '\xA4D0' && c <= '\xA95F'   -> 1+        | c >= '\xA960' && c <= '\xA97C'   -> 2+        | c >= '\xA980' && c <= '\xABF9'   -> 1+        | c >= '\xAC00' && c <= '\xD7FB'   -> 2+        | c >= '\xD800' && c <= '\xDFFF'   -> 1+        | c >= '\xE000' && c <= '\xF8FF'   -> 1 -- ambiguous+        | c >= '\xF900' && c <= '\xFAFF'   -> 2+        | c >= '\xFB00' && c <= '\xFDFD'   -> 1+        | c >= '\xFE00' && c <= '\xFE0F'   -> 1 -- ambiguous+        | c >= '\xFE10' && c <= '\xFE19'   -> 2+        | c >= '\xFE20' && c <= '\xFE26'   -> 1+        | c >= '\xFE30' && c <= '\xFE6B'   -> 2+        | c >= '\xFE70' && c <= '\xFEFF'   -> 1+        | c >= '\xFF01' && c <= '\xFF60'   -> 2+        | c >= '\xFF61' && c <= '\x16A38'  -> 1+        | c >= '\x1B000' && c <= '\x1B001' -> 2+        | c >= '\x1D000' && c <= '\x1F1FF' -> 1+        | c >= '\x1F200' && c <= '\x1F251' -> 2+        | c >= '\x1F300' && c <= '\x1F773' -> 1+        | c >= '\x20000' && c <= '\x3FFFD' -> 2+        | otherwise                        -> 1+

@@ -0,0 +1,41 @@+module Hledger.Utils.Test where++import Test.HUnit+import Text.Parsec++-- | Get a Test's label, or the empty string.+testName :: Test -> String+testName (TestLabel n _) = n+testName _ = ""++-- | Flatten a Test containing TestLists into a list of single tests.+flattenTests :: Test -> [Test]+flattenTests (TestLabel _ t@(TestList _)) = flattenTests t+flattenTests (TestList ts) = concatMap flattenTests ts+flattenTests t = [t]++-- | Filter TestLists in a Test, recursively, preserving the structure.+filterTests :: (Test -> Bool) -> Test -> Test+filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts)+filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts+filterTests _ t = t++-- | Simple way to assert something is some expected value, with no label.+is :: (Eq a, Show a) => a -> a -> Assertion+a `is` e = assertEqual "" e a++-- | Assert a parse result is successful, printing the parse error on failure.+assertParse :: (Either ParseError a) -> Assertion+assertParse parse = either (assertFailure.show) (const (return ())) parse++-- | Assert a parse result is successful, printing the parse error on failure.+assertParseFailure :: (Either ParseError a) -> Assertion+assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse++-- | Assert a parse result is some expected value, printing the parse error on failure.+assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion+assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse++printParseError :: (Show a) => a -> IO ()+printParseError e = do putStr "parse error at "; print e+

@@ -0,0 +1,87 @@+module Hledger.Utils.Tree where++-- import Data.Char+import Data.List (foldl')+import qualified Data.Map as M+import Data.Tree+-- import Text.Parsec+-- import Text.Printf++import Hledger.Utils.Regex+-- import Hledger.Utils.UTF8IOCompat (error')++-- standard tree helpers++root = rootLabel+subs = subForest+branches = subForest++-- | List just the leaf nodes of a tree+leaves :: Tree a -> [a]+leaves (Node v []) = [v]+leaves (Node _ branches) = concatMap leaves branches++-- | get the sub-tree rooted at the first (left-most, depth-first) occurrence+-- of the specified node value+subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)+subtreeat v t+    | root t == v = Just t+    | otherwise = subtreeinforest v $ subs t++-- | get the sub-tree for the specified node value in the first tree in+-- forest in which it occurs.+subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)+subtreeinforest _ [] = Nothing+subtreeinforest v (t:ts) = case (subtreeat v t) of+                             Just t' -> Just t'+                             Nothing -> subtreeinforest v ts++-- | remove all nodes past a certain depth+treeprune :: Int -> Tree a -> Tree a+treeprune 0 t = Node (root t) []+treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)++-- | apply f to all tree nodes+treemap :: (a -> b) -> Tree a -> Tree b+treemap f t = Node (f $ root t) (map (treemap f) $ branches t)++-- | remove all subtrees whose nodes do not fulfill predicate+treefilter :: (a -> Bool) -> Tree a -> Tree a+treefilter f t = Node+                 (root t)+                 (map (treefilter f) $ filter (treeany f) $ branches t)++-- | is predicate true in any node of tree ?+treeany :: (a -> Bool) -> Tree a -> Bool+treeany f t = f (root t) || any (treeany f) (branches t)++-- treedrop -- remove the leaves which do fulfill predicate.+-- treedropall -- do this repeatedly.++-- | show a compact ascii representation of a tree+showtree :: Show a => Tree a -> String+showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show++-- | show a compact ascii representation of a forest+showforest :: Show a => Forest a -> String+showforest = concatMap showtree+++-- | An efficient-to-build tree suggested by Cale Gibbard, probably+-- better than accountNameTreeFrom.+newtype FastTree a = T (M.Map a (FastTree a))+  deriving (Show, Eq, Ord)++emptyTree = T M.empty++mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a+mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')++treeFromPath :: [a] -> FastTree a+treeFromPath []     = T M.empty+treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs))++treeFromPaths :: (Ord a) => [[a]] -> FastTree a+treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath++

@@ -1,162 +1,166 @@+-- This file has been generated from package.yaml by hpack version 0.5.4.+--+-- see: https://github.com/sol/hpack+ name:           hledger-lib-version: 0.26+version:        0.27 stability:      stable-category:       Finance, Console-synopsis:       Core data types, parsers and utilities for the hledger accounting tool.-description:-                hledger is a library and set of user tools for working-                with financial data (or anything that can be tracked in a-                double-entry accounting ledger.) It is a haskell port and-                friendly fork of John Wiegley's Ledger. hledger provides-                command-line, curses and web interfaces, and aims to be a-                reliable, practical tool for daily use.-+category:       Finance+synopsis:       Core data types, parsers and functionality for the hledger accounting tools+description:    +    This is a reusable library containing hledger's core functionality.+    hledger is a cross-platform program for tracking money, time, or+    any other commodity, using double-entry accounting and a simple,+    editable file format. It is inspired by and largely compatible+    with ledger(1).  hledger provides command-line, curses and web+    interfaces, and aims to be a reliable, practical tool for daily+    use. license:        GPL license-file:   LICENSE author:         Simon Michael <simon@joyful.com> maintainer:     Simon Michael <simon@joyful.com> homepage:       http://hledger.org-bug-reports:    http://hledger.org/bugs-tested-with:    GHC==7.8.4, GHC==7.10.1+bug-reports:    http://bugs.hledger.org cabal-version:  >= 1.10 build-type:     Simple--- data-dir:       data--- data-files:--- extra-tmp-files:-extra-source-files: -                    tests/suite.hs-                    CHANGES---   README---   sample.ledger---   sample.timelog+tested-with:    GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.2 +extra-source-files:+    CHANGES + source-repository head-  type:     git+  type: git   location: https://github.com/simonmichael/hledger  flag double-    description:   Use old Double number representation (instead of Decimal), for testing/benchmarking.-    default:       False-    manual:        True+  manual: True+  default: False+  description:+    Use old Double number representation (instead of Decimal), for testing/benchmarking.  flag old-locale-  description: A compatibility flag, set automatically by cabal.-               If false then depend on time >= 1.5, -               if true then depend on time < 1.5 together with old-locale.   default: False-+  description: +    A compatibility flag, set automatically by cabal.+    If false then depend on time >= 1.5, +    if true then depend on time < 1.5 together with old-locale.  library-  -- should set patchlevel here as in Makefile-  cpp-options: -DPATCHLEVEL=0-  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures-  ghc-options: -fno-warn-type-defaults -fno-warn-orphans   if flag(double)     cpp-options: -DDOUBLE-  default-language: Haskell2010-  exposed-modules:-                  Hledger-                  Hledger.Data-                  Hledger.Data.Account-                  Hledger.Data.AccountName-                  Hledger.Data.Amount-                  Hledger.Data.Commodity-                  Hledger.Data.Dates-                  Hledger.Data.OutputFormat-                  Hledger.Data.Journal-                  Hledger.Data.Ledger-                  Hledger.Data.Posting-                  Hledger.Data.RawOptions-                  Hledger.Data.TimeLog-                  Hledger.Data.Transaction-                  Hledger.Data.Types-                  Hledger.Query-                  Hledger.Read-                  Hledger.Read.CsvReader-                  Hledger.Read.JournalReader-                  Hledger.Read.TimelogReader-                  Hledger.Reports-                  Hledger.Reports.ReportOptions-                  Hledger.Reports.BalanceHistoryReport-                  Hledger.Reports.BalanceReport-                  Hledger.Reports.EntriesReport-                  Hledger.Reports.MultiBalanceReports-                  Hledger.Reports.PostingsReport-                  Hledger.Reports.TransactionsReports-                  Hledger.Utils-                  Hledger.Utils.Debug-                  Hledger.Utils.Regex-                  Hledger.Utils.UTF8IOCompat+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans   build-depends:-                  base >= 4.3 && < 5-                 ,base-compat >= 0.8.1-                 ,array-                 ,blaze-markup >= 0.5.1-                 ,bytestring-                 ,cmdargs >= 0.10 && < 0.11-                 ,containers-                 ,csv-                 -- ,data-pprint >= 0.2.3 && < 0.3-                 ,Decimal-                 ,directory-                 ,filepath-                 ,mtl-                 ,mtl-compat-                 ,old-time-                 ,parsec >= 3-                 ,regex-tdfa-                 ,safe >= 0.2-                 ,split >= 0.1 && < 0.3-                 ,transformers >= 0.2 && < 0.5-                 ,utf8-string >= 0.3.5 && < 1.1-                 ,HUnit+      base >= 4.3 && < 5+    , base-compat >= 0.8.1+    , array+    , blaze-markup >= 0.5.1+    , bytestring+    , cmdargs >= 0.10 && < 0.11+    , containers+    , csv+    , Decimal+    , deepseq+    , directory+    , filepath+    , mtl+    , mtl-compat+    , old-time+    , parsec >= 3+    , regex-tdfa+    , safe >= 0.2+    , split >= 0.1 && < 0.3+    , transformers >= 0.2 && < 0.5+    , uglymemo+    , utf8-string >= 0.3.5 && < 1.1+    , HUnit+   if impl(ghc >= 7.4)     build-depends: pretty-show >= 1.6.4+   if flag(old-locale)     build-depends: time < 1.5, old-locale   else     build-depends: time >= 1.5 +  exposed-modules:+      Hledger+      Hledger.Data+      Hledger.Data.Account+      Hledger.Data.AccountName+      Hledger.Data.Amount+      Hledger.Data.Commodity+      Hledger.Data.Dates+      Hledger.Data.Journal+      Hledger.Data.Ledger+      Hledger.Data.StringFormat+      Hledger.Data.Posting+      Hledger.Data.RawOptions+      Hledger.Data.TimeLog+      Hledger.Data.Transaction+      Hledger.Data.Types+      Hledger.Query+      Hledger.Read+      Hledger.Read.CsvReader+      Hledger.Read.JournalReader+      Hledger.Read.TimelogReader+      Hledger.Reports+      Hledger.Reports.ReportOptions+      Hledger.Reports.BalanceHistoryReport+      Hledger.Reports.BalanceReport+      Hledger.Reports.EntriesReport+      Hledger.Reports.MultiBalanceReports+      Hledger.Reports.PostingsReport+      Hledger.Reports.TransactionsReports+      Hledger.Utils+      Hledger.Utils.Debug+      Hledger.Utils.Parse+      Hledger.Utils.Regex+      Hledger.Utils.String+      Hledger.Utils.Test+      Hledger.Utils.Tree+      Hledger.Utils.UTF8IOCompat+  default-language: Haskell2010  test-suite tests-  type:     exitcode-stdio-1.0-  main-is:  suite.hs-  hs-source-dirs: tests-  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures-  ghc-options: -fno-warn-type-defaults -fno-warn-orphans-  default-language: Haskell2010-  build-depends: hledger-lib-               , base >= 4.3 && < 5-               , base-compat >= 0.8.1-               , array-               , blaze-markup >= 0.5.1-               , cmdargs-               , containers-               , csv-               -- , data-pprint >= 0.2.3 && < 0.3-               , Decimal-               , directory-               , filepath-               , HUnit-               , mtl-               , mtl-compat-               , old-time-               , parsec >= 3-               , regex-tdfa-               , safe-               , split-               , test-framework-               , test-framework-hunit-               , transformers+  type: exitcode-stdio-1.0+  main-is: suite.hs+  hs-source-dirs:+      tests+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+  build-depends:+      base >= 4.3 && < 5+    , base-compat >= 0.8.1+    , array+    , blaze-markup >= 0.5.1+    , bytestring+    , cmdargs >= 0.10 && < 0.11+    , containers+    , csv+    , Decimal+    , deepseq+    , directory+    , filepath+    , mtl+    , mtl-compat+    , old-time+    , parsec >= 3+    , regex-tdfa+    , safe >= 0.2+    , split >= 0.1 && < 0.3+    , transformers >= 0.2 && < 0.5+    , uglymemo+    , utf8-string >= 0.3.5 && < 1.1+    , HUnit+    , hledger-lib+    , test-framework+    , test-framework-hunit+   if impl(ghc >= 7.4)     build-depends: pretty-show >= 1.6.4+   if flag(old-locale)     build-depends: time < 1.5, old-locale   else     build-depends: time >= 1.5 --- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html---- Additional dependencies:--- required for make test: test-framework, test-framework-hunit--- required for make bench: tabular-0.1+  default-language: Haskell2010