module System.FS.BlockIO.Serial (
    serialHasBlockIO
  ) where

import           Control.Concurrent.Class.MonadMVar
import           Control.Monad (unless)
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)
import           Data.Primitive (MutableByteArray, isMutableByteArrayPinned)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
import           GHC.Stack (HasCallStack)
import           System.FS.API
import qualified System.FS.BlockIO.API as API
import           System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..))
import qualified System.FS.BlockIO.IO.Internal as IOI

{-# SPECIALISE serialHasBlockIO ::
     Eq h
  => (Handle h -> Bool -> IO ())
  -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> IO ())
  -> (Handle h -> API.FileOffset -> API.FileOffset -> IO ())
  -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO)))
  -> (Handle h -> IO ())
  -> (FsPath -> IO ())
  -> (FsPath -> FsPath -> IO ())
  -> HasFS IO h
  -> IO (API.HasBlockIO IO h)
  #-}
-- | IO instantiation of 'HasBlockIO', using an existing 'HasFS'. Thus this
-- implementation does not take advantage of parallel I\/O.
serialHasBlockIO ::
     (MonadThrow m, MonadMVar m, PrimMonad m, Eq h)
  => (Handle h -> Bool -> m ())
  -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> m ())
  -> (Handle h -> API.FileOffset -> API.FileOffset -> m ())
  -> (FsPath -> LockMode -> m (Maybe (API.LockFileHandle m)))
  -> (Handle h -> m ())
  -> (FsPath -> m ())
  -> (FsPath -> FsPath -> m ())
  -> HasFS m h
  -> m (API.HasBlockIO m h)
serialHasBlockIO :: forall (m :: * -> *) h.
(MonadThrow m, MonadMVar m, PrimMonad m, Eq h) =>
(Handle h -> Bool -> m ())
-> (Handle h -> FileOffset -> FileOffset -> Advice -> m ())
-> (Handle h -> FileOffset -> FileOffset -> m ())
-> (FsPath -> LockMode -> m (Maybe (LockFileHandle m)))
-> (Handle h -> m ())
-> (FsPath -> m ())
-> (FsPath -> FsPath -> m ())
-> HasFS m h
-> m (HasBlockIO m h)
serialHasBlockIO Handle h -> Bool -> m ()
hSetNoCache Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise Handle h -> FileOffset -> FileOffset -> m ()
hAllocate FsPath -> LockMode -> m (Maybe (LockFileHandle m))
tryLockFile Handle h -> m ()
hSynchronise FsPath -> m ()
synchroniseDirectory FsPath -> FsPath -> m ()
createHardLink HasFS m h
hfs = do
  IOCtx m
ctx <- SomeHasFS m -> m (IOCtx m)
forall (m :: * -> *). MonadMVar m => SomeHasFS m -> m (IOCtx m)
initIOCtx (HasFS m h -> SomeHasFS m
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS HasFS m h
hfs)
  HasBlockIO m h -> m (HasBlockIO m h)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasBlockIO m h -> m (HasBlockIO m h))
-> HasBlockIO m h -> m (HasBlockIO m h)
forall a b. (a -> b) -> a -> b
$ API.HasBlockIO {
      close :: HasCallStack => m ()
API.close = IOCtx m -> m ()
forall (m :: * -> *). MonadMVar m => IOCtx m -> m ()
close IOCtx m
ctx
    , submitIO :: HasCallStack =>
Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
API.submitIO = HasFS m h
-> IOCtx m -> Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
forall (m :: * -> *) h.
(HasCallStack, MonadMVar m, MonadThrow m, PrimMonad m) =>
HasFS m h
-> IOCtx m -> Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
submitIO HasFS m h
hfs IOCtx m
ctx
    , Handle h -> Bool -> m ()
hSetNoCache :: Handle h -> Bool -> m ()
hSetNoCache :: Handle h -> Bool -> m ()
API.hSetNoCache
    , Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m ()
hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m ()
API.hAdvise
    , Handle h -> FileOffset -> FileOffset -> m ()
hAllocate :: Handle h -> FileOffset -> FileOffset -> m ()
hAllocate :: Handle h -> FileOffset -> FileOffset -> m ()
API.hAllocate
    , FsPath -> LockMode -> m (Maybe (LockFileHandle m))
tryLockFile :: FsPath -> LockMode -> m (Maybe (LockFileHandle m))
tryLockFile :: FsPath -> LockMode -> m (Maybe (LockFileHandle m))
API.tryLockFile
    , Handle h -> m ()
hSynchronise :: Handle h -> m ()
hSynchronise :: Handle h -> m ()
API.hSynchronise
    , FsPath -> m ()
synchroniseDirectory :: FsPath -> m ()
synchroniseDirectory :: FsPath -> m ()
API.synchroniseDirectory
    , FsPath -> FsPath -> m ()
createHardLink :: FsPath -> FsPath -> m ()
createHardLink :: FsPath -> FsPath -> m ()
API.createHardLink
    }

