diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index a79c74ee..3184b633 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -571,6 +571,11 @@ runForms ss = for_ ss $ \s -> do compactStorageClose sto + ListVal [SymbolVal "git:list-refs"] -> do + refs <- listRefs False + for_ refs $ \(h,r) -> do + liftIO $ print $ pretty h <+> pretty r + ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 2bc989f1..f9600d31 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -24,6 +24,7 @@ import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString.Lazy (ByteString) import Data.Either import Data.Fixed +import Data.List qualified as List import Data.Maybe import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM @@ -109,8 +110,8 @@ listCommits = do spec = sq <> delims " \t" -listRefs :: FixmePerks m => FixmeM m [(GitHash, GitRef)] -listRefs = do +listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)] +listRefs every = do gd <- fixmeGetGitDirCLIOpt gitRunCommand [qc|git {gd} show-ref --dereference|] <&> fromRight mempty @@ -120,6 +121,14 @@ listRefs = do [h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b)) _ -> Nothing ) + >>= filterM filt + + where + filt _ | every = pure True + + filt (h,_) = do + done <- withState $ isProcessed $ ViaSerialise h + pure (not done) listBlobs :: FixmePerks m => GitHash -> m [(FilePath,GitHash)] listBlobs co = do @@ -159,7 +168,7 @@ scanGitLogLocal :: FixmePerks m scanGitLogLocal refMask play = do warn $ red "scanGitLogLocal" <+> pretty refMask - (t,refs) <- timeItT listRefs + (t,refs) <- timeItT $ listRefs False let hashes = fmap fst refs @@ -168,12 +177,15 @@ scanGitLogLocal refMask play = do let pat = [(True, refMask)] -- FIXME: use-cache-to-skip-already-processed-tips - logz <- S.toList_ $ for_ hashes $ \h -> do - done <- lift $ withState (isProcessed (ViaSerialise h)) - unless done do - blobs <- lift (listBlobs h >>= filterBlobs0 pat) - for_ blobs $ \(_,b) -> do - S.yield (h,b) + logz <- withState do + S.toList_ $ for_ hashes $ \h -> do + done <- lift $ isProcessed (ViaSerialise h) + unless done do + blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat) + when (List.null blobs) do + lift $ insertProcessed (ViaSerialise h) + for_ blobs $ \(_,b) -> do + S.yield (h,b) warn $ yellow "STEP 3" <+> "for each tree --- find log"