wip

hbs2-git3/app/Main.hs

@@ -1242,6 +1242,17 @@ instance Exception ReadLogError
 
 instance ReadLogOpts ()
 
+type NumBytes = Int
+
+class Monad m => BytesReader m where
+  noBytesLeft    :: m Bool
+  readBytes      :: NumBytes -> m ByteString
+
+  readBytesMaybe :: NumBytes -> m (Maybe ByteString)
+  readBytesMaybe n = do
+    bs <- readBytes n
+    if LBS.length bs == fromIntegral n then pure (Just bs) else pure Nothing
+
 newtype ConsumeLBS m a = ConsumeLBS { fromConsumeLBS :: StateT ByteString m a  }
                          deriving newtype ( Applicative
                                           , Functor
@@ -1261,6 +1272,13 @@ readChunkThrow n = do
     put $! that
     pure this
 
+readChunkSimple :: Monad m => Int -> ConsumeLBS m ByteString
+readChunkSimple n = do
+  lbs <- get
+  let (this, that) = LBS.splitAt (fromIntegral n) lbs
+  put $! that
+  pure this
+
 reminds :: Monad m => ConsumeLBS m Int
 reminds = gets (fromIntegral . LBS.length)
 
@@ -1270,6 +1288,10 @@ consumed = gets LBS.null
 runConsumeLBS :: Monad m => ByteString -> ConsumeLBS m a -> m a
 runConsumeLBS s m  = evalStateT (fromConsumeLBS m) s
 
+instance Monad m => BytesReader (ConsumeLBS m) where
+  readBytes n = readChunkSimple n
+  noBytesLeft = consumed
+
 readLogFileLBS :: forall opts m . ( MonadIO m, ReadLogOpts opts )
                => opts
                -> ByteString
@@ -1277,12 +1299,20 @@ readLogFileLBS :: forall opts m . ( MonadIO m, ReadLogOpts opts )
                -> m Int
 
 readLogFileLBS _ lbs action = runConsumeLBS lbs $ flip fix 0 \go n -> do
-  done <- consumed
+  done <- noBytesLeft
   if done then pure n
     else do
-      ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
+      ssize <- readBytesMaybe 4
-      hash  <- readChunkThrow 20 <&> GitHash . LBS.toStrict
+                  >>= orThrow SomeReadLogError
-      sdata <- readChunkThrow ( ssize - 20 )
+                  <&> fromIntegral . N.word32 . LBS.toStrict
+
+      hash  <- readBytesMaybe 20
+                  >>= orThrow SomeReadLogError
+                  <&> GitHash . LBS.toStrict
+
+      sdata <- readBytesMaybe ( ssize - 20 )
+                  >>= orThrow SomeReadLogError
+
       void $ lift $ action hash (fromIntegral ssize) sdata
       go (succ n)
 
@@ -1775,6 +1805,12 @@ theDict = do
           for_ (HS.fromList r) $ \x -> do
             liftIO $ print x
 
+        entry $ bindMatch "test:git:zstd:train" $ nil_ $ \case
+          [ StringLike fn ] -> do
+            file <- liftIO $ mmapFileByteString fn Nothing
+            pure ()
+
+          _ -> throwIO (BadFormException @C nil)
 
         entry $ bindMatch "test:git:read-log-file" $ nil_ $ \syn -> lift do
           let (_, argz) = splitOpts [] syn
@@ -1811,8 +1847,14 @@ theDict = do
             done <- consumed
             if done then pure ()
               else do
-                ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
+                ssize  <- readBytesMaybe 4
-                hash   <- readChunkThrow 20 <&> GitHash . LBS.toStrict
+                               >>= orThrow SomeReadLogError
+                               <&> fromIntegral . N.word32 . LBS.toStrict
+
+                hash   <- readBytesMaybe 20
+                             >>= orThrow SomeReadLogError
+                             <&> GitHash . LBS.toStrict
+
                 liftIO $ print $ pretty hash <+> pretty ssize
                 go (succ n)
 
@@ -1825,8 +1867,14 @@ theDict = do
               done <- consumed
               if done then pure ()
                 else do
-                  ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
+                  ssize  <- readBytesMaybe 4
-                  hash   <- readChunkThrow 20 <&> GitHash . LBS.toStrict
+                                 >>= orThrow SomeReadLogError
+                                 <&> fromIntegral . N.word32 . LBS.toStrict
+
+                  hash   <- readBytesMaybe 20
+                                >>= orThrow SomeReadLogError
+                                <&> GitHash . LBS.toStrict
+
                   lift $ S.yield hash
                   go (succ n)
 
@@ -1834,7 +1882,7 @@ theDict = do
 
             for_ hashes $ \h -> do
              -- found <- binSearchBS 24 (BS.take 20 . BS.drop 4) ( show . pretty . GitHash ) (coerce h) file
-              found <- liftIO $ binSearchWTF 24 (BS.take 20 . BS.drop 4) (coerce h) file
+              found <- liftIO $ binarySearchBS 24 (BS.take 20 . BS.drop 4) (coerce h) file
               liftIO $ print $ pretty h <+> pretty (isJust found)
 
           _ -> throwIO (BadFormException @C nil)
@@ -1852,7 +1900,7 @@ theDict = do
                         & orThrowUser "no index specified"
 
           file <- liftIO $ mmapFileByteString idxName Nothing
-          r <- liftIO $ binSearchWTF 24 (BS.take 20 . BS.drop 4) (coerce hash) file
+          r <- liftIO $ binarySearchBS 24 (BS.take 20 . BS.drop 4) (coerce hash) file
 
           liftIO $ print $ pretty r
 
@@ -1865,13 +1913,19 @@ theDict = do
               done <- consumed
               if done then pure ()
                 else do
-                  ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
+                  ssize  <- readBytesMaybe 4
-                  hash   <- readChunkThrow 20 <&> GitHash . LBS.toStrict
+                                >>= orThrow SomeReadLogError
+                                <&> fromIntegral . N.word32 . LBS.toStrict
+
+                  hash   <- readBytesMaybe 20
+                               >>= orThrow SomeReadLogError
+                               <&> GitHash . LBS.toStrict
+
                   lift $ S.yield hash
                   go (succ n)
 
             for_ hashes $ \h ->do
-              found <- linearSearch h lbs
+              found <- linearSearchLBS h lbs
               liftIO $ print $ pretty h <+> pretty (isJust found)
 
           _ -> throwIO (BadFormException @C nil)
@@ -1887,7 +1941,7 @@ theDict = do
               done <- consumed
               if done then pure ()
                 else do
-                  shit <- LBS.toStrict <$> readChunkThrow 24
+                  shit <- LBS.toStrict <$> (readBytesMaybe 24 >>= orThrow SomeReadLogError)
                   lift $ S.yield shit
                   go (succ n)
 
@@ -1902,48 +1956,12 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-            -- let m = HS.fromList (fmap (coerce @_ @BS.ByteString) hashes)
-
-
-            -- for_ hashes $ \h -> do
-            --   let found = HS.member (coerce h) m
-            --   liftIO $ print $ pretty h <+> pretty found
-
-
-        entry $ bindMatch "test:git:log:index:naive:search:map:test" $ nil_ $ \case
-          [ StringLike fn ] -> do
-
-            lbs <- liftIO $ LBS.readFile fn
-
-            hashes <- S.toList_ $ runConsumeLBS lbs $ flip fix 0 \go n -> do
-              done <- consumed
-              if done then pure ()
-                else do
-                  ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
-                  hash   <- readChunkThrow 20 <&> GitHash . LBS.toStrict
-                  lift $ S.yield hash
-                  go (succ n)
-
-            let m = HS.fromList (fmap (coerce @_ @BS.ByteString) hashes)
-
-
-            for_ hashes $ \h -> do
-              let found = HS.member (coerce h) m
-              liftIO $ print $ pretty h <+> pretty found
-
---             for_ hashes $ \h ->do
---               found <- linearSearch h lbs
---               liftIO $ print $ pretty h <+> pretty (isJust found)
-
-          _ -> throwIO (BadFormException @C nil)
-
-
         entry $ bindMatch "test:git:log:index:naive:search:linear" $ nil_ $ \case
           [ StringLike ha, StringLike fn ] -> lift do
             hash <- fromStringMay @GitHash ha & orThrowUser "not a git hash"
 
             lbs <- liftIO $ LBS.readFile fn
-            found <- linearSearch hash lbs
+            found <- linearSearchLBS hash lbs
             liftIO $ print $ pretty found
 
           _ -> throwIO (BadFormException @C nil)
@@ -1969,26 +1987,6 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-          -- let (_, argz) = splitOpts [] syn
-          -- let fnames = [ x | StringLike x <- argz]
-
-          -- s <- randomIO @Word16
-          -- liftIO $ withBinaryFile (show ("index" <> pretty s <> ".idx")) AppendMode $ \fh -> do
-
-          --   for_ fnames $ \f -> do
-          --     theLog <- liftIO $ LBS.readFile f
-
-          --     all <- S.toList_ $ void $ readLogFileLBS () theLog $ \h s lbs -> do
-          --               S.yield (coerce @_ @BS.ByteString h)
-          --               debug $ "object" <+> pretty h
-
-          --     let sorted = L.sort all
-
-          --     for_ sorted $ \ghs -> do
-          --       let ks = BS.length ghs
-          --       let entrySize = N.bytestring32 (fromIntegral ks)
-          --       BS.hPutStr fh entrySize
-          --       BS.hPutStr fh ghs
 
         entry $ bindMatch "test:git:log:index:entry" $ nil_ $ \case
           [LitIntVal i, StringLike fn] -> lift do
@@ -2098,14 +2096,19 @@ theDict = do
                     BS.hPutStr  ofile kbs
                     LBS.hPutStr ofile lbs
 
-linearSearch hash lbs = do
+linearSearchLBS hash lbs = do
 
   found <- S.toList_ $ runConsumeLBS lbs $ flip fix 0 \go n -> do
     done <- consumed
     if done then pure ()
       else do
-        ssize  <- readChunkThrow 4  <&> fromIntegral . N.word32 . LBS.toStrict
+        ssize  <- readBytesMaybe 4
-        hash1   <- readChunkThrow 20 <&> LBS.toStrict
+                        >>= orThrow SomeReadLogError
+                        <&> fromIntegral . N.word32 . LBS.toStrict
+
+        hash1   <- readBytesMaybe 20
+                       >>= orThrow SomeReadLogError
+                       <&> LBS.toStrict
 
         case (compare hash1 (coerce hash)) of
           EQ -> lift $ S.yield n
@@ -2113,53 +2116,15 @@ linearSearch hash lbs = do
 
   pure $ listToMaybe found
 
--- binarySearch :: BS.ByteString -> Int -> BS.ByteString -> Maybe Int
--- binarySearch file recordSize targetKey = go 0 (BS.length file `div` recordSize - 1)
---   where
---     go lo hi
---       | lo > hi = do
---           -- putStrLn $ "Key not found: " ++ BSC.unpack targetKey
---           pure Nothing
---       | otherwise = do
---           let mid = (lo + hi) `div` 2
---           let offset = mid * recordSize
---           let record = BS.take recordSize (BS.drop offset file)
---           let key = getKey record
---           -- putStrLn $ "lo: " ++ show lo ++ ", hi: " ++ show hi ++ ", mid: " ++ show mid ++ ", offset: " ++ show offset
---           -- putStrLn $ "Key at offset: " ++ BSC.unpack key ++ ", Target key: " ++ BSC.unpack targetKey
---           case compare key targetKey of
---             EQ -> do
---               -- putStrLn $ "Key found at offset: " ++ show offset
---               pure (Just offset)
---             LT -> go (mid + 1) hi
---             GT -> go lo (mid - 1)
 
---     getKey :: BS.ByteString -> BS.ByteString
+binarySearchBS :: MonadIO m
---     getKey bs = BS.take 20 $ BS.drop 4 bs
+             => Int           -- ^ record size
-
--- binarySearchByBounds :: (PrimMonad m, MVector v e)
---                      => Comparison e -> v (PrimState m) e -> e -> Int -> Int -> m Int
--- binarySearchByBounds cmp vec e = loop
---  where
---  loop !l !u
---    | u <= l    = return l
---    | otherwise = do e' <- unsafeRead vec k
---                     case cmp e' e of
---                       LT -> loop (k+1) u
---                       EQ -> return k
---                       GT -> loop l     k
---   where k = midPoint u l
--- {-# INLINE binarySearchByBounds #-}
-
-
-binSearchWTF :: MonadIO m
-             => Int -- ^ record size
              -> ( BS.ByteString -> BS.ByteString ) -- ^ key extractor
-             ->  BS.ByteString -- ^ key
+             -> BS.ByteString -- ^ key
              -> BS.ByteString -- ^ source
              -> m (Maybe Int)
 
-binSearchWTF rs getKey s source = do
+binarySearchBS rs getKey s source = do
   let maxn = BS.length source `div` rs
   loop 0 maxn
   where
@@ -2173,127 +2138,6 @@ binSearchWTF rs getKey s source = do
 
       where k = (l + u) `div` 2
 
-binSearchBS :: MonadIO m
-            => Int
-            -> ( BS.ByteString -> BS.ByteString )
-            -> ( BS.ByteString -> String )
-            -> BS.ByteString
-            -> BS.ByteString
-            -> m (Maybe Int)
-
-binSearchBS rlen getKey nice s source = do
-
-  flip fix (0,source) $ \next (i,bs) -> do
-
-    let num = BS.length bs `quot` rlen
-
-    let n = BS.length bs `mod` rlen
-
-    when (n /= 0 ) $ error "FUCKED!"
-
-    if | num == 0 -> pure Nothing
-       | num == 1 && getKey bs == s -> pure (Just i)
-       | num == 1 -> pure Nothing
-       | otherwise  -> do
-
-        let iMid  = (num `div` 2)
-        let iOff  = iMid * rlen
-
-        let (sa,sb) = BS.splitAt iOff bs
-
-        let el = getKey sb
-
-        if | s < el -> next (i, sa)
-           | s > el -> next (i, sb)
-           | otherwise -> pure $ Just i
-
-        -- case compare s el of
-        --   EQ -> pure (Just iOff)
-        --   LT -> next (i, sa)
-        --   GT -> next (i+iMid, BS.drop rlen sb)
-
--- binarySearchIO :: BS.ByteString -> Int -> BS.ByteString -> IO (Maybe Int)
--- binarySearchIO file recordSize targetKey = go 0 (BS.length file `div` recordSize - 1)
---   where
---     go lo hi
---       | lo > hi = do
---           print $ "Key not found: " <+> pretty (GitHash targetKey)
---           pure Nothing
---       | lo == hi = do
---           let offset = lo * recordSize
---           let record = BS.take recordSize (BS.drop offset file)
---           let key = getKey record
---           print $ "Final check at offset: " <+> pretty offset
---           print $ "Key at offset: " <+> pretty (GitHash key) <+> "Target key: " <+> pretty (GitHash targetKey)
---           if key == targetKey
---             then do
---               print $ "Key found at offset: " <+> pretty offset
---               pure (Just lo)
---             else do
---               print $ "Key not found in final check: " <+> pretty (GitHash targetKey)
---               pure Nothing
---       | otherwise = do
---           let mid = (lo + hi) `div` 2
---           let offset = mid * recordSize
---           let record = BS.take recordSize (BS.drop offset file)
---           let key = getKey record
-
---           print $ "lo: " <+> pretty lo <+> ", hi: " <+> pretty hi <+> ", mid: " <+> pretty mid <+> ", offset: " <+> pretty offset
---           print $ "Key at offset: " <+> pretty (GitHash key) <+> "Target key: " <+> pretty (GitHash targetKey)
-
---           case compare key targetKey of
---             EQ -> do
---               print $ "Key found at mid: " <+> pretty mid <+> ", offset: " <+> pretty offset
---               pure (Just mid)
---             LT -> do
---               print $ "Moving right"
---               go (mid + 1) hi
---             GT -> do
---               print $ "Moving left"
---               go lo (mid - 1)
-
---     getKey :: BS.ByteString -> BS.ByteString
---     getKey bs = BS.take 20 $ BS.drop 4 bs
-
-
-binarySearchIO :: BS.ByteString -> Int -> BS.ByteString -> IO (Maybe Int)
-binarySearchIO file recordSize targetKey = go 0 (BS.length file `div` recordSize - 1)
-  where
-    go lo hi
-      | lo > hi = do
-          pure Nothing
-      | otherwise = do
-          let mid = (lo + hi) `div` 2
-          let offset = mid * recordSize
-          let record = BS.take recordSize (BS.drop offset file)
-          let key = getKey record
-          case compare key targetKey of
-            EQ -> do
-              pure (Just mid)
-            LT -> do
-              go (mid + 1) hi
-            GT -> do
-              go lo (mid - 1)
-
-    getKey :: BS.ByteString -> BS.ByteString
-    getKey bs = BS.take 20 $ BS.drop 4 bs
-
-
--- binarySearch :: BS.ByteString -> Int -> BS.ByteString -> Maybe Int
--- binarySearch file recordSize targetKey = go 0 (BS.length file `div` recordSize - 1)
---   where
---     go lo hi
---       | lo > hi = Nothing
---       | otherwise =
---           let mid = (lo + hi) `div` 2
---               offset = mid * recordSize
---               record = BS.take recordSize (BS.drop offset file)
---               key = BS.take 20 $ BS.drop 4 record
---           in case compare key targetKey of
---                EQ -> Just mid
---                LT -> go (mid + 1) hi
---                GT -> go lo (mid - 1)
-
 -- debugPrefix :: LoggerEntry -> LoggerEntry
 debugPrefix = toStderr . logPrefix "[debug] "