Haskell: Add hlint rule to suggest foldl' over foldl (digital-asset#7897

) * Haskell: Add hlint rule to suggest foldl' over foldl `foldl` is lazy in a way that almost never is what you want since it can cause space leaks without any benefit. `foldl'` does not have this problem. See https://www.well-typed.com/blog/2014/04/fixing-foldl/ for more details. CHANGELOG_BEGIN CHANGELOG_END * Fix all existing occurrences of foldl CHANGELOG_BEGIN CHANGELOG_END
TuranDev · Nov 5, 2020 · b01d327 · b01d327
1 parent 6fd1286
commit b01d327
Show file tree

Hide file tree

Showing 10 changed files with 32 additions and 26 deletions.
diff --git a/.hlint.yaml b/.hlint.yaml
@@ -34,6 +34,9 @@
 # Off by default hints we like
 - warn: {name: Use module export list}
 
+# Performance foot guns
+- warn: {lhs: foldl, rhs: "foldl'"}
+
 # Condemn nub and friends
 - warn: {lhs: nub (sort x), rhs: Data.List.Extra.nubSort x}
 - warn: {lhs: nub, rhs: Data.List.Extra.nubOrd}
@@ -53,7 +56,7 @@
 - warn: {lhs: Data.Text.Lazy.readFile, rhs: Data.Text.Extended.readFileUtf8}
 - warn: {lhs: Data.Text.Lazy.writeFile, rhs: Data.Text.Extended.writeFileUtf8}
 - warn: {lhs: System.Environment.setEnv, rhs: System.Environment.Blank.setEnv}
-- warn: {lhs: toNormalizedFilePath, rhs: toNormalizedFilePath'}
+- warn: {lhs: toNormalizedFilePath, rhs: "toNormalizedFilePath'"}
 
 # Hints that do not always make sense
 - ignore: {name: "Use if", within: [DA.Daml.LF.Proto3.EncodeV1, DA.Daml.LF.Ast.Pretty]}

diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Util.hs
@@ -5,6 +5,7 @@
 module DA.Daml.LF.Ast.Util(module DA.Daml.LF.Ast.Util) where
 
 import Control.Monad
+import Data.List
 import Data.Maybe
 import qualified Data.Text as T
 import           Control.Lens
@@ -191,7 +192,7 @@ pattern TTextMapEntry a = TStruct [(FieldName "key", TText), (FieldName "value",
 pattern TConApp :: Qualified TypeConName -> [Type] -> Type
 pattern TConApp tcon targs <- (view (leftSpine _TApp) -> (TCon tcon, targs))
   where
-    TConApp tcon targs = foldl TApp (TCon tcon) targs
+    TConApp tcon targs = foldl' TApp (TCon tcon) targs
 
 pattern TForalls :: [(TypeVarName, Kind)] -> Type -> Type
 pattern TForalls binders ty <- (view _TForalls -> (binders, ty))

diff --git a/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs b/compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs
@@ -778,7 +778,7 @@ decodeType LF1.Type{..} = mayDecode "typeSum" typeSum $ \case
     TStruct <$> mapM (decodeFieldWithType FieldName) (V.toList flds)
   where
     decodeWithArgs :: V.Vector LF1.Type -> Decode Type -> Decode Type
-    decodeWithArgs args fun = foldl TApp <$> fun <*> traverse decodeType args
+    decodeWithArgs args fun = foldl' TApp <$> fun <*> traverse decodeType args
 
 
 decodeFieldWithType :: (T.Text -> a) -> LF1.FieldWithType -> Decode (a, Type)

diff --git a/compiler/daml-lf-verify/src/DA/Daml/LF/Verify/ReferenceSolve.hs b/compiler/daml-lf-verify/src/DA/Daml/LF/Verify/ReferenceSolve.hs
@@ -15,7 +15,7 @@ module DA.Daml.LF.Verify.ReferenceSolve
 
 import Data.Hashable
 import Data.Maybe (fromMaybe)
-import Data.List (intercalate)
+import Data.List (foldl', intercalate)
 import qualified Data.HashMap.Strict as HM
 
 import DA.Daml.LF.Ast hiding (lookupChoice)
@@ -29,7 +29,7 @@ solveValueReferences :: Env 'ValueGathering -> Env 'ChoiceGathering
 solveValueReferences env =
   let val_exp_hmap = HM.map fst $ envVals env
       val_ref_hmap = HM.map snd $ envVals env
-      (_, val_sol_hmap) = foldl (\hmaps ref -> snd $ solveReference lookup_ref_in lookup_ref_out pop_upds ext_upds make_rec make_mutrec intro_cond empty_upds [] hmaps ref) (val_ref_hmap, HM.empty) (HM.keys $ envVals env)
+      (_, val_sol_hmap) = foldl' (\hmaps ref -> snd $ solveReference lookup_ref_in lookup_ref_out pop_upds ext_upds make_rec make_mutrec intro_cond empty_upds [] hmaps ref) (val_ref_hmap, HM.empty) (HM.keys $ envVals env)
       valhmap = HM.intersectionWith (\e u -> (e,u)) val_exp_hmap val_sol_hmap
   in EnvCG (envSkols env) valhmap (envDats env) (envCids env) HM.empty (envCtrs env) HM.empty
   where
@@ -70,7 +70,7 @@ solveValueReferences env =
     make_mutrec inp =
       let (strs, upds) = unzip inp
           debug = intercalate " - " $ map (show . unExprValName . qualObject) strs
-          updConcat = foldl concatUpdateSet emptyUpdateSet upds
+          updConcat = foldl' concatUpdateSet emptyUpdateSet upds
       in (map baseUpd $ makeMutRec [upd | UpdCGBase upd <- updConcat] debug)
            ++ [UpdCGChoice cho | UpdCGChoice cho <- updConcat]
 
@@ -80,8 +80,8 @@ solveValueReferences env =
     intro_cond (Conditional cond cx cy) =
       let xs = map intro_cond cx
           ys = map intro_cond cy
-          updx = foldl concatUpdateSet emptyUpdateSet xs
-          updy = foldl concatUpdateSet emptyUpdateSet ys
+          updx = foldl' concatUpdateSet emptyUpdateSet xs
+          updy = foldl' concatUpdateSet emptyUpdateSet ys
       in (introCond $ createCond cond updx updy)
 
     empty_upds :: UpdateSet 'ValueGathering
@@ -93,7 +93,7 @@ solveValueReferences env =
 -- It thus empties `_usChoice` by collecting all updates made by this closure.
 solveChoiceReferences :: Env 'ChoiceGathering -> Env 'Solving
 solveChoiceReferences env =
-  let (_, chhmap) = foldl (\hmaps ref -> snd $ solveReference lookup_ref_in lookup_ref_out pop_upds ext_upds make_rec make_mutrec intro_cond empty_upds [] hmaps ref) (envChoices env, HM.empty) (HM.keys $ envChoices env)
+  let (_, chhmap) = foldl' (\hmaps ref -> snd $ solveReference lookup_ref_in lookup_ref_out pop_upds ext_upds make_rec make_mutrec intro_cond empty_upds [] hmaps ref) (envChoices env, HM.empty) (HM.keys $ envChoices env)
       valhmap = HM.map (inlineChoices chhmap) (envVals env)
   in EnvS (envSkols env) valhmap (envDats env) (envCids env) (envPreconds env) (envCtrs env) chhmap
   where
@@ -148,7 +148,7 @@ solveChoiceReferences env =
     concat_chdats :: IsPhase ph => [ChoiceData ph] -> ChoiceData ph
     concat_chdats inp =
       let chdat = head inp
-          upds = foldl concatUpdateSet emptyUpdateSet $ map _cdUpds inp
+          upds = foldl' concatUpdateSet emptyUpdateSet $ map _cdUpds inp
       in chdat{_cdUpds = upds}
 
     intro_cond :: IsPhase ph
@@ -159,10 +159,10 @@ solveChoiceReferences env =
       let datxs = map intro_cond cdatxs
           datys = map intro_cond cdatys
           newUpds = introCond (createCond cond
-              (foldl
+              (foldl'
                 (\upd dat -> upd `concatUpdateSet` _cdUpds dat)
                 emptyUpdateSet datxs)
-              (foldl
+              (foldl'
                 (\upd dat -> upd `concatUpdateSet` _cdUpds dat)
                 emptyUpdateSet datys))
       in (head datxs){_cdUpds = newUpds}
@@ -293,9 +293,9 @@ solveReference lookupRef lookupSol popUpd extUpds makeRec makeMutRec introCond e
       -- preserved in the computed closure (update set).
       Conditional cond refs_a refs_b ->
             -- Compute the closure for the true-case.
-        let (updset_a, hmaps_a) = foldl (handle_ref vis) (updset0,hmaps0) refs_a
+        let (updset_a, hmaps_a) = foldl' (handle_ref vis) (updset0,hmaps0) refs_a
             -- Compute the closure for the false-case.
-            (updset_b, hmaps_b) = foldl (handle_ref vis) (updset0,hmaps_a) refs_b
+            (updset_b, hmaps_b) = foldl' (handle_ref vis) (updset0,hmaps_a) refs_b
             -- Move the conditional inwards, in the update set.
             -- TODO: This has the unfortunate side effect of moving all updates inside the conditional.
             updset1 = introCond $ createCond cond updset_a updset_b

diff --git a/compiler/daml-lf-verify/src/DA/Daml/LF/Verify/Solve.hs b/compiler/daml-lf-verify/src/DA/Daml/LF/Verify/Solve.hs
@@ -294,7 +294,7 @@ filterVars vars cexprs =
 constructSynonyms :: [(ExprVarName, [ExprVarName])]
   -- ^ The current contract names, along with any previous synonyms.
   -> [(ExprVarName, ExprVarName)]
-constructSynonyms = foldl step []
+constructSynonyms = foldl' step []
   where
     step :: [(ExprVarName, ExprVarName)] -> (ExprVarName, [ExprVarName])
       -> [(ExprVarName, ExprVarName)]
@@ -334,7 +334,7 @@ constructConstr env chtem ch ftem f =
       -- ^ The updates to analyse.
       -> ConstraintSet
     constructSingleSet vars ctrs syns (info, upds) =
-      let (cres, arcs) = foldl
+      let (cres, arcs) = foldl'
             (\(cs,as) upd -> let (cs',as') = filterCondUpd ftem syns f upd in (cs ++ cs',as ++ as'))
             ([],[])
             upds
@@ -504,7 +504,7 @@ declareCtrs sol cvars1 exprs = do
     cc_step [] _ = ([],[])
     cc_step edges0 (o,l,r,vars) =
       let (neighbors,edges1) = partition (\(_,_,_,vars') -> not $ null $ intersect vars vars') edges0
-      in foldl (\(conn,edges2) edge -> first (conn ++) $ cc_step edges2 edge)
+      in foldl' (\(conn,edges2) edge -> first (conn ++) $ cc_step edges2 edge)
            ((o,l,r,vars):neighbors,edges1) neighbors
 
     declare :: [(ExprVarName,S.SExpr)]
@@ -543,7 +543,7 @@ data Result
 
 instance Show Result where
   show Success = "Success!"
-  show (Fail cs) = "Fail. Counter example:" ++ foldl (flip step) "" cs
+  show (Fail cs) = "Fail. Counter example:" ++ foldl' (flip step) "" cs
     where
       step :: (S.SExpr, S.Value) -> String -> String
       step (var, val) str = ("\n" ++) $ S.ppSExpr var $ (" = " ++) $ S.ppSExpr (S.value val) str
@@ -555,7 +555,7 @@ showResult choice field result = case result of
   Success -> "Success! The choice " ++ choiceStr ++ " preserves the field "
     ++ fieldStr ++ "."
   (Fail cs) -> "Fail. The choice " ++ choiceStr ++ " does not preserve the field "
-    ++ fieldStr ++ ". Counter example:" ++ foldl (flip step) "" cs
+    ++ fieldStr ++ ". Counter example:" ++ foldl' (flip step) "" cs
   Unknown -> "Inconclusive result."
   where
     choiceStr = T.unpack $ unChoiceName choice
@@ -582,8 +582,8 @@ solveConstr spath ConstraintSet{..} = do
     else pure (vars1 ++ vars2)
   let cres = renderFilter $ map simplifyCExpr _cCres
       arcs = renderFilter $ map simplifyCExpr _cArcs
-  cre <- foldl S.add (S.real 0.0) <$> mapM (cexp2sexp vars) cres
-  arc <- foldl S.add (S.real 0.0) <$> mapM (cexp2sexp vars) arcs
+  cre <- foldl' S.add (S.real 0.0) <$> mapM (cexp2sexp vars) cres
+  arc <- foldl' S.add (S.real 0.0) <$> mapM (cexp2sexp vars) arcs
   S.assert sol (S.not (cre `S.eq` arc))
   result <- S.check sol >>= \case
     S.Sat -> do

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -1671,7 +1671,7 @@ convertType env = go env
             erasedTy env
 
         | t == funTyCon, _:_:ts' <- ts =
-            foldl TApp TArrow <$> mapM (go env) ts'
+            foldl' TApp TArrow <$> mapM (go env) ts'
         | NameIn DA_Internal_LF "Pair" <- t
         , [StrLitTy f1, StrLitTy f2, t1, t2] <- ts = do
             t1 <- go env t1

diff --git a/compiler/damlc/daml-preprocessor/src/DA/Daml/Preprocessor/Records.hs b/compiler/damlc/daml-preprocessor/src/DA/Daml/Preprocessor/Records.hs
@@ -167,7 +167,7 @@ onExp (L o (SectionR _ mid@(isDot -> True) rhs))
         -- don't need it when the record type is unknown. When the record type
         -- is known, the conversion to DAML-LF needs to add the lambda anyway.
         [sel] -> mkVar var_getField `mkAppType` sel
-        _:_:_ -> mkLam var_record $ foldl (\x sel -> mkVar var_getField `mkAppType` sel `mkApp` x) (mkVar var_record) sels
+        _:_:_ -> mkLam var_record $ foldl' (\x sel -> mkVar var_getField `mkAppType` sel `mkApp` x) (mkVar var_record) sels
           where
             var_record = GHC.mkRdrUnqual $ GHC.mkVarOcc "record"
 

diff --git a/language-support/hs/bindings/examples/chat/src/DA/Ledger/App/Chat/Interact.hs b/language-support/hs/bindings/examples/chat/src/DA/Ledger/App/Chat/Interact.hs
@@ -7,6 +7,7 @@ module DA.Ledger.App.Chat.Interact (InteractState(..), makeInteractState, runSub
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar
+import Data.List
 import DA.Ledger.App.Chat.ChatLedger (Handle,sendCommand,getTrans)
 import DA.Ledger.App.Chat.Contracts (ChatContract)
 import DA.Ledger.App.Chat.Domain (Party)
@@ -51,7 +52,7 @@ manageUpdates :: Handle -> Party -> Logger -> MVar State -> IO (Stream ChatContr
 manageUpdates h whoami log sv = do
     PastAndFuture{past,future} <- getTrans whoami h
     log $ "replaying " <> show (length past) <> " transactions"
-    modifyMVar_ sv (\s -> return $ foldl (applyTransQuiet whoami) s past)
+    modifyMVar_ sv (\s -> return $ foldl' (applyTransQuiet whoami) s past)
     withMVar sv $ \s -> sendShowingRejection whoami h log (introduceEveryone whoami s)
     _ <- forkIO (updateX h whoami log sv future)
     return future

diff --git a/libs-haskell/da-hs-base/src/Control/Lens/Ast.hs b/libs-haskell/da-hs-base/src/Control/Lens/Ast.hs
@@ -8,6 +8,7 @@ module Control.Lens.Ast
   ) where
 
 import Control.Lens
+import Data.List
 
 -- $setup
 -- The examples for 'leftSpine' and 'rightSpine' assume we have the following
@@ -34,7 +35,7 @@ leftSpine p = iso unwindl rewindl
         go e0 as = case matching p e0 of
           Left   e1     -> (e1, as)
           Right (e1, a) -> go e1 (a:as)
-    rewindl (e0, as) = foldl (curry (p #)) e0 as
+    rewindl (e0, as) = foldl' (curry (p #)) e0 as
 
 -- | Analogue of 'leftSpine' for right associative constructors.
 --

diff --git a/libs-haskell/da-hs-base/src/Data/NameMap.hs b/libs-haskell/da-hs-base/src/Data/NameMap.hs
@@ -132,7 +132,7 @@ traverse f (NameMap ras _) = build <$> Prelude.traverse f' (reverse ras)
     build as = NameMap (reverse as) (HMS.fromList as)
 
 instance Foldable NameMap where
-  foldr f z (NameMap ras _) = foldl f' z ras
+  foldr f z (NameMap ras _) = foldl' f' z ras
     where
       f' acc (_, x) = f x acc