{-# language BangPatterns #-}
{-# language CApiFFI #-}
{-# language FlexibleContexts #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language MagicHash #-}
{-# language MultiParamTypeClasses #-}
{-# language PatternSynonyms #-}
{-# language RankNTypes #-}
{-# language TypeApplications #-}
{-# language UnboxedTuples #-}
{-# language UnliftedFFITypes #-}
{-# language ViewPatterns #-}

module Zlib.Raw
  ( Zlib
  , runZlib
  , decompress
  , ZlibError(..)
  ) where

import Control.Exception (Exception)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Except (MonadError(throwError,catchError))
import Control.Monad.Reader (ReaderT, runReaderT, asks)
import Control.Monad.ST (runST)
import Control.Monad.ST (ST)
import Data.Bytes (Bytes)
import Data.Bytes.Chunks (Chunks(ChunksCons,ChunksNil))
import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray))
import Data.Primitive.ByteArray (newPinnedByteArray)
import Data.Word (Word8)
import Foreign.C.Types (CInt(CInt))
import Foreign.Ptr (Ptr)
import GHC.Exts (MutableByteArray#,touch#)
import GHC.IO (IO(IO),unsafeIOToST)

import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Primitive.ByteArray as BA


-- FIXME there are kinda two monads: ZlibCompress, ZlibDecompress
-- so far, I've only done the latter
newtype Zlib s a = Zlib { forall s a.
Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
unZlib :: ReaderT (Stream s) (ExceptT ZlibError (ST s)) a }
  deriving((forall a b. (a -> b) -> Zlib s a -> Zlib s b)
-> (forall a b. a -> Zlib s b -> Zlib s a) -> Functor (Zlib s)
forall a b. a -> Zlib s b -> Zlib s a
forall a b. (a -> b) -> Zlib s a -> Zlib s b
forall s a b. a -> Zlib s b -> Zlib s a
forall s a b. (a -> b) -> Zlib s a -> Zlib s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> Zlib s a -> Zlib s b
fmap :: forall a b. (a -> b) -> Zlib s a -> Zlib s b
$c<$ :: forall s a b. a -> Zlib s b -> Zlib s a
<$ :: forall a b. a -> Zlib s b -> Zlib s a
Functor, Functor (Zlib s)
Functor (Zlib s) =>
(forall a. a -> Zlib s a)
-> (forall a b. Zlib s (a -> b) -> Zlib s a -> Zlib s b)
-> (forall a b c.
    (a -> b -> c) -> Zlib s a -> Zlib s b -> Zlib s c)
-> (forall a b. Zlib s a -> Zlib s b -> Zlib s b)
-> (forall a b. Zlib s a -> Zlib s b -> Zlib s a)
-> Applicative (Zlib s)
forall s. Functor (Zlib s)
forall a. a -> Zlib s a
forall s a. a -> Zlib s a
forall a b. Zlib s a -> Zlib s b -> Zlib s a
forall a b. Zlib s a -> Zlib s b -> Zlib s b
forall a b. Zlib s (a -> b) -> Zlib s a -> Zlib s b
forall s a b. Zlib s a -> Zlib s b -> Zlib s a
forall s a b. Zlib s a -> Zlib s b -> Zlib s b
forall s a b. Zlib s (a -> b) -> Zlib s a -> Zlib s b
forall a b c. (a -> b -> c) -> Zlib s a -> Zlib s b -> Zlib s c
forall s a b c. (a -> b -> c) -> Zlib s a -> Zlib s b -> Zlib s c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s a. a -> Zlib s a
pure :: forall a. a -> Zlib s a
$c<*> :: forall s a b. Zlib s (a -> b) -> Zlib s a -> Zlib s b
<*> :: forall a b. Zlib s (a -> b) -> Zlib s a -> Zlib s b
$cliftA2 :: forall s a b c. (a -> b -> c) -> Zlib s a -> Zlib s b -> Zlib s c
liftA2 :: forall a b c. (a -> b -> c) -> Zlib s a -> Zlib s b -> Zlib s c
$c*> :: forall s a b. Zlib s a -> Zlib s b -> Zlib s b
*> :: forall a b. Zlib s a -> Zlib s b -> Zlib s b
$c<* :: forall s a b. Zlib s a -> Zlib s b -> Zlib s a
<* :: forall a b. Zlib s a -> Zlib s b -> Zlib s a
Applicative, Applicative (Zlib s)
Applicative (Zlib s) =>
(forall a b. Zlib s a -> (a -> Zlib s b) -> Zlib s b)
-> (forall a b. Zlib s a -> Zlib s b -> Zlib s b)
-> (forall a. a -> Zlib s a)
-> Monad (Zlib s)
forall s. Applicative (Zlib s)
forall a. a -> Zlib s a
forall s a. a -> Zlib s a
forall a b. Zlib s a -> Zlib s b -> Zlib s b
forall a b. Zlib s a -> (a -> Zlib s b) -> Zlib s b
forall s a b. Zlib s a -> Zlib s b -> Zlib s b
forall s a b. Zlib s a -> (a -> Zlib s b) -> Zlib s b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s a b. Zlib s a -> (a -> Zlib s b) -> Zlib s b
>>= :: forall a b. Zlib s a -> (a -> Zlib s b) -> Zlib s b
$c>> :: forall s a b. Zlib s a -> Zlib s b -> Zlib s b
>> :: forall a b. Zlib s a -> Zlib s b -> Zlib s b
$creturn :: forall s a. a -> Zlib s a
return :: forall a. a -> Zlib s a
Monad)

instance MonadError ZlibError (Zlib s) where
  throwError :: forall a. ZlibError -> Zlib s a
throwError ZlibError
exn = ReaderT (Stream s) (ExceptT ZlibError (ST s)) a -> Zlib s a
forall s a.
ReaderT (Stream s) (ExceptT ZlibError (ST s)) a -> Zlib s a
Zlib (ZlibError -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall a.
ZlibError -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
exn)
  catchError :: forall a. Zlib s a -> (ZlibError -> Zlib s a) -> Zlib s a
catchError Zlib s a
try ZlibError -> Zlib s a
handle = ReaderT (Stream s) (ExceptT ZlibError (ST s)) a -> Zlib s a
forall s a.
ReaderT (Stream s) (ExceptT ZlibError (ST s)) a -> Zlib s a
Zlib (Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall s a.
Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
unZlib Zlib s a
try ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
-> (ZlibError -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a)
-> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall a.
ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
-> (ZlibError -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a)
-> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall s a.
Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
unZlib (Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a)
-> (ZlibError -> Zlib s a)
-> ZlibError
-> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZlibError -> Zlib s a
handle))

newtype Stream s = Stream
  { forall s. Stream s -> MutableByteArray s
unStream :: MutableByteArray s
  }

-- TODO: In GHC 8.10+, use with# instead of touch# so that the
-- noinline pragma is not needed.
runZlib :: (forall s. Zlib s a) -> Bytes -> Either ZlibError a
{-# noinline runZlib #-}
runZlib :: forall a. (forall s. Zlib s a) -> Bytes -> Either ZlibError a
runZlib forall s. Zlib s a
action Bytes
inp = (forall s. ST s (Either ZlibError a)) -> Either ZlibError a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either ZlibError a)) -> Either ZlibError a)
-> (forall s. ST s (Either ZlibError a)) -> Either ZlibError a
forall a b. (a -> b) -> a -> b
$ ExceptT ZlibError (ST s) a -> ST s (Either ZlibError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ZlibError (ST s) a -> ST s (Either ZlibError a))
-> ExceptT ZlibError (ST s) a -> ST s (Either ZlibError a)
forall a b. (a -> b) -> a -> b
$ do
  let pinnedInp :: Bytes
pinnedInp = Bytes -> Bytes
Bytes.pin Bytes
inp
  Stream s
stream <- Bytes -> PreZlib s (Stream s)
forall s. Bytes -> PreZlib s (Stream s)
newStream Bytes
pinnedInp
  a
v <- ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
-> Stream s -> ExceptT ZlibError (ST s) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
forall s a.
Zlib s a -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) a
unZlib Zlib s a
forall s. Zlib s a
action) Stream s
stream ExceptT ZlibError (ST s) a
-> (ZlibError -> ExceptT ZlibError (ST s) a)
-> ExceptT ZlibError (ST s) a
forall a.
ExceptT ZlibError (ST s) a
-> (ZlibError -> ExceptT ZlibError (ST s) a)
-> ExceptT ZlibError (ST s) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\ZlibError
exn -> Stream s -> PreZlib s ()
forall s. Stream s -> PreZlib s ()
delStream Stream s
stream PreZlib s ()
-> ExceptT ZlibError (ST s) a -> ExceptT ZlibError (ST s) a
forall a b.
ExceptT ZlibError (ST s) a
-> ExceptT ZlibError (ST s) b -> ExceptT ZlibError (ST s) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ZlibError -> ExceptT ZlibError (ST s) a
forall a. ZlibError -> ExceptT ZlibError (ST s) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
exn)
  ()
_ <- Stream s -> PreZlib s ()
forall s. Stream s -> PreZlib s ()
delStream Stream s
stream
  Bytes -> PreZlib s ()
forall (m :: * -> *). PrimMonad m => Bytes -> m ()
Bytes.touch Bytes
pinnedInp
  a -> ExceptT ZlibError (ST s) a
forall a. a -> ExceptT ZlibError (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v


------------ Idiomatic FFI Calls ------------

type PreZlib s a = ExceptT ZlibError (ST s) a

-- Precondition: Bytes are pinned.
-- Postcondition: Call touch on the argument after calling this function.
newStream :: Bytes -> PreZlib s (Stream s)
newStream :: forall s. Bytes -> PreZlib s (Stream s)
newStream Bytes
pinnedInp = do
  let inpP :: Ptr Word8
inpP = Bytes -> Ptr Word8
Bytes.contents Bytes
pinnedInp
      inpLen :: Int
inpLen = Bytes -> Int
Bytes.length Bytes
pinnedInp
  MutableByteArray MutableByteArray# s
stream# <- Int
-> ExceptT
     ZlibError
     (ST s)
     (MutableByteArray (PrimState (ExceptT ZlibError (ST s))))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
sizeofStream
  CInt
ret <- ST s CInt -> ExceptT ZlibError (ST s) CInt
forall (m :: * -> *) a. Monad m => m a -> ExceptT ZlibError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s CInt -> ExceptT ZlibError (ST s) CInt)
-> (IO CInt -> ST s CInt)
-> IO CInt
-> ExceptT ZlibError (ST s) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> ST s CInt
forall a s. IO a -> ST s a
unsafeIOToST (IO CInt -> ExceptT ZlibError (ST s) CInt)
-> IO CInt -> ExceptT ZlibError (ST s) CInt
forall a b. (a -> b) -> a -> b
$ MutableByteArray# s -> Ptr Word8 -> Int -> IO CInt
forall s. MutableByteArray# s -> Ptr Word8 -> Int -> IO CInt
initDecompress MutableByteArray# s
stream# Ptr Word8
inpP Int
inpLen
  let stream :: Stream s
stream = Stream
        { unStream :: MutableByteArray s
unStream = MutableByteArray# s -> MutableByteArray s
forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# s
stream#
        }
  case CInt
ret of
    CInt
Z_OK -> Stream s -> PreZlib s (Stream s)
forall a. a -> ExceptT ZlibError (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stream s
stream
    CInt
Z_MEM_ERROR -> [Char] -> PreZlib s (Stream s)
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"zlib: out of memory"
    CInt
Z_VERSION_ERROR -> [Char] -> PreZlib s (Stream s)
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"zlib: incompatible version"
    CInt
Z_STREAM_ERROR -> ZlibError -> PreZlib s (Stream s)
forall a. ZlibError -> ExceptT ZlibError (ST s) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
InvalidInitParameters
    CInt
_ -> [Char] -> PreZlib s (Stream s)
forall a. [Char] -> a
errorWithoutStackTrace ([Char]
"unknown error produced by zlib: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
ret)

delStream :: Stream s -> PreZlib s ()
delStream :: forall s. Stream s -> PreZlib s ()
delStream Stream s
stream = do
  let !(MutableByteArray MutableByteArray# s
stream#) = Stream s -> MutableByteArray s
forall s. Stream s -> MutableByteArray s
unStream Stream s
stream
  CInt
ret <- ST s CInt -> ExceptT ZlibError (ST s) CInt
forall (m :: * -> *) a. Monad m => m a -> ExceptT ZlibError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s CInt -> ExceptT ZlibError (ST s) CInt)
-> (IO CInt -> ST s CInt)
-> IO CInt
-> ExceptT ZlibError (ST s) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> ST s CInt
forall a s. IO a -> ST s a
unsafeIOToST (IO CInt -> ExceptT ZlibError (ST s) CInt)
-> IO CInt -> ExceptT ZlibError (ST s) CInt
forall a b. (a -> b) -> a -> b
$ MutableByteArray# s -> IO CInt
forall s. MutableByteArray# s -> IO CInt
inflateEnd MutableByteArray# s
stream#
  case CInt
ret of
    CInt
Z_OK -> () -> PreZlib s ()
forall a. a -> ExceptT ZlibError (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    CInt
Z_STREAM_ERROR -> ZlibError -> PreZlib s ()
forall a. ZlibError -> ExceptT ZlibError (ST s) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
InvalidStreamState
    CInt
_ -> [Char] -> PreZlib s ()
forall a. [Char] -> a
errorWithoutStackTrace ([Char]
"unknown error produced by zlib: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
ret)

-- TODO couldn't I resize the output buffer rather than use chunks?
-- probably more useful for an unsliced version
decompress :: Zlib s Chunks
decompress :: forall s. Zlib s Chunks
decompress = ReaderT (Stream s) (ExceptT ZlibError (ST s)) Chunks
-> Zlib s Chunks
forall s a.
ReaderT (Stream s) (ExceptT ZlibError (ST s)) a -> Zlib s a
Zlib (ReaderT (Stream s) (ExceptT ZlibError (ST s)) Chunks
 -> Zlib s Chunks)
-> ReaderT (Stream s) (ExceptT ZlibError (ST s)) Chunks
-> Zlib s Chunks
forall a b. (a -> b) -> a -> b
$ Chunks -> ReaderT (Stream s) (ExceptT ZlibError (ST s)) Chunks
forall {t :: (* -> *) -> * -> *} {t :: (* -> *) -> * -> *} {s}.
(MonadReader (Stream (PrimState (t (t (ST s))))) (t (t (ST s))),
 PrimMonad (t (t (ST s))), Monad (t (ST s)), MonadTrans t,
 MonadTrans t, MonadError ZlibError (t (t (ST s)))) =>
Chunks -> t (t (ST s)) Chunks
loop Chunks
ChunksNil
  where
  -- TODO adapt chunkSize based on input remaining and estimated compression ratio
  chunkSize :: Int
chunkSize = Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 :: Int
  loop :: Chunks -> t (t (ST s)) Chunks
loop Chunks
acc = do
    !(MutableByteArray MutableByteArray# (PrimState (t (t (ST s))))
stream#) <- (Stream (PrimState (t (t (ST s))))
 -> MutableByteArray (PrimState (t (t (ST s)))))
-> t (t (ST s)) (MutableByteArray (PrimState (t (t (ST s)))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Stream (PrimState (t (t (ST s))))
-> MutableByteArray (PrimState (t (t (ST s))))
forall s. Stream s -> MutableByteArray s
unStream
    !oBuf :: MutableByteArray (PrimState (t (t (ST s))))
oBuf@(MutableByteArray MutableByteArray# (PrimState (t (t (ST s))))
oBuf#) <- Int -> t (t (ST s)) (MutableByteArray (PrimState (t (t (ST s)))))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
chunkSize
    CInt
ret <- t (ST s) CInt -> t (t (ST s)) CInt
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t (ST s) CInt -> t (t (ST s)) CInt)
-> (IO CInt -> t (ST s) CInt) -> IO CInt -> t (t (ST s)) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s CInt -> t (ST s) CInt
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s CInt -> t (ST s) CInt)
-> (IO CInt -> ST s CInt) -> IO CInt -> t (ST s) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> ST s CInt
forall a s. IO a -> ST s a
unsafeIOToST (IO CInt -> t (t (ST s)) CInt) -> IO CInt -> t (t (ST s)) CInt
forall a b. (a -> b) -> a -> b
$ do
      CInt
r <- MutableByteArray# (PrimState (t (t (ST s))))
-> MutableByteArray# (PrimState (t (t (ST s)))) -> Int -> IO CInt
forall s.
MutableByteArray# s -> MutableByteArray# s -> Int -> IO CInt
decompressChunk MutableByteArray# (PrimState (t (t (ST s))))
stream# MutableByteArray# (PrimState (t (t (ST s))))
oBuf# Int
chunkSize
      -- This call to touch# is not really necessary since GHC cannot
      -- possibly have any insight into what ret is, but it is prudent
      -- to include it here anyway.
      MutableByteArray# (PrimState (t (t (ST s)))) -> IO ()
forall s. MutableByteArray# s -> IO ()
touchMutableByteArray# MutableByteArray# (PrimState (t (t (ST s))))
oBuf#
      CInt -> IO CInt
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CInt
r
    case CInt
ret of
      CInt
Z_OK -> do
        Bytes
out <- ByteArray -> Bytes
Bytes.fromByteArray (ByteArray -> Bytes)
-> t (t (ST s)) ByteArray -> t (t (ST s)) Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray (PrimState (t (t (ST s))))
-> t (t (ST s)) ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
BA.unsafeFreezeByteArray MutableByteArray (PrimState (t (t (ST s))))
oBuf
        let acc' :: Chunks
acc' = Bytes -> Chunks -> Chunks
ChunksCons Bytes
out Chunks
acc
        Chunks -> t (t (ST s)) Chunks
loop Chunks
acc'
      CInt
Z_STREAM_END -> do
        Bytes
out <- ByteArray -> Bytes
Bytes.fromByteArray (ByteArray -> Bytes)
-> t (t (ST s)) ByteArray -> t (t (ST s)) Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray (PrimState (t (t (ST s))))
-> t (t (ST s)) ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
BA.unsafeFreezeByteArray MutableByteArray (PrimState (t (t (ST s))))
oBuf
        CInt
outRestCInt <- t (ST s) CInt -> t (t (ST s)) CInt
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t (ST s) CInt -> t (t (ST s)) CInt)
-> (IO CInt -> t (ST s) CInt) -> IO CInt -> t (t (ST s)) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s CInt -> t (ST s) CInt
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s CInt -> t (ST s) CInt)
-> (IO CInt -> ST s CInt) -> IO CInt -> t (ST s) CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> ST s CInt
forall a s. IO a -> ST s a
unsafeIOToST (IO CInt -> t (t (ST s)) CInt) -> IO CInt -> t (t (ST s)) CInt
forall a b. (a -> b) -> a -> b
$ MutableByteArray# (PrimState (t (t (ST s)))) -> IO CInt
forall s. MutableByteArray# s -> IO CInt
availOut MutableByteArray# (PrimState (t (t (ST s))))
stream#
        let outRest :: Int
outRest = forall a b. (Integral a, Num b) => a -> b
fromIntegral @CInt @Int CInt
outRestCInt
        let outLen :: Int
outLen = Int
chunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
outRest
        Chunks -> t (t (ST s)) Chunks
forall a. a -> t (t (ST s)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chunks -> t (t (ST s)) Chunks) -> Chunks -> t (t (ST s)) Chunks
forall a b. (a -> b) -> a -> b
$ Chunks -> Chunks
Chunks.reverse (Chunks -> Chunks) -> Chunks -> Chunks
forall a b. (a -> b) -> a -> b
$ case Int
outLen of
          Int
0 -> Chunks
acc
          Int
_ -> Bytes -> Chunks -> Chunks
ChunksCons (Int -> Bytes -> Bytes
Bytes.unsafeTake Int
outLen Bytes
out) Chunks
acc
      CInt
Z_NEED_DICT -> [Char] -> t (t (ST s)) Chunks
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"zlib: preset dictionary is needed to decompress"
      CInt
Z_DATA_ERROR -> ZlibError -> t (t (ST s)) Chunks
forall a. ZlibError -> t (t (ST s)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
DataCorrupt
      CInt
Z_STREAM_ERROR -> ZlibError -> t (t (ST s)) Chunks
forall a. ZlibError -> t (t (ST s)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
InvalidStreamState
      CInt
Z_MEM_ERROR -> [Char] -> t (t (ST s)) Chunks
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"zlib: out of memory"
      CInt
Z_BUF_ERROR -> ZlibError -> t (t (ST s)) Chunks
forall a. ZlibError -> t (t (ST s)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ZlibError
BufferTooSmall
      CInt
_ -> [Char] -> t (t (ST s)) Chunks
forall a. [Char] -> a
errorWithoutStackTrace ([Char]
"unknown error produced by zlib: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
ret)

touchMutableByteArray# :: MutableByteArray# s -> IO ()
touchMutableByteArray# :: forall s. MutableByteArray# s -> IO ()
touchMutableByteArray# MutableByteArray# s
x = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (# MutableByteArray# s -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# MutableByteArray# s
x State# RealWorld
s, () #))

------------ Idiomatic Error Handling ------------

data ZlibError
  = InvalidInitParameters -- corresponds to Z_STREAM_ERROR
  | InvalidStreamState -- corresponds to Z_STREAM_ERROR
  | DataCorrupt -- corresponds to Z_DATA_ERROR
  | BufferTooSmall -- corresponds to Z_BUF_ERROR
  deriving (Int -> ZlibError -> [Char] -> [Char]
[ZlibError] -> [Char] -> [Char]
ZlibError -> [Char]
(Int -> ZlibError -> [Char] -> [Char])
-> (ZlibError -> [Char])
-> ([ZlibError] -> [Char] -> [Char])
-> Show ZlibError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ZlibError -> [Char] -> [Char]
showsPrec :: Int -> ZlibError -> [Char] -> [Char]
$cshow :: ZlibError -> [Char]
show :: ZlibError -> [Char]
$cshowList :: [ZlibError] -> [Char] -> [Char]
showList :: [ZlibError] -> [Char] -> [Char]
Show)

instance Exception ZlibError where


pattern Z_BUF_ERROR :: CInt
pattern $mZ_BUF_ERROR :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_BUF_ERROR :: CInt
Z_BUF_ERROR <- ((== z_BUF_ERROR) -> True)
  where Z_BUF_ERROR = CInt
z_BUF_ERROR

pattern Z_DATA_ERROR :: CInt
pattern $mZ_DATA_ERROR :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_DATA_ERROR :: CInt
Z_DATA_ERROR <- ((== z_DATA_ERROR) -> True)
  where Z_DATA_ERROR = CInt
z_DATA_ERROR

pattern Z_MEM_ERROR :: CInt
pattern $mZ_MEM_ERROR :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_MEM_ERROR :: CInt
Z_MEM_ERROR <- ((== z_MEM_ERROR) -> True)
  where Z_MEM_ERROR = CInt
z_MEM_ERROR

pattern Z_NEED_DICT :: CInt
pattern $mZ_NEED_DICT :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_NEED_DICT :: CInt
Z_NEED_DICT <- ((== z_NEED_DICT) -> True)
  where Z_NEED_DICT = CInt
z_NEED_DICT

pattern Z_OK :: CInt
pattern $mZ_OK :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_OK :: CInt
Z_OK <- ((== z_OK) -> True)
  where Z_OK = CInt
z_OK

pattern Z_STREAM_END :: CInt
pattern $mZ_STREAM_END :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_STREAM_END :: CInt
Z_STREAM_END <- ((== z_STREAM_END) -> True)
  where Z_STREAM_END = CInt
z_STREAM_END

pattern Z_STREAM_ERROR :: CInt
pattern $mZ_STREAM_ERROR :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_STREAM_ERROR :: CInt
Z_STREAM_ERROR <- ((== z_STREAM_ERROR) -> True)
  where Z_STREAM_ERROR = CInt
z_STREAM_ERROR

pattern Z_VERSION_ERROR :: CInt
pattern $mZ_VERSION_ERROR :: forall {r}. CInt -> ((# #) -> r) -> ((# #) -> r) -> r
$bZ_VERSION_ERROR :: CInt
Z_VERSION_ERROR <- ((== z_VERSION_ERROR) -> True)
  where Z_VERSION_ERROR = CInt
z_VERSION_ERROR


------------ Raw Foreign Imports ------------

foreign import capi "zlib.h value Z_BUF_ERROR" z_BUF_ERROR :: CInt
foreign import capi "zlib.h value Z_DATA_ERROR" z_DATA_ERROR :: CInt
foreign import capi "zlib.h value Z_MEM_ERROR" z_MEM_ERROR :: CInt
foreign import capi "zlib.h value Z_NEED_DICT" z_NEED_DICT :: CInt
foreign import capi "zlib.h value Z_OK" z_OK :: CInt
foreign import capi "zlib.h value Z_STREAM_END" z_STREAM_END :: CInt
foreign import capi "zlib.h value Z_STREAM_ERROR" z_STREAM_ERROR :: CInt
foreign import capi "zlib.h value Z_VERSION_ERROR" z_VERSION_ERROR :: CInt

foreign import capi "hs_zlib.h value hs_sizeofStream" sizeofStream :: Int

foreign import ccall unsafe "hs_initDecompress" initDecompress ::
     MutableByteArray# s
  -> Ptr Word8
  -> Int
  -> IO CInt

foreign import ccall unsafe "hs_decompressChunk" decompressChunk ::
     MutableByteArray# s
  -> MutableByteArray# s
  -> Int
  -> IO CInt

foreign import ccall unsafe "hs_avail_out" availOut ::
     MutableByteArray# s
  -> IO CInt

foreign import ccall unsafe "inflateEnd" inflateEnd ::
     MutableByteArray# s
  -> IO CInt