Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Make ioHasBufFS more general #58

Merged
merged 2 commits into from
May 1, 2024
Merged

Make ioHasBufFS more general #58

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
351dd51
Make `ioHasBufFS` more general
jorisdral Apr 23, 2024
62bc69a
Use MacOS-13 instead of MacOS-latest in GHA
jorisdral May 1, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .github/workflows/haskell.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
4 changes: 2 additions & 2 deletions cabal.project
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
26 changes: 16 additions & 10 deletions fs-api/src/System/FS/IO.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | IO implementation of the 'HasFS' class
module System.FS.IO (
-- * IO implementation & monad
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down