data IOCtx m = IOCtx { forall (m :: * -> *). IOCtx m -> SomeHasFS m
ctxFS :: SomeHasFS m, forall (m :: * -> *). IOCtx m -> MVar m Bool
openVar :: MVar m Bool }

{-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-}
guardIsOpen :: (HasCallStack, MonadMVar m, MonadThrow m) => IOCtx m -> m ()
guardIsOpen :: forall (m :: * -> *).
(HasCallStack, MonadMVar m, MonadThrow m) =>
IOCtx m -> m ()
guardIsOpen IOCtx m
ctx = MVar m Bool -> m Bool
forall a. MVar m a -> m a
forall (m :: * -> *) a. MonadMVar m => MVar m a -> m a
readMVar (IOCtx m -> MVar m Bool
forall (m :: * -> *). IOCtx m -> MVar m Bool
openVar IOCtx m
ctx) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
    case IOCtx m -> SomeHasFS m
forall (m :: * -> *). IOCtx m -> SomeHasFS m
ctxFS IOCtx m
ctx of
      SomeHasFS HasFS m h
hfs ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FsError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FsError -> m ()) -> FsError -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> String -> FsError
forall (m :: * -> *) h.
HasCallStack =>
HasFS m h -> String -> FsError
IOI.mkClosedError HasFS m h
hfs String
"submitIO"

