Merge pull request #6053 from commercialhaskell/merge

Replace mergeWithKey with merge

Author: mpilgrem

src/Stack/Build/ConstructPlan.hs

@@ -10,7 +10,7 @@ module Stack.Build.ConstructPlan
 
 import           Control.Monad.RWS.Strict hiding ( (<>) )
 import qualified Data.List as L
-import qualified Data.Map.Strict as M
+import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
 import           Data.Monoid.Map ( MonoidMap(..) )
 import qualified Data.Set as Set
@@ -93,10 +93,10 @@ combineSourceInstalled ps (location, installed) =
 type CombinedMap = Map PackageName PackageInfo
 
 combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap
-combineMap = Map.mergeWithKey
-  (\_ s i -> Just $ combineSourceInstalled s i)
-  (fmap PIOnlySource)
-  (fmap (uncurry PIOnlyInstalled))
+combineMap = Map.merge
+  (Map.mapMissing (\_ s -> PIOnlySource s))
+  (Map.mapMissing (\_ i -> uncurry PIOnlyInstalled i))
+  (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i))
 
 data AddDepRes
   = ADRToInstall Task
@@ -243,29 +243,29 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
   pathEnvVar' <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
   let ctx = mkCtx econfig globalCabalVersion sources mcur pathEnvVar'
   ((), m, W efinals installExes dirtyReason warnings parents) <-
-    liftIO $ runRWST inner ctx M.empty
+    liftIO $ runRWST inner ctx Map.empty
   mapM_
     (prettyWarn . fromString . T.unpack . textDisplay) (warnings [])
   let toEither (_, Left e)  = Left e
       toEither (k, Right v) = Right (k, v)
