Compiling but messy!

Author: ChrisPenner

src/Share/BackgroundJobs/Search/DefinitionSync.hs

@@ -4,7 +4,6 @@
 module Share.BackgroundJobs.Search.DefinitionSync (worker) where
 
 import Control.Lens
-import Control.Monad.Except
 import Data.Either (isRight)
 import Data.Generics.Product (HasField (..))
 import Data.List qualified as List
@@ -384,47 +383,56 @@ syncTypes ::
   m ([DefnIndexingFailure], [Text])
 syncTypes codebase namesPerspective rootBranchHashId typesCursor = do
   Cursors.foldBatched typesCursor defnBatchSize \types -> do
-    (errs, refDocs) <-
-      types
-        -- Most lib names are already filtered out by using the name lookup; but sometimes
-        -- when libs aren't at the project root some can slip through, so we remove them.
-        & V.filter
-          ( \(fqn, _) -> not (libSegment `elem` (NEL.toList $ Name.reverseSegments fqn))
-          )
-        & foldMapM \(fqn, ref) -> fmap (either (\err -> ([err], [])) (\doc -> ([], [doc]))) . runExceptT $ do
-          (declTokens, declArity) <- case ref of
-            Reference.Builtin _ -> pure (mempty, Arity 0)
-            Reference.DerivedId refId -> do
-              -- TODO: batchify this
-              decl <- lift (Codebase.loadV1TypeDeclarationsByRefIdsOf codebase id refId) `whenNothingM` throwError (NoDeclForType fqn ref)
-              pure $ (tokensForDecl refId decl, Arity . fromIntegral . length . DD.bound $ DD.asDataDecl decl)
-          let basicTokens = Set.fromList [NameToken fqn, HashToken $ Reference.toShortHash ref]
-          typeSummary <- lift $ Summary.typeSummariesForReferencesOf codebase Nothing id (ref, Just fqn)
+    let nonLibTypes =
+          types
+            -- Most lib names are already filtered out by using the name lookup; but sometimes
+            -- when libs aren't at the project root some can slip through, so we remove them.
+            & V.filter
+              ( \(fqn, _) -> not (libSegment `elem` (NEL.toList $ Name.reverseSegments fqn))
+              )
+    let (fqns, refs) = V.unzip nonLibTypes
+    let partitioned :: V.Vector (Either ([DefnIndexingFailure], Set (DefnSearchToken TypeReference), Arity) (Reference.Id, Reference.Id))
+        partitioned =
+          refs <&> \case
+            Reference.Builtin _ -> Left (mempty, mempty, Arity 0)
+            Reference.DerivedId refId -> Right (refId, refId)
+    (errs, declTokens :: (V.Vector (Set (DefnSearchToken typeRef0))), arities :: V.Vector Arity) <- do
+      Codebase.loadV1TypeDeclarationsByRefIdsOf codebase (traverse . _Right . _2) partitioned
+        <&> itraversed <. _Right
+          %@~ ( \i ->
+                  \case
+                    (refId, Just decl) -> ([], tokensForDecl refId decl, Arity . fromIntegral . length . DD.bound $ DD.asDataDecl decl)
+                    (refId, Nothing) -> ([(NoDeclForType (fqns V.! i) $ Reference.DerivedId refId)], mempty, Arity 0)
+              )
+        <&> fmap (either id id)
+        <&> V.unzip3
+    let basicTokens = Data.zipWith2 fqns refs \fqn ref -> Set.fromList [NameToken fqn, HashToken $ Reference.toShortHash ref]
+    let allTokens = Data.zipWith2 declTokens basicTokens Set.union
+    typeSummaries <- Summary.typeSummariesForReferencesOf codebase Nothing traversed (Data.zip2 refs (Just <$> fqns))
+    let defDocuments = Data.zipWith5 refs fqns typeSummaries allTokens arities $ \ref fqn typeSummary tokens arity ->
           let sh = Reference.toShortHash ref
-          let dd =
-                DefinitionDocument
-                  { rootBranchHashId,
-                    fqn,
-                    hash = sh,
-                    tokens = declTokens <> basicTokens,
-                    arity = declArity,
-                    tag = ToTTypeTag (typeSummary.tag),
-                    metadata = ToTTypeSummary typeSummary
-                  }
-          pure dd
+           in DefinitionDocument
+                { rootBranchHashId,
+                  fqn,
+                  hash = sh,
+                  tokens,
+                  arity,
+                  tag = ToTTypeTag (typeSummary.tag),
+                  metadata = ToTTypeSummary typeSummary
+                }
     -- It's much more efficient to build only one PPE per batch.
-    let allDeps = setOf (folded . folding tokens . folded . to LD.TypeReference) refDocs
+    let allDeps = setOf (folded . folding tokens . folded . to LD.TypeReference) defDocuments
     pped <- PPEPostgres.ppedForReferences namesPerspective allDeps
     let ppe = PPED.unsuffixifiedPPE pped
-    let namedDocs :: [DefinitionDocument Name (Name, ShortHash)]
+    let namedDocs :: V.Vector (DefinitionDocument Name (Name, ShortHash))
         namedDocs =
-          refDocs
+          defDocuments
             & traversed . field @"tokens" %~ Set.mapMaybe \token -> do
               for token \ref -> do
                 name <- PPE.types ppe ref
                 pure $ (HQ'.toName name, Reference.toShortHash ref)
-    badNames <- DDQ.insertDefinitionDocuments namedDocs
-    pure (errs, badNames)
+    badNames <- DDQ.insertDefinitionDocuments $ V.toList namedDocs
+    pure (fold errs, badNames)
 
 -- | Compute the search tokens for a type declaration.
 -- Note that constructors are handled separately when syncing terms.

src/Share/Utils/Data.hs

@@ -5,6 +5,8 @@ module Share.Utils.Data
     zipWith3,
     zip4,
     zipWith4,
+    zip5,
+    zipWith5,
     mapFromSelf,
   )
 where
@@ -47,6 +49,15 @@ zipWith4 as bs cs ds f =
   zip4 as bs cs ds
     <&> (\(a, b, c, d) -> f a b c d)
 
+zip5 :: (Zip.Zip t) => t a -> t b -> t c -> t d -> t e -> t (a, b, c, d, e)
+zip5 as bs cs ds es =
+  Zip.zipWith (\(a, b) (c, d, e) -> (a, b, c, d, e)) (Zip.zip as bs) (zip3 cs ds es)
+
+zipWith5 :: (Zip.Zip t) => t a -> t b -> t c -> t d -> t e -> (a -> b -> c -> d -> e -> f) -> t f
+zipWith5 as bs cs ds es f =
+  zip5 as bs cs ds es
+    <&> (\(a, b, c, d, e) -> f a b c d e)
+
 mapFromSelf :: (Ord k) => [k] -> Map k k
 mapFromSelf ks =
   Map.fromList (ks <&> \k -> (k, k))