{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE ScopedTypeVariables #-}

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 qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
import           System.FS.API
import qualified System.FS.BlockIO.API as API
import           System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..))

{-# 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.
(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 :: (MonadMVar m, MonadThrow m) => IOCtx m -> m ()
guardIsOpen :: forall (m :: * -> *).
(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 ->
    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 (SomeHasFS m -> String -> FsError
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> String -> FsError
API.mkClosedError (IOCtx m -> SomeHasFS m
forall (m :: * -> *). IOCtx m -> SomeHasFS m
ctxFS IOCtx m
ctx) 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 ::
     (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.
(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 :: * -> *).
(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) =
    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) =
    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 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)