Remove expensive union calls during dependency fetching (#1095)

src/Spago/Command/Fetch.purs

@@ -404,42 +404,45 @@ getTransitiveDepsFromPackageSet packageSet deps = do
     init :: TransitiveDepsResult
     init = { packages: (Map.empty :: Map PackageName Package), errors: mempty }
 
-    mergeResults :: TransitiveDepsResult -> TransitiveDepsResult -> TransitiveDepsResult
-    mergeResults r1 r2 =
-      { packages: Map.union r1.packages r2.packages
-      , errors: r1.errors <> r2.errors
-      }
-
-    go :: Set PackageName -> PackageName -> StateT (Map PackageName (Map PackageName Package)) (Spago (FetchEnv a)) TransitiveDepsResult
-    go seen dep =
-      if (Set.member dep seen) then do
-        pure (init { errors { cycle = Set.singleton dep } })
+    go :: Set PackageName -> PackageName -> StateT TransitiveDepsResult (Spago (FetchEnv a)) Unit
+    go seen dep = do
+      -- We stash packages that we encountered along the way in `seen`,
+      -- so if we see it again we have a cycle
+      if Set.member dep seen then do
+        State.modify_ $ cycleError dep
       else do
-        cache <- State.get
-        case Map.lookup dep cache of
-          Just allDeps ->
-            pure (init { packages = allDeps })
-          Nothing ->
-            -- First look for the package in the set to get a version number out,
-            -- then use that version to look it up in the index and get the dependencies
-            case Map.lookup dep packageSet of
-              Nothing -> pure (init { errors { notInPackageSet = Set.singleton dep } })
-              Just package -> do
-                maybeDeps <- State.lift $ memoisedGetPackageDependencies dep package
-                case maybeDeps of
-                  Nothing -> pure (init { errors { notInIndex = Set.singleton dep } })
-                  Just dependenciesMap -> do
-                    -- recur here, as we need to get the transitive tree, not just the first level
-                    { packages: childDeps, errors } <-
-                      for (Map.toUnfoldable dependenciesMap :: Array (Tuple PackageName Range)) (\(Tuple d _) -> go (Set.insert dep seen) d)
-                        >>= (pure <<< foldl mergeResults init)
-                    let allDeps = Map.insert dep package childDeps
-                    when (Set.isEmpty (errors.cycle <> errors.notInIndex <> errors.notInPackageSet)) do
-                      State.modify_ $ Map.insert dep allDeps
-                    pure { packages: allDeps, errors }
+        -- If the package is a transitive dependency of some other package that
+        -- we already met, then we don't need to do the work again
+        alreadyRun <- Map.member dep <$> State.gets _.packages
+        when (not alreadyRun)
+          -- If we need to compute the dependencies from scratch instead, we first look
+          -- in the package set to get a version number out, then use that version to
+          -- look it up in the index and get the dependencies
+          case Map.lookup dep packageSet of
+            Nothing -> State.modify_ $ notInPackageSetError dep
+            Just package -> do
+              maybeDeps <- State.lift $ memoisedGetPackageDependencies dep package
+              case maybeDeps of
+                Nothing -> State.modify_ $ notInIndexError dep
+                Just dependenciesMap -> do
+                  -- Compare errors before and after recursively running transitive deps
+                  errors <- State.gets _.errors
+
+                  -- recur here, as we need to get the transitive tree, not just the first level
+                  void $ forWithIndex dependenciesMap
+                    (\dependency _ -> go (Set.insert dep seen) dependency)
+
+                  -- Errors may have changed after running through the child deps
+                  errorsAfterTransitiveDeps <- State.gets _.errors
+
+                  -- Do not include the package if any child deps fail
+                  when (errors == errorsAfterTransitiveDeps) do
+                    State.modify_ \st -> st { packages = Map.insert dep package st.packages }
 
   { packages, errors } <-
-    for deps (\d -> State.evalStateT (go mempty d) Map.empty) >>= (pure <<< foldl mergeResults init)
+    State.execStateT
+      (for deps (go mempty))
+      init
 
   when (not (Set.isEmpty errors.cycle)) do
     die $ "The following packages have circular dependencies:\n" <> foldMap printPackageError (Set.toUnfoldable errors.cycle :: Array PackageName)
@@ -460,3 +463,16 @@ getVersionFromPackage :: Package -> Version
 getVersionFromPackage = case _ of
   RegistryVersion v -> v
   _ -> unsafeFromRight $ Version.parse "0.0.0"
+
+notInPackageSetError :: PackageName -> TransitiveDepsResult -> TransitiveDepsResult
+notInPackageSetError dep result = result
+  { errors { notInPackageSet = Set.insert dep result.errors.notInPackageSet } }
+
+notInIndexError :: PackageName -> TransitiveDepsResult -> TransitiveDepsResult
+notInIndexError dep result = result
+  { errors { notInIndex = Set.insert dep result.errors.notInIndex } }
+
+cycleError :: PackageName -> TransitiveDepsResult -> TransitiveDepsResult
+cycleError dep result = result
+  { errors { cycle = Set.insert dep result.errors.cycle } }
+