packages feed

zlib-yaftee (empty) → 0.1.0.0

raw patch · 7 files changed

+492/−0 lines, 7 filesdep +basedep +bytestringdep +bytestring-ftsetup-changed

Dependencies added: base, bytestring, bytestring-ft, higher-order-open-union, primitive, tools-yj, yaftee, yaftee-basic-monads, yaftee-conduit, zlib-core, zlib-yaftee

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `zlib-yaftee`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,150 @@+# zlib-yaftee++sample1++```Haskell+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Main (main) where++import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Pipe qualified as Pp+import Control.Monad.Yaftee.Pipe.Tools qualified as PpT+import Control.Monad.Yaftee.Pipe.IO qualified as PpIO+import Control.Monad.Yaftee.Pipe.ByteString qualified as PpBS+import Control.Monad.Yaftee.Pipe.Zlib qualified as Z+import Control.Monad.Yaftee.Except qualified as Except+import Control.Monad.Yaftee.IO qualified as IO+import Data.ByteString.FingerTree qualified as BSF+import System.IO+import System.Environment+import Codec.Compression.Zlib.Constant.Core qualified as Z+import Codec.Compression.Zlib.Advanced.Core qualified as Z++readBufSize :: Int+readBufSize = 64 * 5++inputBufSize, outputBufSize :: Int+inputBufSize = 64 * 4+outputBufSize = 64++main :: IO ()+main = do+	fp : _ <- getArgs; h <- openFile fp ReadMode+	(i, o) <- (,)+		<$> Z.cByteArrayMalloc inputBufSize+		<*> Z.cByteArrayMalloc outputBufSize++	void . Eff.runM . Except.run @Z.ReturnCode . Z.run @"" . Pp.run+		. (`Except.catch` IO.print @Z.ReturnCode) . void+		$ PpBS.hGet readBufSize h Pp.=$=+			PpT.convert BSF.fromStrict Pp.=$=+			Z.inflate "" IO (Z.WindowBitsZlibAndGzip 15) i o Pp.=$=+			PpIO.print++	Z.cByteArrayFree i; Z.cByteArrayFree o; hClose h+```++sample2++```Haskell+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Main (main) where++import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Pipe qualified as Pp+import Control.Monad.Yaftee.Pipe.Tools qualified as PpT+import Control.Monad.Yaftee.Pipe.ByteString qualified as PpBS+import Control.Monad.Yaftee.Pipe.Zlib qualified as Z+import Control.Monad.Yaftee.Except qualified as Except+import Data.ByteString qualified as BS+import Data.ByteString.FingerTree qualified as BSF+import System.Environment+import Codec.Compression.Zlib.Constant.Core qualified as Z+import Codec.Compression.Zlib.Advanced.Core qualified as Z++readBufSize :: Int+readBufSize = 64 * 5++inputBufSize, outputBufSize :: Int+inputBufSize = 64 * 4+outputBufSize = 64++main :: IO ()+main = do+	fp : _ <- getArgs; cnt <- BS.readFile fp+	either print BS.putStr $ runST $ inflate cnt++inflate :: forall m . PrimBase m =>+	BS.ByteString -> m (Either Z.ReturnCode BS.ByteString)+inflate s = do+	(i, o) <- (,)	<$> Z.cByteArrayMalloc inputBufSize+			<*> Z.cByteArrayMalloc outputBufSize+	r <- Eff.runM . Except.run @Z.ReturnCode . Z.run @"" . PpBS.to+		$ PpBS.from readBufSize s Pp.=$=+			PpT.convert BSF.fromStrict Pp.=$=+			Z.inflate "" m (Z.WindowBitsZlibAndGzip 15) i o Pp.=$=+			PpT.convert BSF.toStrict+	r <$ (Z.cByteArrayFree i >> Z.cByteArrayFree o)+```++sample3++```Haskell+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Main (main) where++import Control.Monad+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Pipe qualified as Pp+import Control.Monad.Yaftee.Pipe.Tools qualified as PpT+import Control.Monad.Yaftee.Pipe.IO qualified as PpIO+import Control.Monad.Yaftee.Pipe.ByteString qualified as PpBS+import Control.Monad.Yaftee.Pipe.Zlib qualified as PpZ+import Control.Monad.Yaftee.Except qualified as Ex+import Control.Monad.Yaftee.IO qualified as IO+import Data.ByteString.FingerTree qualified as BSF+import System.IO+import System.Environment+import Codec.Compression.Zlib.Constant.Core qualified as Z+import Codec.Compression.Zlib.Advanced.Core qualified as Z++main :: IO ()+main = do+	fp : as <- getArgs; h <- openFile fp ReadMode+	let	opt = case as of+			[] -> options $ Z.WindowBitsRaw 15+			["zlib"] -> options $ Z.WindowBitsZlib 15+			["gzip"] -> options $ Z.WindowBitsGzip 15+			_ -> error "bad arguments"+	ib <- PpZ.cByteArrayMalloc 64; ob <- PpZ.cByteArrayMalloc 64+	_ <- Eff.runM . Ex.run @Z.ReturnCode . PpZ.run @"" . Pp.run+		. (`Ex.catch` IO.print @Z.ReturnCode) . void $ PpBS.hGet 32 h+			Pp.=$= PpT.convert BSF.fromStrict+			Pp.=$= PpZ.deflate "" IO opt ib ob+			Pp.=$= PpIO.print+	PpZ.cByteArrayFree ib; PpZ.cByteArrayFree ob; hClose h++options :: Z.WindowBits -> PpZ.DeflateOptions+options wb = PpZ.DeflateOptions {+	PpZ.deflateOptionsCompressionLevel = Z.DefaultCompression,+	PpZ.deflateOptionsCompressionMethod = Z.Deflated,+	PpZ.deflateOptionsWindowBits = wb,+	PpZ.deflateOptionsMemLevel = Z.MemLevel 8,+	PpZ.deflateOptionsCompressionStrategy = Z.DefaultStrategy }+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/Yaftee/Pipe/Zlib.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Pipe.Zlib (++	-- * RUN++	run, ByteString,++	-- * DEFLATE++	deflate, DeflateOptions(..),++	-- * INFLATE++	inflate,++	-- * C BYTE ARRAY++	CByteArray, cByteArrayMalloc, cByteArrayFree++	) where++import Foreign.Ptr+import Foreign.C.String+import Foreign.C.ByteArray qualified as CByteArray+import Control.Monad+import Control.Monad.ToolsYj+import Control.Monad.Primitive+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Pipe qualified as Pipe+import Control.Monad.Yaftee.State qualified as State+import Control.Monad.Yaftee.Except qualified as Except+import Control.HigherOpenUnion qualified as U+import Data.HigherFunctor qualified as HFunctor++import Codec.Compression.Zlib.Structure.Core qualified as Zlib+import Codec.Compression.Zlib.Constant.Core qualified as Zlib+import Codec.Compression.Zlib.Basic.Core qualified as Zlib+import Codec.Compression.Zlib.Advanced.Core qualified as Zlib++import Data.ByteString qualified as BS+import Data.ByteString.FingerTree qualified as BSF+import Data.ByteString.FingerTree.CString qualified as BSF++-- import Debug.Trace qualified as Trace++trace :: String -> a -> a+trace = const id -- Trace.trace++run :: forall nm es i o r . HFunctor.Loose (U.U es) =>+	Eff.E (State.Named nm (Maybe ByteString) ': es) i o r ->+	Eff.E es i o r+run = (fst <$>) . (`State.runN` (Nothing :: Maybe ByteString))++newtype ByteString = ByteString { unByteString :: BSF.ByteString } deriving Show++newtype CByteArray s = CByteArray { unCByteArray :: CByteArray.B } deriving Show++cByteArrayMalloc :: PrimMonad m => Int -> m (CByteArray (PrimState m))+cByteArrayMalloc n = unsafeIOToPrim $ CByteArray <$> CByteArray.malloc n++cByteArrayFree :: PrimMonad m => CByteArray (PrimState m) -> m ()+cByteArrayFree (CByteArray ba) = unsafeIOToPrim $ CByteArray.free ba++data DeflateOptions = DeflateOptions {+	deflateOptionsCompressionLevel :: Zlib.CompressionLevel,+	deflateOptionsCompressionMethod :: Zlib.CompressionMethod,+	deflateOptionsWindowBits :: Zlib.WindowBits,+	deflateOptionsMemLevel :: Zlib.MemLevel,+	deflateOptionsCompressionStrategy :: Zlib.CompressionStrategy }+	deriving Show++deflate :: forall nm m -> (+	PrimBase m,+	U.Member Pipe.P es, U.Member (State.Named nm (Maybe ByteString)) es,+	U.Member (Except.E Zlib.ReturnCode) es, U.Base (U.FromFirst m) es ) =>+	DeflateOptions ->+	CByteArray (PrimState m) -> CByteArray (PrimState m) ->+	Eff.E es BSF.ByteString BSF.ByteString BSF.ByteString+deflate nm m dos bai bao = do+	strm <- initialize nm m+		(\s os -> Zlib.deflateInit2 s+			(deflateOptionsCompressionLevel os)+			(deflateOptionsCompressionMethod os)+			(deflateOptionsWindowBits os)+			(deflateOptionsMemLevel os)+			(deflateOptionsCompressionStrategy os))+		dos bai bao+	doWhile_ $ body nm m Zlib.deflate bai bao strm+	finalize @m Zlib.deflateEnd strm+	restOfInput nm m strm++inflate :: forall nm m -> (+	PrimBase m,+	U.Member Pipe.P es, U.Member (State.Named nm (Maybe ByteString)) es,+	U.Member (Except.E Zlib.ReturnCode) es, U.Base (U.FromFirst m) es ) =>+	Zlib.WindowBits ->+	CByteArray (PrimState m) -> CByteArray (PrimState m) ->+	Eff.E es BSF.ByteString BSF.ByteString BSF.ByteString+inflate nm m wbs bai bao = do+	strm <- initialize nm m Zlib.inflateInit2 wbs bai bao+	doWhile_ $ body nm m Zlib.inflate bai bao strm+	finalize @m Zlib.inflateEnd strm+	restOfInput nm m strm++initialize :: forall nm m -> (+	PrimBase m,+	U.Member Pipe.P es, U.Member (State.Named nm (Maybe ByteString)) es,+	U.Member (Except.E Zlib.ReturnCode) es, U.Base (U.FromFirst m) es ) =>+	(forall m' . PrimBase m' =>+		Zlib.StreamPrim (PrimState m') -> arg -> m' Zlib.ReturnCode) ->+	arg -> CByteArray (PrimState m) -> CByteArray (PrimState m) ->+	Eff.E es BSF.ByteString BSF.ByteString (Zlib.StreamPrim (PrimState m))+initialize nm m f a+	(CByteArray (castPtr -> i, ni))+	(CByteArray (o, (fromIntegral -> no'))) = do+	bs0 <- awaitInput+	((castPtr -> i0, fromIntegral -> n0), ebs0) <-+		Eff.effBase . unsafeIOToPrim @m $ BSF.poke (i, ni) bs0+	either (const $ pure ()) (putInput nm ByteString) ebs0+	strm <- Eff.effBase $ Zlib.streamThaw @m Zlib.streamInitial {+		Zlib.streamNextIn = i0, Zlib.streamAvailIn = n0,+		Zlib.streamNextOut = o, Zlib.streamAvailOut = no' }+	rc0 <- Eff.effBase $ f @m strm a+	when (rc0 /= Zlib.Ok) $ Except.throw rc0+	pure strm++awaitInput :: U.Member Pipe.P es => Eff.E es BSF.ByteString o BSF.ByteString+awaitInput = do+	bs <- Pipe.await+	if BSF.null bs then awaitInput else pure bs++awaitInputMaybe :: U.Member Pipe.P es => (i -> Bool) -> Eff.E es i o (Maybe i)+awaitInputMaybe p = Pipe.awaitMaybe >>= \case+	Nothing -> pure Nothing+	Just bs -> if p bs then awaitInputMaybe p else pure $ Just bs++finalize :: forall m es i o . ( -- forall m -> (+	U.Member (Except.E Zlib.ReturnCode) es, U.Base (U.FromFirst m) es ) =>+	(Zlib.StreamPrim (PrimState m) -> m Zlib.ReturnCode) ->+	Zlib.StreamPrim (PrimState m) -> Eff.E es i o ()+finalize f strm = do+	rc <- Eff.effBase $ f strm+	trace "FINALIZE" $ pure ()+	when (rc /= Zlib.Ok) do+--		cmsg <- Eff.effBase $ Zlib.msg @m strm+--		msg <- Eff.effBase . unsafeIOToPrim @m $ peekCString cmsg+--		trace msg $ pure ()+		Except.throw rc++body :: forall nm m -> (+	PrimBase m,+	U.Member Pipe.P es,+	U.Member (State.Named nm (Maybe ByteString)) es,+	U.Member (Except.E Zlib.ReturnCode) es,+	U.Base (U.FromFirst m) es ) =>+	(forall m' . PrimBase m' => Zlib.StreamPrim (PrimState m') -> Zlib.Flush -> m' Zlib.ReturnCode) ->+	CByteArray (PrimState m) -> CByteArray (PrimState m) ->+	Zlib.StreamPrim (PrimState m) ->+	Eff.E es BSF.ByteString BSF.ByteString Bool+body nm m f+	(CByteArray (castPtr -> i, ni))+	(CByteArray (o@(castPtr -> o'), no@(fromIntegral -> no')))+	strm = do+		rc <- Eff.effBase $ f @m strm Zlib.NoFlush+--		rc <- Eff.effBase $ f @m strm Zlib.FullFlush+		ai <- Eff.effBase @m $ Zlib.availIn strm+		(fromIntegral -> ao) <- Eff.effBase @m $ Zlib.availOut strm+		when (rc `notElem` [Zlib.Ok, Zlib.StreamEnd]) do+			cmsg <- Eff.effBase $ Zlib.msg @m strm+			msg <- Eff.effBase . unsafeIOToPrim @m $ peekCString cmsg+			trace msg $ pure ()+			Except.throw rc+		Pipe.yield =<< Eff.effBase+			(unsafeIOToPrim @m $ BSF.peek (o', no - ao))+		Eff.effBase $ Zlib.setNextOut @m strm o no'+		whenDef (rc /= Zlib.StreamEnd) (rc /= Zlib.StreamEnd && ai == 0) do+			minp <- getInput nm BSF.null unByteString+			case minp of+				Nothing -> do+					doWhile_ do+						rc' <- Eff.effBase $ f @m strm Zlib.Finish+						(fromIntegral -> ao') <- Eff.effBase @m $ Zlib.availOut strm+						Pipe.yield =<< Eff.effBase+							(unsafeIOToPrim @m $ BSF.peek (o', no - ao'))+						trace (show rc') $ pure ()+						Eff.effBase $ Zlib.setNextOut @m strm o no'+						pure $ rc' /= Zlib.StreamEnd+					pure False+				Just inp -> do+					((castPtr -> i', fromIntegral -> n), ebs) <- Eff.effBase+						. unsafeIOToPrim @m+						$ BSF.poke (i, ni) inp+					either (const $ pure ()) (putInput nm ByteString) ebs+					Eff.effBase $ Zlib.setNextIn @m strm i' n+					pure $ rc /= Zlib.StreamEnd++restOfInput :: forall nm m -> (+	PrimBase m,+	U.Member (State.Named nm (Maybe ByteString)) es,+	U.Base (U.FromFirst m) es ) =>+	Zlib.StreamPrim (PrimState m) ->+	Eff.E es i o BSF.ByteString+restOfInput nm m strm = do+	(castPtr -> i') <- Eff.effBase @m $ Zlib.nextIn strm+	(fromIntegral -> ai) <- Eff.effBase @m $ Zlib.availIn strm+	rbs <- Eff.effBase @m . unsafeIOToPrim $ BS.packCStringLen (i', ai)+	ByteString bs' <- maybe (ByteString "") id <$> State.getN nm+	pure $ rbs BSF.:<| bs'++getInput :: forall es i' i o . forall nm ->+	(U.Member Pipe.P es, U.Member (State.Named nm (Maybe i')) es) =>+	(i -> Bool) -> (i' -> i) -> Eff.E es i o (Maybe i)+getInput nm p un = State.getN nm+	>>= maybe (awaitInputMaybe p) ((<$ State.putN @(Maybe i') nm Nothing) . Just . un)++putInput :: forall nm -> (U.Member (State.Named nm (Maybe i')) es) =>+	(i -> i') -> i -> Eff.E es i o ()+putInput nm to = State.putN nm . Just . to
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ zlib-yaftee.cabal view
@@ -0,0 +1,74 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           zlib-yaftee+version:        0.1.0.0+synopsis:       Zlib wrapper built on Yaftee+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/zlib-yaftee#readme>+category:       Codec+homepage:       https://github.com/YoshikuniJujo/zlib-yaftee#readme+bug-reports:    https://github.com/YoshikuniJujo/zlib-yaftee/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      (c) 2025 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/zlib-yaftee++library+  exposed-modules:+      Control.Monad.Yaftee.Pipe.Zlib+  other-modules:+      Paths_zlib_yaftee+  autogen-modules:+      Paths_zlib_yaftee+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.12.*+    , bytestring-ft ==0.1.*+    , higher-order-open-union ==0.1.*+    , primitive ==0.9.*+    , tools-yj ==0.1.*+    , yaftee ==0.1.*+    , yaftee-basic-monads ==0.1.*+    , yaftee-conduit ==0.1.*+    , zlib-core ==0.1.*+  default-language: Haskell2010++test-suite zlib-yaftee-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_zlib_yaftee+  autogen-modules:+      Paths_zlib_yaftee+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.12.*+    , bytestring-ft ==0.1.*+    , higher-order-open-union ==0.1.*+    , primitive ==0.9.*+    , tools-yj ==0.1.*+    , yaftee ==0.1.*+    , yaftee-basic-monads ==0.1.*+    , yaftee-conduit ==0.1.*+    , zlib-core ==0.1.*+    , zlib-yaftee+  default-language: Haskell2010