diff --git a/.gitignore b/.gitignore
index 733412c6f54fb97497b5847dbd3d1757545ddf82..82a9923d62811bb61b76c1fbaeb84f9af590a6ac 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,3 @@
*~
dist
+cabal.project.local
\ No newline at end of file
diff --git a/machines-zlib.cabal b/machines-zlib.cabal
index 7d0e637fe7706a3d1f2240d2795ed2cf499e16a5..d61c01b15390e72108e3023ff1ad9fae6f316282 100644
--- a/machines-zlib.cabal
+++ b/machines-zlib.cabal
@@ -3,7 +3,7 @@ cabal-version: 2.2
name: machines-zlib
version: 0.2
synopsis: Decompression support for machines
--- description:
+-- description:
homepage: https://github.com/lshift/machines-zlib
license: BSD-3-Clause
license-file: LICENSE
@@ -18,8 +18,12 @@ common deps
build-depends:
base >=4.11 && < 4.14
, bytestring ^>= 0.10
+ , exceptions
, machines >=0.4.1 && <0.8
+ , mtl ^>= 2.2
, streaming-commons >=0.1.11 && <0.3
+ , primitive ^>= 0.7
+ , ghc-prim >= 0.3 && < 0.6
library
import: deps
diff --git a/src/Data/Machine/Zlib.hs b/src/Data/Machine/Zlib.hs
index 94145e641079e89809024a732eb50b55e0547e5d..77842af8f41f6fbb961323516b410f9d95445a2c 100644
--- a/src/Data/Machine/Zlib.hs
+++ b/src/Data/Machine/Zlib.hs
@@ -1,72 +1,54 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Machine.Zlib
- ( gzipper
- , gunzipper
+ ( gunzipper
, WindowBits(..)
) where
-import Control.Applicative
-import Control.Exception (throw)
-import Control.Monad
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.Primitive
+import Control.Monad.Trans
import qualified Data.ByteString as BS
-import Data.Machine
-import Data.Machine.Stack
-import Data.Streaming.Zlib
-import System.IO.Unsafe
+import Data.Machine
+import Data.Machine.Stack
+import Data.Streaming.Zlib
-unsafeM :: Monad n => IO a -> n a
-unsafeM ma = pure . unsafePerformIO $! ma
-
-handleRes :: Applicative m => PopperRes -> m (Maybe BS.ByteString)
-handleRes PRDone = pure $ Nothing
-handleRes (PRNext bs) = pure $ Just bs
-handleRes (PRError e) = throw e
-
-gunzipper :: forall m . (Monad m) => MachineT m (Stack BS.ByteString) BS.ByteString
-gunzipper = construct $
- go =<< (unsafeM $ initInflate (WindowBits 0)) -- Use what the header says.
+gunzipper :: forall m . (MonadThrow m, PrimMonad m, Monad m) => MachineT m (Stack BS.ByteString) BS.ByteString
+gunzipper = construct $ do
+ i <- doPrim $ initInflate (WindowBits 0)
+ start i
where
- go :: Inflate -> PlanT (Stack BS.ByteString) BS.ByteString m ()
- go inflate = do
- bs <- awaits Pop <|> stop
- popper <- unsafeM <$> unsafeM (feedInflate inflate bs)
- exhaust (handleRes =<< popper)
- complete <- unsafeM $ isCompleteInflate inflate
- if complete
- then void $ finish
- else go'
- where
- go' :: PlanT (Stack BS.ByteString) BS.ByteString m ()
- go' = do
- bs <- awaits Pop <|> finish
- popper <- unsafeM <$> unsafeM (feedInflate inflate bs)
- exhaust (handleRes =<< popper)
- complete <- unsafeM $ isCompleteInflate inflate
- if complete
- then void $ finish
- else go'
- finish :: PlanT (Stack BS.ByteString) BS.ByteString m BS.ByteString
- finish = do
- r <- unsafeM $ finishInflate inflate
- yield r
- unused <- unsafeM $ getUnusedInflate inflate
- awaits (Push unused)
- stop
-
-gzipper :: forall m. Monad m => Int -> WindowBits -> ProcessT m BS.ByteString BS.ByteString
-gzipper lvl wb = construct $
- go =<< (unsafeM $ initDeflate lvl wb)
- where
- go :: Deflate -> PlanT (Is BS.ByteString) BS.ByteString m ()
- go deflate = go'
+ doPrim :: IO a -> PlanT (Stack BS.ByteString) BS.ByteString m a
+ doPrim = lift . unsafePrimToPrim
+ yield' :: BS.ByteString -> PlanT (Stack BS.ByteString) BS.ByteString m ()
+ yield' d = unless (BS.null d) $ yield d
+ push' :: BS.ByteString -> PlanT (Stack BS.ByteString) BS.ByteString m ()
+ push' d = unless (BS.null d) $ push d
+ -- This is all stupid. Its based on the exact behavior of the base API.
+ start :: Inflate -> PlanT (Stack BS.ByteString) BS.ByteString m ()
+ start i = go
where
- go' :: PlanT (Is BS.ByteString) BS.ByteString m ()
- go' = do
- bs <- await <|> finish
- popper <- unsafeM <$> unsafeM (feedDeflate deflate bs)
- exhaust (handleRes =<< popper)
- go'
- finish = do
- let popper = unsafeM (finishDeflate deflate)
- exhaust (handleRes =<< popper)
- stop
+ drain :: Popper -> PlanT (Stack BS.ByteString) BS.ByteString m ()
+ drain popper = do
+ md <- doPrim popper
+ case md of
+ PRNext d -> yield' d >> drain popper
+ PRDone -> do
+ -- This magic tries to detect if we've reached the end of a substream.
+ l <- doPrim (getUnusedInflate i)
+ if BS.null l
+ then go
+ else do
+ yield' =<< doPrim (flushInflate i)
+ push l
+ PRError e -> lift $ throwM e
+ getMore :: PlanT (Stack BS.ByteString) BS.ByteString m ()
+ getMore = drain =<< (doPrim . feedInflate i) =<< pop
+ allDone :: PlanT (Stack BS.ByteString) BS.ByteString m ()
+ allDone = do
+ yield' =<< doPrim (flushInflate i)
+ push' =<< doPrim (getUnusedInflate i)
+ go :: PlanT (Stack BS.ByteString) BS.ByteString m ()
+ go = getMore <|> allDone
+
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 44b9ae0cb61b3c305799e6a4271d74a067e75c5d..b29beeef543f82f9af7de4949d64e98e2af8ff09 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
-import qualified Codec.Compression.Zlib as ZLib
+import qualified "zlib" Codec.Compression.Zlib as ZLib
+import Control.Monad.Trans
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Machine
@@ -10,52 +13,67 @@ import Data.Machine.Zlib
import Data.Word
import Test.Tasty
import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck as QC
+import Test.Tasty.QuickCheck as QC
+import Test.QuickCheck.Monadic as QC
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "machines-zlib"
- [ properties
+ [ unzipTests
+-- , zipTests
+-- , inversionTest
]
-properties :: TestTree
-properties = testGroup "properties"
+runF :: Monoid a => MachineT IO k a -> IO (Maybe a)
+runF = fmap (Just . mconcat) . runT
+
+unzipTests :: TestTree
+unzipTests = testGroup "unzip"
[ testCase "unzip empty stream doesn't error" $ do
- mempty @=? (run $ (source []) `stack` gunzipper)
- mempty @=? (run $ (source [mempty]) `stack` gunzipper)
- mempty @=? (run $ (source [mempty, mempty]) `stack` gunzipper)
- , testCase "zip on empty stream doesn't error" $ do
- mempty @=? (run $ source [] ~> gzipper 1 (WindowBits 9))
- , QC.testProperty "unzips" $ \(ds'::[Word8]) ->
- let ds = BS.pack ds'
- in ds === (mconcat . run $ (source [ds]) `stack` gunzipper)
- , QC.testProperty "zips" $ \(ds'::[Word8]) ->
+ ((Just mempty) @=?) =<< (runF $ (source []) `stack` gunzipper)
+ ((Just mempty) @=?) =<< (runF $ (source [mempty]) `stack` gunzipper)
+ ((Just mempty) @=?) =<< (runF $ (source [mempty, mempty]) `stack` gunzipper)
+ , QC.testProperty "unzips" $ \(ds'::[Word8]) -> monadicIO $ do
let ds = BS.pack ds'
- in (BL.fromStrict ds) ===
- (ZLib.decompress . BL.fromChunks . run $ source [ds] ~> (gzipper 1 (WindowBits 9)))
- , QC.testProperty "zip/unzip" $ \(ds'::[[Word8]]) ->
- let ds = map BS.pack ds'
- in (BL.fromChunks ds) ===
- (BL.fromChunks $ run $
- (source ds ~> gzipper 5 (WindowBits 9)) `stack`
- gunzipper)
- , testGroup "only first stream"
- [ QC.testProperty "seperate chunks" $ \(ds0'::[Word8]) (ds1'::[Word8]) ->
- let ds0 = BS.pack ds0'
- ds1 = BS.pack ds1'
- in (ds0) ===
- (mconcat $ run $
- (source (map (BL.toStrict . ZLib.compress . BL.fromStrict) [ds0, ds1])) `stack`
- gunzipper)
- ]
+ QC.assert . ((Just ds) ==) =<< (lift . runF $ (source [BL.toStrict . ZLib.compress $ BL.fromStrict ds]) `stack` gunzipper)
-- , testGroup "multiple streams"
-- [ QC.testProperty "seperate chunks" $ \(ds0'::[Word8]) (ds1'::[Word8]) ->
-- let ds0 = BS.pack ds0'
-- ds1 = BS.pack ds1'
--- in (ds0 `mappend` ds1) === (mconcat $ run $
+-- in (ds0 `mappend` ds1) === (mconcat $ runF $
-- (source (map (BL.toStrict . ZLib.compress . BL.fromStrict) [ds0, ds1])) `stack`
-- (forever gunzipper))
-- ]
+ , testGroup "only first stream"
+ [ QC.testProperty "seperate chunks" $ \(ds0'::[Word8]) (ds1'::[Word8]) -> monadicIO $ do
+ let ds0 = BS.pack ds0'
+ ds1 = BS.pack ds1'
+ QC.assert . ((Just ds0) ==) =<<
+ (lift . runF $
+ (source (map (BL.toStrict . ZLib.compress . BL.fromStrict) [ds0, ds1])) `stack`
+ gunzipper)
+ ]
+ ]
+{-
+zipTests :: TestTree
+zipTests = testGroup "properties"
+ [ testCase "zip on empty stream doesn't error" $ do
+ (Just mempty) @=? (runF $ (source []) `stack` (gzipper 1 (WindowBits 9)))
+ , QC.testProperty "zips" $ \(ds'::[Word8]) ->
+ let ds = BS.pack ds'
+ in (Just $ BL.fromStrict ds) ===
+ (fmap (ZLib.decompress . BL.fromStrict) . runF $ (source [ds]) `stack` (gzipper 1 (WindowBits 9)))
+ ]
+
+inversionTest :: TestTree
+inversionTest = testGroup "inversion test"
+ [ QC.testProperty "zip/unzip" $ \(ds'::[[Word8]]) ->
+ let ds = map BS.pack ds'
+ in (Just $ BL.fromChunks ds) ===
+ (fmap BL.fromStrict . runF $
+ (source ds `stack` gzipper 5 (WindowBits 9)) `stack`
+ gunzipper)
]
+-}
\ No newline at end of file