From d236f7b237480f86e1aa6ad1fbe8812f32cef3eb Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Fri, 13 Jan 2017 01:24:53 +0100 Subject: [PATCH] Fix a few spaceleaks (#413) --- hledger-lib/Hledger/Data/Account.hs | 2 +- hledger-lib/Hledger/Data/Amount.hs | 2 +- hledger-lib/Hledger/Data/Journal.hs | 10 +++---- hledger-lib/Hledger/Data/Posting.hs | 2 +- hledger-lib/Hledger/Data/Transaction.hs | 10 +++---- hledger-lib/Hledger/Data/Types.hs | 2 +- hledger-lib/Hledger/Utils.hs | 39 +++++++++++++++++++++++-- hledger/Hledger/Cli/Register.hs | 4 +-- 8 files changed, 53 insertions(+), 18 deletions(-) diff --git a/hledger-lib/Hledger/Data/Account.hs b/hledger-lib/Hledger/Data/Account.hs index 74365dfa5..78b40d7ce 100644 --- a/hledger-lib/Hledger/Data/Account.hs +++ b/hledger-lib/Hledger/Data/Account.hs @@ -64,7 +64,7 @@ accountsFromPostings ps = acctamts = [(paccount p,pamount p) | p <- ps] grouped = groupBy (\a b -> fst a == fst b) $ sort $ acctamts counted = [(a, length acctamts) | acctamts@((a,_):_) <- grouped] - summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty + summed = map (\as@((aname,_):_) -> (aname, sumStrict $ map snd as)) grouped -- always non-empty nametree = treeFromPaths $ map (expandAccountName . fst) summed acctswithnames = nameTreeToAccount "root" nametree acctswithnumps = mapAccounts setnumps acctswithnames where setnumps a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted} diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 24158290b..c4f6615d3 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -435,7 +435,7 @@ tests_normaliseMixedAmountSquashPricesForDisplay = [ -- rendering helper. sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount sumSimilarAmountsUsingFirstPrice [] = nullamt -sumSimilarAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as} +sumSimilarAmountsUsingFirstPrice as = (sumStrict as){aprice=aprice $ head as} -- -- | Sum same-commodity amounts. If there were different prices, set -- -- the price to a special marker indicating "various". Only used as a diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 7aa37945f..97ad60592 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -584,8 +584,8 @@ journalBalanceTransactionsST assrt j createStore storeIn extract = flip R.runReaderT (Env bals (storeIn txStore) assrt $ Just $ jinferredcommodities j) $ do dated <- fmap snd . sortBy (comparing fst) . concat - <$> mapM discriminateByDate (jtxns j) - mapM checkInferAndRegisterAmounts dated + <$> mapM' discriminateByDate (jtxns j) + mapM' checkInferAndRegisterAmounts dated lift $ extract txStore where size = genericLength $ journalPostings j @@ -759,7 +759,7 @@ canonicalStyleFrom ss@(first:_) = where mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss -- precision is maximum of all precisions - prec = maximum $ map asprecision ss + prec = maximumStrict $ map asprecision ss mdec = Just $ headDef '.' $ catMaybes $ map asdecimalpoint ss -- precision is that of first amount with a decimal point -- (mdec, prec) = @@ -842,8 +842,8 @@ journalDateSpan secondary j | null ts = DateSpan Nothing Nothing | otherwise = DateSpan (Just earliest) (Just $ addDays 1 latest) where - earliest = minimum dates - latest = maximum dates + earliest = minimumStrict dates + latest = maximumStrict dates dates = pdates ++ tdates tdates = map (if secondary then transactionDate2 else tdate) ts pdates = concatMap (catMaybes . map (if secondary then (Just . postingDate2) else pdate) . tpostings) ts diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 18b6d9d8f..a54ba5737 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -126,7 +126,7 @@ accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings = nub . map paccount sumPostings :: [Posting] -> MixedAmount -sumPostings = sum . map pamount +sumPostings = sumStrict . map pamount -- | Remove all prices of a posting removePrices :: Posting -> Posting diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index f1c860715..731692f03 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -393,10 +393,10 @@ inferBalancingAmount update t@Transaction{tpostings=ps} return t{tpostings=postings} where printerr s = intercalate "\n" [s, showTransactionUnelided t] - ((amountfulrealps, amountlessrealps), realsum) = - (partition hasAmount (realPostings t), sum $ map pamount amountfulrealps) - ((amountfulbvps, amountlessbvps), bvsum) = - (partition hasAmount (balancedVirtualPostings t), sum $ map pamount amountfulbvps) + (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) + realsum = sumStrict $ map pamount amountfulrealps + (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) + bvsum = sumStrict $ map pamount amountfulbvps inferamount p@Posting{ptype=RegularPosting} | not (hasAmount p) = updateAmount p realsum inferamount p@Posting{ptype=BalancedVirtualPosting} @@ -460,7 +460,7 @@ priceInferrerFor t pt = inferprice pmixedamounts = map pamount postings pamounts = concatMap amounts pmixedamounts pcommodities = map acommodity pamounts - sumamounts = amounts $ sum pmixedamounts -- sum normalises to one amount per commodity & price + sumamounts = amounts $ sumStrict pmixedamounts -- sum normalises to one amount per commodity & price sumcommodities = map acommodity sumamounts sumprices = filter (/=NoPrice) $ map aprice sumamounts caninferprices = length sumcommodities == 2 && null sumprices diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 8faa7bb11..6e7d21161 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -130,7 +130,7 @@ instance NFData Price data AmountStyle = AmountStyle { ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ? ascommodityspaced :: Bool, -- ^ space between symbol and quantity ? - asprecision :: Int, -- ^ number of digits displayed after the decimal point + asprecision :: !Int, -- ^ number of digits displayed after the decimal point asdecimalpoint :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any } deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 554ce4096..6a2b48086 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -34,7 +34,7 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c where import Control.Monad (liftM) -- import Data.Char --- import Data.List +import Data.List -- import Data.Maybe -- import Data.PPrint import Data.Text (Text) @@ -173,4 +173,39 @@ readFileOrStdinAnyLineEnding f = do -- | Total version of maximum, for integral types, giving 0 for an empty list. maximum' :: Integral a => [a] -> a maximum' [] = 0 -maximum' xs = maximum xs +maximum' xs = maximumStrict xs + +-- | Strict version of sum that doesn’t leak space +{-# INLINABLE sumStrict #-} +sumStrict :: Num a => [a] -> a +sumStrict = foldl' (+) 0 + +-- | Strict version of maximum that doesn’t leak space +{-# INLINABLE maximumStrict #-} +maximumStrict :: Ord a => [a] -> a +maximumStrict = foldl1' max + +-- | Strict version of minimum that doesn’t leak space +{-# INLINABLE minimumStrict #-} +minimumStrict :: Ord a => [a] -> a +minimumStrict = foldl1' min + +-- | This is a version of sequence based on difference lists. It is +-- slightly faster but we mostly use it because it uses the heap +-- instead of the stack. This has the advantage that Neil Mitchell’s +-- trick of limiting the stack size to discover space leaks doesn’t +-- show this as a false positive. +{-# INLINABLE sequence' #-} +sequence' :: Monad f => [f a] -> f [a] +sequence' ms = do + h <- go id ms + return (h []) + where + go h [] = return h + go h (m:ms) = do + x <- m + go (h . (x :)) ms + +{-# INLINABLE mapM' #-} +mapM' :: Monad f => (a -> f b) -> [a] -> f [b] +mapM' f = sequence' . map f diff --git a/hledger/Hledger/Cli/Register.hs b/hledger/Hledger/Cli/Register.hs index 28b8e4470..5abbb6166 100644 --- a/hledger/Hledger/Cli/Register.hs +++ b/hledger/Hledger/Cli/Register.hs @@ -90,8 +90,8 @@ postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,desc,acct,amt,bal] postingsReportAsText :: CliOpts -> PostingsReport -> String postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText opts amtwidth balwidth) items where - amtwidth = maximum $ 12 : map (strWidth . showMixedAmount . itemamt) items - balwidth = maximum $ 12 : map (strWidth . showMixedAmount . itembal) items + amtwidth = maximumStrict $ 12 : map (strWidth . showMixedAmount . itemamt) items + balwidth = maximumStrict $ 12 : map (strWidth . showMixedAmount . itembal) items itemamt (_,_,_,Posting{pamount=a},_) = a itembal (_,_,_,_,a) = a