-      (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m
-      (errfinals, finals) = partitionEithers $ map toEither $ M.toList efinals
+      (errlibs, adrs) = partitionEithers $ map toEither $ Map.toList m
+      (errfinals, finals) = partitionEithers $ map toEither $ Map.toList efinals
       errs = errlibs ++ errfinals
   if null errs
     then do
       let toTask (_, ADRFound _ _) = Nothing
           toTask (name, ADRToInstall task) = Just (name, task)
-          tasks = M.fromList $ mapMaybe toTask adrs
+          tasks = Map.fromList $ mapMaybe toTask adrs
           takeSubset =
             case boptsCLIBuildSubset $ bcoBuildOptsCLI baseConfigOpts0 of
               BSAll -> pure
               BSOnlySnapshot -> pure . stripLocals
               BSOnlyDependencies ->
-                pure . stripNonDeps (M.keysSet $ smDeps sourceMap)
+                pure . stripNonDeps (Map.keysSet $ smDeps sourceMap)
               BSOnlyLocals -> errorOnSnapshot
       takeSubset Plan
         { planTasks = tasks
-        , planFinals = M.fromList finals
+        , planFinals = Map.fromList finals
         , planUnregisterLocal =
             mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps
         , planInstallExes =
@@ -794,9 +794,9 @@ packageBuildTypeConfig pkg = packageBuildType pkg == Configure
 -- error about cyclic dependencies, prefer the cyclic error.
 updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M ()
 updateLibMap name val = modify $ \mp ->
-  case (M.lookup name mp, val) of
+  case (Map.lookup name mp, val) of
     (Just (Left DependencyCycleDetected{}), Left _) -> mp
-    _ -> M.insert name val mp
+    _ -> Map.insert name val mp
 
 addEllipsis :: Text -> Text
 addEllipsis t
@@ -935,7 +935,7 @@ addPackageDeps package = do
   -- Update the parents map, for later use in plan construction errors
   -- - see 'getShortestDepsPath'.
   addParent depname range mversion =
-    tell mempty { wParents = MonoidMap $ M.singleton depname val }
+    tell mempty { wParents = MonoidMap $ Map.singleton depname val }
    where
     val = (First mversion, [(packageIdentifier package, range)])
 
@@ -1150,7 +1150,7 @@ stripNonDeps deps plan = plan
     when (pid `elem` dependents) $
       impureThrow $ TaskCycleBug pid
     modify' (<> Set.singleton pid)
-    mapM_ (collectMissing (pid:dependents)) (fromMaybe mempty $ M.lookup pid missing)
+    mapM_ (collectMissing (pid:dependents)) (fromMaybe mempty $ Map.lookup pid missing)
 
 -- | Is the given package/version combo defined in the snapshot or in the global
 -- database?

src/Stack/Build/Execute.hs

@@ -45,7 +45,7 @@ import qualified Data.List as L
 import           Data.List.NonEmpty ( nonEmpty )
 import qualified Data.List.NonEmpty as NonEmpty ( toList )
 import           Data.List.Split ( chunksOf )
-import qualified Data.Map.Strict as M
+import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
@@ -726,15 +726,15 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
                  else Just <$> liftIO (newMVar ())
 
   let actions = concatMap (toActions installedMap' mtestLock run ee) $
-        Map.elems $ Map.mergeWithKey
-          (\_ b f -> Just (Just b, Just f))
-          (fmap (\b -> (Just b, Nothing)))
-          (fmap (\f -> (Nothing, Just f)))
+        Map.elems $ Map.merge
+          (Map.mapMissing (\_ b -> (Just b, Nothing)))
+          (Map.mapMissing (\_ f -> (Nothing, Just f)))
+          (Map.zipWithMatched (\_ b f -> (Just b, Just f)))
           (planTasks plan)
           (planFinals plan)
   threads <- view $ configL.to configJobs
   let keepGoing =
-        fromMaybe (not (M.null (planFinals plan))) (boptsKeepGoing eeBuildOpts)
+        fromMaybe (not (Map.null (planFinals plan))) (boptsKeepGoing eeBuildOpts)
   terminal <- view terminalL
   errs <- liftIO $ runActions threads keepGoing actions $
     \doneVar actionsVar -> do
@@ -2103,7 +2103,7 @@ getExecutableBuildStatuses package pkgDir = do
   distDir <- distDirFromDir pkgDir
   platform <- view platformL
   fmap
-    M.fromList
+    Map.fromList
     (mapM (checkExeStatus platform distDir) (Set.toList (packageExes package)))
 
 -- | Check whether the given executable is defined in the given dist directory.
@@ -2147,7 +2147,7 @@ checkForUnlistedFiles (TTLocalMutable lp) pkgDir = do
       (lpCabalFile lp)
       (lpComponents lp)
       caches
-  forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do
+  forM_ (Map.toList addBuildCache) $ \(component, newToCache) -> do
     let cache = Map.findWithDefault Map.empty component caches
     writeBuildCache pkgDir component $
       Map.unions (cache : newToCache)
@@ -2279,7 +2279,7 @@ singleTest topts testsToRun ac ee task installedMap = do
                          <> display (unGhcPkgId ghcId)
                          <> "\n"
                      )
-                     (pkgGhcIdList ++ thGhcId:M.elems allDepsMap)
+                     (pkgGhcIdList ++ thGhcId:Map.elems allDepsMap)
           writeFileUtf8Builder fp ghcEnv
           menv <- liftIO $
             setEnv fp =<< configProcessContextSettings config EnvSettings
@@ -2661,7 +2661,7 @@ exesToBuild executableBuildStatuses lp =
 
 -- | Do the current executables satisfy Cabal's bugged out requirements?
 cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool
-cabalIsSatisfied = all (== ExecutableBuilt) . M.elems
+cabalIsSatisfied = all (== ExecutableBuilt) . Map.elems
 
 -- Test-suite and benchmark build components.
 finalComponentOptions :: LocalPackage -> [String]

src/Stack/Build/Source.hs

@@ -18,6 +18,7 @@ import           Conduit ( ZipSink (..), withSourceFile )
 import           Data.ByteString.Builder ( toLazyByteString )
 import qualified Data.List as L
 import qualified Data.Map as Map
+import qualified Data.Map.Merge.Lazy as Map
 import qualified Data.Map.Strict as M
 import qualified Data.Set as Set
 import qualified Distribution.PackageDescription as C
@@ -422,10 +423,10 @@ checkBuildCache oldCache files = do
     mdigest <- liftIO (getFileDigestMaybe (toFilePath fp))
     pure (toFilePath fp, mdigest)
   fmap (mconcat . Map.elems) $ sequence $
-    Map.mergeWithKey
-      (\fp mdigest fci -> Just (go fp mdigest (Just fci)))
-      (Map.mapWithKey (\fp mdigest -> go fp mdigest Nothing))
-      (Map.mapWithKey (\fp fci -> go fp Nothing (Just fci)))
+    Map.merge
+      (Map.mapMissing (\fp mdigest -> go fp mdigest Nothing))
+      (Map.mapMissing (\fp fci -> go fp Nothing (Just fci)))
+      (Map.zipWithMatched (\fp mdigest fci -> go fp mdigest (Just fci)))
       fileTimes
       oldCache
  where

src/Stack/FileWatch.hs

@@ -8,6 +8,7 @@ module Stack.FileWatch
   ) where
 
 import           Control.Concurrent.STM ( check )
+import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import           GHC.IO.Exception
@@ -56,10 +57,10 @@ fileWatchConf cfg inner =
         setWatched files = do
           atomically $ writeTVar allFiles $ Set.map toFilePath files
           watch0 <- readTVarIO watchVar
-          let actions = Map.mergeWithKey
-                keepListening
-                stopListening
-                startListening
+          let actions = Map.merge
+                (Map.mapMissing stopListening)
+                (Map.mapMissing startListening)
+                (Map.zipWithMatched keepListening)
                 watch0
                 newDirs
           watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
@@ -74,16 +75,16 @@ fileWatchConf cfg inner =
                   $ Set.toList
                   $ Set.map parent files
 
-          keepListening _dir listen () = Just $ pure $ Just listen
-          stopListening = Map.map $ \f -> do
+          keepListening _dir listen () = pure $ Just listen
+          stopListening _ f = do
             () <- f `catch` \ioe ->
               -- Ignore invalid argument error - it can happen if
               -- the directory is removed.
               case ioe_type ioe of
                 InvalidArgument -> pure ()
                 _ -> throwIO ioe
             pure Nothing
-          startListening = Map.mapWithKey $ \dir () -> do
+          startListening dir () = do
             let dir' = fromString $ toFilePath dir
             listen <- watchDir manager dir' (const True) onChange
             pure $ Just listen