blob: d1222312fdd620cae471dcac245069f1488416c5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Handle
(
write
, read
)
where
import Control.Monad.IO.Class (MonadIO(..))
import Data.Word (Word8)
import Foreign.Storable (Storable(..))
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (plusPtr, minusPtr)
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
import System.IO (Handle, hGetBufSome, hPutBuf)
import Unfold (Unfold(..))
import Fold (Fold(..))
import Array (Array(..))
import qualified MArray as MA
import qualified Fold as FL
import qualified Unfold as UF
import qualified StreamD as D
import qualified Array as A
import Prelude hiding (length, read)
{-# INLINABLE writeArray #-}
writeArray :: Storable a => Handle -> Array a -> IO ()
writeArray _ arr | A.length arr == 0 = return ()
writeArray h Array{..} = withForeignPtr aStart $ \p -> hPutBuf h p aLen
where
aLen =
let p = unsafeForeignPtrToPtr aStart
in aEnd `minusPtr` p
{-# INLINE writeChunks #-}
writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) ()
writeChunks h = FL.drainBy (liftIO . writeArray h)
{-# INLINE writeWithBufferOf #-}
writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 ()
writeWithBufferOf n h = FL.chunksOf n (A.writeNUnsafe n) (writeChunks h)
{-# INLINE write #-}
write :: MonadIO m => Handle -> Fold m Word8 ()
write = writeWithBufferOf MA.defaultChunkSize
{-# INLINABLE readArrayUpto #-}
readArrayUpto :: Int -> Handle -> IO (Array Word8)
readArrayUpto size h = do
ptr <- mallocPlainForeignPtrBytes size
-- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))
withForeignPtr ptr $ \p -> do
n <- hGetBufSome h p size
-- XXX shrink only if the diff is significant
return $
A.unsafeFreezeWithShrink $
MA.mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)
{-# INLINE [1] readChunksWithBufferOf #-}
readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8)
readChunksWithBufferOf = Unfold step return
where
{-# INLINE [0] step #-}
step (size, h) = do
arr <- liftIO $ readArrayUpto size h
return $
case A.length arr of
0 -> D.Stop
_ -> D.Yield arr (size, h)
{-# INLINE readWithBufferOf #-}
readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8
readWithBufferOf = UF.many readChunksWithBufferOf A.read
{-# INLINE read #-}
read :: MonadIO m => Unfold m Handle Word8
read = UF.supplyFirst MA.defaultChunkSize readWithBufferOf
|
