WIP: MutableByteArray as buffer

fs-api/fs-api.cabal

@@ -35,7 +35,6 @@ library
     System.FS.API.Lazy
     System.FS.API.Strict
     System.FS.API.Types
-    System.FS.API.UBuffer
     System.FS.CRC
     System.FS.IO
     System.FS.IO.Internal

fs-api/src/System/FS/API.hs

@@ -28,13 +28,14 @@ module System.FS.API (
   ) where
 
 import           Control.Monad.Class.MonadThrow
+import           Control.Monad.Primitive
 import qualified Data.ByteString as BS
 import           Data.Int (Int64)
+import           Data.Primitive
 import           Data.Set (Set)
 import           Data.Word
 
 import           System.FS.API.Types as Types
-import           System.FS.API.UBuffer
 
 import           Util.CallStack
 
@@ -203,31 +204,35 @@ data HasBufFS m h = HasBufFS {
     -- See __User-supplied buffers__.
     hGetBufSome      :: HasCallStack
                      => Handle h
-                     -> UBuffer -- ^ Buffer to read bytes into
+                     -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into
+                     -> Int -- ^ Offset into buffer
                      -> Word64  -- ^ The number of bytes to read
                      -> m Word64
     -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer.
     -- See __User-supplied buffers__.
   , hGetBufSomeAt    :: HasCallStack
                      => Handle h
-                     -> UBuffer   -- ^ Buffer to read bytes into
-                     -> Word64    -- ^ The number of bytes to read
+                     -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to read
                      -> AbsOffset -- ^ The file offset at which to read
                      -> m Word64
     -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer.
     -- See __User-supplied buffers__.
   , hPutBufSome      :: HasCallStack
                      => Handle h
-                     -> UBuffer -- ^ Buffer to write bytes from
+                     -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
+                     -> Int -- ^ Offset into buffer
                      -> Word64  -- ^ The number of bytes to write
                      -> m Word64
     -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer
     -- at a given file offset. This offset does not affect the offset stored in
     -- the file handle (see also 'hGetSomeAt'). See __User-supplied buffers__.
   , hPutBufSomeAt    :: HasCallStack
                      => Handle h
-                     -> UBuffer   -- ^ Buffer to write bytes from
-                     -> Word64    -- ^ The number of bytes to write
+                     -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
+                     -> Int -- ^ Offset into buffer
+                     -> Word64  -- ^ The number of bytes to write
                      -> AbsOffset -- ^ The file offset at which to write
                      -> m Word64
   }
@@ -263,13 +268,14 @@ hGetBufAllAt :: forall m h. (HasCallStack, MonadThrow m)
           => HasFS m h
           -> HasBufFS m h
           -> Handle h
-          -> UBuffer   -- ^ Buffer to read bytes into
+          -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+          -> Int -- ^ Offset into buffer
           -> AbsOffset -- ^ The file offset at which to read
           -> m Word64
-hGetBufAllAt hfs hbfs h buf off = do
+hGetBufAllAt hfs hbfs h buf bufOff off = do
     sz <- hGetSize hfs h
     let c = sz - unAbsOffset off
-    hGetBufExactlyAt hfs hbfs h buf c off
+    hGetBufExactlyAt hfs hbfs h buf bufOff c off
 
 -- | Wrapper for 'hGetBufSome' that ensures that we read exactly as many
 -- bytes as requested. If EOF is found before the requested number of bytes is
@@ -278,16 +284,17 @@ hGetBufExactly :: forall m h. (HasCallStack, MonadThrow m)
                => HasFS m h
                -> HasBufFS m h
                -> Handle h
-               -> UBuffer -- ^ Buffer to read bytes into
+               -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into
+               -> Int -- ^ Offset into buffer
                -> Word64  -- ^ The number of bytes to read
                -> m Word64
-hGetBufExactly hfs hbfs h buf c = go 0 buf
+hGetBufExactly hfs hbfs h buf bufOff c = go c bufOff
   where