{-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-}
initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m)
initIOCtx :: forall (m :: * -> *). MonadMVar m => SomeHasFS m -> m (IOCtx m)
initIOCtx SomeHasFS m
someHasFS = SomeHasFS m -> MVar m Bool -> IOCtx m
forall (m :: * -> *). SomeHasFS m -> MVar m Bool -> IOCtx m
IOCtx SomeHasFS m
someHasFS (MVar m Bool -> IOCtx m) -> m (MVar m Bool) -> m (IOCtx m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> m (MVar m Bool)
forall a. a -> m (MVar m a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar Bool
True

{-# SPECIALISE close :: IOCtx IO -> IO () #-}
close :: MonadMVar m => IOCtx m -> m ()
close :: forall (m :: * -> *). MonadMVar m => IOCtx m -> m ()
close IOCtx m
ctx = MVar m Bool -> (Bool -> m Bool) -> m ()
forall a. MVar m a -> (a -> m a) -> m ()
forall (m :: * -> *) a.
MonadMVar m =>
MVar m a -> (a -> m a) -> m ()
modifyMVar_ (IOCtx m -> MVar m Bool
forall (m :: * -> *). IOCtx m -> MVar m Bool
openVar IOCtx m
ctx) ((Bool -> m Bool) -> m ()) -> (Bool -> m Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ m Bool -> Bool -> m Bool
forall a b. a -> b -> a
const (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

{-# SPECIALISE submitIO ::
     HasFS IO h
  -> IOCtx IO -> V.Vector (IOOp RealWorld h)
  -> IO (VU.Vector IOResult) #-}
submitIO ::
     (HasCallStack, MonadMVar m, MonadThrow m, PrimMonad m)
  => HasFS m h
  -> IOCtx m
  -> V.Vector (IOOp (PrimState m) h)
  -> m (VU.Vector IOResult)
submitIO :: forall (m :: * -> *) h.
(HasCallStack, MonadMVar m, MonadThrow m, PrimMonad m) =>
HasFS m h
-> IOCtx m -> Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
submitIO HasFS m h
hfs IOCtx m
ctx Vector (IOOp (PrimState m) h)
ioops = do
    IOCtx m -> m ()
forall (m :: * -> *).
(HasCallStack, MonadMVar m, MonadThrow m) =>
IOCtx m -> m ()
guardIsOpen IOCtx m
ctx
    (IOOp (PrimState m) h -> m IOResult)
-> Vector (IOOp (PrimState m) h) -> m (Vector IOResult)
forall (m :: * -> *) a b.
(PrimMonad m, Unbox b) =>
(a -> m b) -> Vector a -> m (Vector b)
hmapM (HasFS m h -> IOOp (PrimState m) h -> m IOResult
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> IOOp (PrimState m) h -> m IOResult
ioop HasFS m h
hfs) Vector (IOOp (PrimState m) h)
ioops

{-# SPECIALISE ioop :: HasFS IO h -> IOOp RealWorld h -> IO IOResult #-}
-- | Perform the IOOp using synchronous I\/O.
ioop ::
     MonadThrow m
  => HasFS m h
  -> IOOp (PrimState m) h
  -> m IOResult
ioop :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> IOOp (PrimState m) h -> m IOResult
ioop HasFS m h
hfs (IOOpRead Handle h
h FileOffset
off MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c) = do
    HasFS m h -> MutableByteArray (PrimState m) -> String -> m ()
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> MutableByteArray (PrimState m) -> String -> m ()
guardPinned HasFS m h
hfs MutableByteArray (PrimState m)
buf String
"submitIO"
    ByteCount -> IOResult
IOResult (ByteCount -> IOResult) -> m ByteCount -> m IOResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hGetBufExactlyAt HasFS m h
hfs Handle h
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c (FileOffset -> AbsOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
off)
ioop HasFS m h
hfs (IOOpWrite Handle h
h FileOffset
off MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c) = do
    HasFS m h -> MutableByteArray (PrimState m) -> String -> m ()
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> MutableByteArray (PrimState m) -> String -> m ()
guardPinned HasFS m h
hfs MutableByteArray (PrimState m)
buf String
"submitIO"
    ByteCount -> IOResult
IOResult (ByteCount -> IOResult) -> m ByteCount -> m IOResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufExactlyAt HasFS m h
hfs Handle h
h MutableByteArray (PrimState m)
buf BufferOffset
bufOff ByteCount
c (FileOffset -> AbsOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
off)

{-# SPECIALISE guardPinned :: HasFS IO h -> MutableByteArray RealWorld -> String -> IO () #-}
guardPinned ::
     MonadThrow m
  => HasFS m h
  -> MutableByteArray (PrimState m)
  -> String
  -> m ()
guardPinned :: forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h -> MutableByteArray (PrimState m) -> String -> m ()
guardPinned HasFS m h
hfs MutableByteArray (PrimState m)
buf String
loc =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MutableByteArray (PrimState m) -> Bool
forall s. MutableByteArray s -> Bool
isMutableByteArrayPinned MutableByteArray (PrimState m)
buf) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      FsError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HasFS m h -> String -> FsError
forall (m :: * -> *) h.
HasCallStack =>
HasFS m h -> String -> FsError
IOI.mkNotPinnedError HasFS m h
hfs String
loc)

{-# SPECIALISE hmapM ::
     VUM.Unbox b
  => (a -> IO b)
  -> V.Vector a
  -> IO (VU.Vector b) #-}
-- | Heterogeneous blend of 'V.mapM' and 'VU.mapM'.
--
-- The @vector@ package does not provide functions that take distinct vector
-- containers as arguments, so we write it by hand to prevent having to convert
-- one vector type to the other.
hmapM ::
     forall m a b. (PrimMonad m, VUM.Unbox b)
  => (a -> m b)
  -> V.Vector a
  -> m (VU.Vector b)
hmapM :: forall (m :: * -> *) a b.
(PrimMonad m, Unbox b) =>
(a -> m b) -> Vector a -> m (Vector b)
hmapM a -> m b
f Vector a
v = do
    MVector (PrimState m) b
res <- Int -> m (MVector (PrimState m) b)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
VUM.unsafeNew Int
n
    MVector (PrimState m) b -> Int -> m (Vector b)
loop MVector (PrimState m) b
res Int
0
  where
    !n :: Int
n = Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
v
    loop :: MVector (PrimState m) b -> Int -> m (Vector b)
loop !MVector (PrimState m) b
res !Int
i
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = MVector (PrimState m) b -> m (Vector b)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VU.unsafeFreeze MVector (PrimState m) b
res
      | Bool
otherwise = do
          let !x :: a
x = Vector a
v Vector a -> Int -> a
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
i
          !b
z <- a -> m b
f a
x
          MVector (PrimState m) b -> Int -> b -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VUM.unsafeWrite MVector (PrimState m) b
res Int
i b
z
          MVector (PrimState m) b -> Int -> m (Vector b)
loop MVector (PrimState m) b
res (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)