wip

hbs2-git3/app/Main.hs

@@ -1121,8 +1121,9 @@ theDict = do
               che <- ContT withGitCat
               pure $ gitReadObjectMaybe che
 
-            out <- newTQueueIO
-            r <- ContT $ withAsync $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
+
+            new_ <- newTVarIO mempty
+            lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
 
               (_,self) <- gitCatBatchQ commit
                              >>= orThrow (GitReadError (show $ pretty commit))
@@ -1131,19 +1132,35 @@ theDict = do
 
               hashes <- gitReadTreeObjectsOnly commit
                             <&> ([commit,tree]<>)
-                            >>= filterM req
+                            -- >>= filterM req
 
-              atomically $ mapM_ (writeTQueue out) hashes
+              atomically $ modifyTVar new_ (HS.union (HS.fromList hashes))
 
-            fix \next -> do
-              h' <- atomically do
-                     pollSTM r >>= \case
-                       Just{}  -> pure Nothing
-                       Nothing -> readTQueue out <&> Just
 
-              maybe1 h' none $ \h ->do
-                liftIO $ print $ pretty h
-                next
+            fps <- lift $ listObjectIndexFiles
+                     <&> fmap fst
+                     >>= liftIO . mapM (`mmapFileByteString` Nothing)
+
+            allHashes <- readTVarIO new_
+            newHashes <- newTVarIO mempty
+            for_ fps $ \mmaped -> do
+              for_ allHashes $ \ha -> do
+                found <- binarySearchBS 56 ( BS.take 20 . BS.drop 4) (coerce ha) mmaped
+                when (isNothing found) do
+                  atomically $ modifyTVar newHashes (HS.insert ha)
+
+            readTVarIO newHashes >>= liftIO . print . pretty . HS.size
+           -- liftIO $ print $ pretty (HS
+
+            -- fix \next -> do
+            --   h' <- atomically do
+            --          pollSTM r >>= \case
+            --            Just{}  -> pure Nothing
+            --            Nothing -> readTQueue out <&> Just
+
+            --   maybe1 h' none $ \h ->do
+            --     liftIO $ print $ pretty h
+            --     next
 
         entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift $ connectedDo do
           let (opts, argz) = splitOpts [("--index",1),("--ref",1)] syn

hbs2-git3/lib/HBS2/Git3/State/Index.hs

@@ -101,37 +101,37 @@ startReflogIndexQueryQueue rq = flip runContT pure do
 
   mmaped <- liftIO $ for files (liftIO . flip mmapFileByteString Nothing)
 
-  r <- newTVarIO (mempty :: HashMap N.ByteString N.ByteString)
+  -- r <- newTVarIO (mempty :: HashMap N.ByteString N.ByteString)
 
-  -- FIXME: may-explode
-  for_ mmaped $ \bs -> do
-    scanBS bs $ \segment -> do
-      let ha = BS.take 20 segment & coerce
-      atomically $ modifyTVar r (HM.insert ha segment)
+  -- -- FIXME: may-explode
+  -- liftIO $ forConcurrently_ mmaped $ \bs -> do
+  --   scanBS bs $ \segment -> do
+  --     let ha = BS.take 20 segment & coerce
+  --     atomically $ modifyTVar r (HM.insert ha segment)
 
-  forever do
-    (s, f, answ) <- atomically $ readTQueue rq
-    found <- readTVarIO r <&> HM.lookup s
-
-    atomically do
-      case found of
-        Nothing -> writeTMVar answ Nothing
-        Just x  -> writeTMVar answ (Just (f x))
-
-  -- forever $ liftIO do
+  -- forever do
   --   (s, f, answ) <- atomically $ readTQueue rq
+  --   found <- readTVarIO r <&> HM.lookup s
 
-  --   found <- forConcurrently mmaped $ \bs -> runMaybeT do
-  --              -- FIXME: size-hardcodes
-  --              w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs
-  --                     >>= toMPlus
+  --   atomically do
+  --     case found of
+  --       Nothing -> writeTMVar answ Nothing
+  --       Just x  -> writeTMVar answ (Just (f x))
 
-  --              let v = BS.drop ( w * 56 ) bs
+  forever $ liftIO do
+    (s, f, answ) <- atomically $ readTQueue rq
 
-  --              pure $ f v
+    found <- forConcurrently mmaped $ \bs -> runMaybeT do
+               -- FIXME: size-hardcodes
+               w <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) s bs
+                      >>= toMPlus
 
-  --   let what = headMay (catMaybes found)
-  --   atomically $ writeTMVar answ what
+               let v = BS.drop ( w * 56 ) bs
+
+               pure $ f v
+
+    let what = headMay (catMaybes found)
+    atomically $ writeTMVar answ what
 
 writeReflogIndex :: forall m . ( Git3Perks m
                                , MonadReader Git3Env m