-    go :: Word64 -> UBuffer -> m Word64
-    go !remainingCount !currentBuf
+    go :: Word64 -> Int -> m Word64
+    go !remainingCount !currentBufOff
       | remainingCount == 0 = pure c
       | otherwise            = do
-          readBytes <- hGetBufSome hbfs h currentBuf c
+          readBytes <- hGetBufSome hbfs h buf currentBufOff c
           if readBytes == 0 then
             throwIO FsError {
                 fsErrorType   = FsReachedEOF
@@ -299,7 +306,7 @@ hGetBufExactly hfs hbfs h buf c = go 0 buf
               }
           -- We know the length <= remainingBytes, so this can't underflow.
           else go (remainingCount - readBytes)
-                  (currentBuf `plusUBuffer` fromIntegral readBytes)
+                  (currentBufOff + fromIntegral readBytes)
 
 -- | Wrapper for 'hGetBufSomeAt' that ensures that we read exactly as many bytes
 -- as requested. If EOF is found before the requested number of bytes is read,
@@ -308,17 +315,18 @@ hGetBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
                  => HasFS m h
                  -> HasBufFS m h
                  -> Handle h
-                 -> UBuffer   -- ^ Buffer to read bytes into
+                 -> MutableByteArray (PrimState m)   -- ^ Buffer to read bytes into
+                 -> Int -- ^ Offset into buffer
                  -> Word64    -- ^ The number of bytes to read
                  -> AbsOffset -- ^ The file offset at which to read
                  -> m Word64
-hGetBufExactlyAt hfs hbfs h buf c off = go 0 off buf
+hGetBufExactlyAt hfs hbfs h buf bufOff c off = go c off bufOff
   where
-    go :: Word64 -> AbsOffset -> UBuffer -> m Word64
-    go !remainingCount !currentOffset currentBuf
+    go :: Word64 -> AbsOffset -> Int -> m Word64
+    go !remainingCount !currentOffset !currentBufOff
       | remainingCount == 0 = pure c
       | otherwise            = do
-          readBytes <- hGetBufSomeAt hbfs h currentBuf c currentOffset
+          readBytes <- hGetBufSomeAt hbfs h buf currentBufOff c currentOffset
           if readBytes == 0 then
             throwIO FsError {
                 fsErrorType   = FsReachedEOF
@@ -331,44 +339,46 @@ hGetBufExactlyAt hfs hbfs h buf c off = go 0 off buf
           -- We know the length <= remainingBytes, so this can't underflow.
           else go (remainingCount - readBytes)
                   (currentOffset + fromIntegral readBytes)
-                  (currentBuf `plusUBuffer` fromIntegral readBytes)
+                  (currentBufOff + fromIntegral readBytes)
 
 -- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as
 -- requested.
 hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m)
                  => HasBufFS m h
                  -> Handle h
-                 -> UBuffer -- ^ Buffer to write bytes from
+                 -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from
+                 -> Int -- ^ Offset into buffer
                  -> Word64  -- ^ The number of bytes to write
                  -> m Word64
-hPutBufExactly hbfs h buf c = go 0 buf
+hPutBufExactly hbfs h buf bufOff c = go c bufOff
   where
-    go :: Word64 -> UBuffer -> m Word64
-    go !remainingCount currentBuf = do
-      writtenBytes <- hPutBufSome hbfs h currentBuf remainingCount
+    go :: Word64 -> Int -> m Word64
+    go !remainingCount !currentBufOff = do
+      writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount
       let remainingCount' = remainingCount - writtenBytes
       if remainingCount' == 0
         then pure c
         else go remainingCount'
-                (currentBuf `plusUBuffer` fromIntegral writtenBytes)
+                (currentBufOff + fromIntegral writtenBytes)
 
 -- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as
 -- requested.
 hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)
                  => HasBufFS m h
                  -> Handle h
-                 -> UBuffer   -- ^ Buffer to write bytes from
+                 -> MutableByteArray (PrimState m)   -- ^ Buffer to write bytes from
+                 -> Int -- ^ Offset into buffer
                  -> Word64    -- ^ The number of bytes to write
                  -> AbsOffset -- ^ The file offset at which to write
                  -> m Word64
