voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
voidlizard 2024-12-21 05:52:34 +03:00
parent 0eb2744979
commit 5d6400892b
1 changed files with 8 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
hbs2-git3/app/Main.hs
View File

@ -680,6 +680,9 @@ instance (Ord k, Hashable k) => Cached (CacheFixedHPSQ k v) k v where
pure v pure v
data RCC =
RCC [GitHash] (HashMap GitHash (HashSet GitHash))
readCommitChain :: ( HBS2GitPerks m readCommitChain :: ( HBS2GitPerks m
, MonadUnliftIO m , MonadUnliftIO m
, MonadReader Git3Env m , MonadReader Git3Env m
@ -694,26 +697,14 @@ readCommitChain _ h0 = flip runContT pure do
theReader <- ContT $ withGitCat theReader <- ContT $ withGitCat
void $ ContT $ bracket (pure theReader) stopProcess void $ ContT $ bracket (pure theReader) stopProcess
_g <- newTVarIO ( mempty :: HashMap GitHash (HashSet GitHash) ) flip fix (RCC [h0] mempty) $ \next -> \case
_s <- newIORef ( mempty :: HashSet GitHash ) RCC [] _ -> none
RCC ( h : hs ) seen | HM.member h seen -> next ( RCC hs seen )
flip fix [h0] $ \next -> \case RCC ( h : hs ) seen -> do
[] -> none
( h : hs ) -> do
modifyIORef' _s (HS.insert h)
liftIO $ print $ pretty h
co <- gitReadObjectMaybe theReader h >>= orThrowUser ("object not found" <+> pretty h) co <- gitReadObjectMaybe theReader h >>= orThrowUser ("object not found" <+> pretty h)
parents <- gitReadCommitParents (Just h) (snd co) parents <- gitReadCommitParents (Just h) (snd co)
debug $ "processed commit" <+> pretty h debug $ "processed commit" <+> pretty h
parents' <- flip filterM parents \p -> readIORef _s <&> (not . HS.member p) next $ RCC ( parents <> hs ) (HM.insertWith (<>) h (HS.fromList parents) seen)
next ( parents' <> hs )
-- atomically $ modifyTVar _g (HM.insertWith (<>) h (HS.fromList parents))
-- debug $ "processed commit" <+> pretty h
where
checkIsCommit x = do
none
export :: ( HBS2GitPerks m export :: ( HBS2GitPerks m
, MonadUnliftIO m , MonadUnliftIO m