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

wip19

This commit is contained in:
voidlizard 2024-12-05 10:23:12 +03:00
parent 284425bd1d
commit 86a73fbe67
1 changed files with 11 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -389,13 +389,6 @@ gitObjectExists what = do
data UState = data UState =
UHead ByteString UHead ByteString
unpackPEntry :: [ByteString] -> Maybe (GitObjectType, Word32, GitHash)
unpackPEntry = \case
("C" : s : h : _) -> (Commit,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
("B" : s : h : _) -> (Blob,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
("T" : s : h : _) -> (Tree,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
_ -> Nothing
data ES = data ES =
ES [BS.ByteString] Result ES [BS.ByteString] Result
@ -453,16 +446,7 @@ data WState =
WStart WStart
| WNextSBlock | WNextSBlock
| WReadSBlock Int HashRef | WReadSBlock Int HashRef
| WCheckSBlock HashRef ByteString | WProcessCBlock Int HashRef
| WWalkSBlock HashRef (MTree [HashRef])
| WProcessCBlock HashRef
| WGetInput
| WEnd
data WInput =
WInputSBlock
| WInputCBlock HashRef
data EOp = data EOp =
EGitObject GitObjectType GitHash (Maybe GitTreeEntry) ByteString EGitObject GitObjectType GitHash (Maybe GitTreeEntry) ByteString
@ -1012,23 +996,26 @@ theDict = do
CBlockParents p -> do CBlockParents p -> do
debug $ "parents" <+> pretty p debug $ "parents" <+> pretty p
next =<< atomically do next =<< atomically do
d <- readTVar done
for_ (zip [1..] p) $ \(i,x) -> do for_ (zip [1..] p) $ \(i,x) -> do
isDone <- readTVar done <&> HS.member x unless (HS.member x d) do
unless isDone do
modifyTVar q (HPSQ.insert x (prio-i) ()) modifyTVar q (HPSQ.insert x (prio-i) ())
isDone <- readTVar done <&> HS.member h let hDone = HS.member h d
unless isDone do
unless hDone do
modifyTVar q (HPSQ.insert h prio ()) modifyTVar q (HPSQ.insert h prio ())
qq <- readTVar q qq <- readTVar q
if not (any (`HPSQ.member` qq) p) && not isDone then do if not (any (`HPSQ.member` qq) p) && not hDone then do
pure $ WProcessCBlock h pure $ WProcessCBlock prio h
else do else do
pure WNextSBlock pure WNextSBlock
WProcessCBlock h -> do WProcessCBlock _ h -> do
what <- cached cache h $ S.toList_ (readCBlock sto h S.yield) what <- cached cache h $ S.toList_ (readCBlock sto h S.yield)
atomically $ modifyTVar done ( HS.insert h )
uncache cache h
debug $ "process cblock" <+> pretty h debug $ "process cblock" <+> pretty h
@ -1039,12 +1026,8 @@ theDict = do
CBlockData{} -> do CBlockData{} -> do
debug $ green "process cblock data" <+> pretty h debug $ green "process cblock data" <+> pretty h
atomically $ modifyTVar done ( HS.insert h )
uncache cache h
next $ WNextSBlock next $ WNextSBlock
_ -> debug "WTF?" -- none
_ -> throwIO (BadFormException @C nil) _ -> throwIO (BadFormException @C nil)
entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> lift do entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> lift do