-hPutBufExactlyAt hbfs h buf c off = go 0 off buf
+hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff
   where
-    go :: Word64 -> AbsOffset -> UBuffer -> m Word64
-    go !remainingCount !currentOffset currentBuf = do
-      writtenBytes <- hPutBufSomeAt hbfs h currentBuf remainingCount currentOffset
+    go :: Word64 -> AbsOffset -> Int -> m Word64
+    go !remainingCount !currentOffset !currentBufOff = do
+      writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset
       let remainingCount' = remainingCount - writtenBytes
       if remainingCount' == 0
         then pure c
         else go remainingCount'
                 (currentOffset + fromIntegral writtenBytes)
-                (currentBuf `plusUBuffer` fromIntegral writtenBytes)
+                (currentBufOff + fromIntegral writtenBytes)

fs-api/src/System/FS/IO.hs

@@ -9,13 +9,15 @@ module System.FS.IO (
 import           Control.Concurrent.MVar
 import qualified Control.Exception as E
 import           Control.Monad.IO.Class (MonadIO (..))
+import           Control.Monad.Primitive (PrimBase)
 import qualified Data.ByteString.Unsafe as BS
+import           Data.Primitive
 import qualified Data.Set as Set
+import           Foreign (plusPtr)
 import qualified Foreign
 import           GHC.Stack
 import qualified System.Directory as Dir
 import           System.FS.API
-import           System.FS.API.UBuffer
 import qualified System.FS.IO.Internal as F
 import qualified System.FS.IO.Internal.Handle as H
 
@@ -102,20 +104,20 @@ _rethrowFsError mount fp action = do
   HasBufFS
 -------------------------------------------------------------------------------}
 
-ioHasBufFS :: MonadIO m => MountPoint -> HasBufFS m HandleIO
+ioHasBufFS :: (MonadIO m, PrimBase m) => MountPoint -> HasBufFS m HandleIO
 ioHasBufFS mount = HasBufFS {
-      hGetBufSome = \(Handle h fp) ubuf c -> liftIO $ rethrowFsError fp $
-        withUBufferContents ubuf $ \buf ->
-          fromIntegral <$> F.readBuf h buf (fromIntegral c)
-    , hGetBufSomeAt = \(Handle h fp) ubuf c off -> liftIO $ rethrowFsError fp $
-        withUBufferContents ubuf $ \buf ->
-          fromIntegral <$> F.preadBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off)
-    , hPutBufSome = \(Handle h fp) ubuf c -> liftIO $ rethrowFsError fp $
-        withUBufferContents ubuf $ \buf ->
-          fromIntegral <$> F.writeBuf h buf (fromIntegral c)
-    , hPutBufSomeAt = \(Handle h fp) ubuf c off -> liftIO $ rethrowFsError fp $
-        withUBufferContents ubuf $ \buf ->
-          fromIntegral <$> F.pwriteBuf h buf (fromIntegral c) (fromIntegral $ unAbsOffset off)
+      hGetBufSome = \(Handle h fp) buf bufOff c ->
+        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+          fromIntegral <$> F.readBuf h (ptr `plusPtr` bufOff) (fromIntegral c)
+    , hGetBufSomeAt = \(Handle h fp) buf bufOff c off ->
+        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+          fromIntegral <$> F.preadBuf h (ptr `plusPtr` bufOff) (fromIntegral c) (fromIntegral $ unAbsOffset off)
+    , hPutBufSome = \(Handle h fp) buf bufOff c ->
+        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+          fromIntegral <$> F.writeBuf h (ptr `plusPtr` bufOff) (fromIntegral c)
+    , hPutBufSomeAt = \(Handle h fp) buf bufOff c off ->
+        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+          fromIntegral <$> F.pwriteBuf h (ptr `plusPtr` bufOff) (fromIntegral c) (fromIntegral $ unAbsOffset off)
     }
   where
     rethrowFsError = _rethrowFsError mount