Merge pull request #58 from input-output-hk/jdral/generalise-iohasbuffs

Make `ioHasBufFS` more general
input-output-hk · May 1, 2024 · b813361 · b813361
2 parents 3c5b49c + 62bc69a
commit b813361
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 13 deletions.
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -24,7 +24,7 @@ jobs:
       matrix:
         ghc: ["8.10.7", "9.2.8", "9.4.8", "9.6.4", "9.8.2"]
         cabal: ["3.10.3.0"]
-        os: [ubuntu-latest, windows-latest, macOS-latest]
+        os: [ubuntu-latest, windows-latest, macOS-13]
 
     timeout-minutes: 60
 

diff --git a/cabal.project b/cabal.project
@@ -12,9 +12,9 @@ repository cardano-haskell-packages
 
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2024-02-22T20:53:27Z
+  , hackage.haskell.org 2024-05-01T04:59:38Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2024-02-23T09:45:19Z
+  , cardano-haskell-packages 2024-04-30T19:46:33Z
 
 packages:
   fs-api

diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE TypeFamilies  #-}
+{-# LANGUAGE TypeOperators #-}
+
 -- | IO implementation of the 'HasFS' class
 module System.FS.IO (
     -- * IO implementation & monad
@@ -9,7 +12,7 @@ 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           Control.Monad.Primitive (PrimMonad (..))
 import qualified Data.ByteString.Unsafe as BS
 import           Data.Primitive (withMutableByteArrayContents)
 import qualified Data.Set as Set
@@ -103,19 +106,22 @@ _rethrowFsError mount fp action = do
   HasBufFS
 -------------------------------------------------------------------------------}
 
-ioHasBufFS :: (MonadIO m, PrimBase m) => MountPoint -> HasBufFS m HandleIO
+ioHasBufFS ::
+     (MonadIO m, PrimState IO ~ PrimState m)
+  => MountPoint
+  -> HasBufFS m HandleIO
 ioHasBufFS mount = HasBufFS {
-      hGetBufSome = \(Handle h fp) buf bufOff c ->
-        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+      hGetBufSome = \(Handle h fp) buf bufOff c ->  liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
           F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
-    , hGetBufSomeAt = \(Handle h fp) buf bufOff c off ->
-        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+    , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
           F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
-    , hPutBufSome = \(Handle h fp) buf bufOff c ->
-        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+    , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
           F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c
-    , hPutBufSomeAt = \(Handle h fp) buf bufOff c off ->
-        withMutableByteArrayContents buf $ \ptr -> liftIO $ rethrowFsError fp $
+    , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $
+        withMutableByteArrayContents buf $ \ptr ->
           F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)
     }
   where