png-chunk-yaftee (empty) → 0.1.0.0

raw patch · 7 files changed

+316/−0 lines, 7 filesdep +basedep +bitarray-bsdep +bytestring-ftsetup-changed

Dependencies added: base, bitarray-bs, bytestring-ft, higher-order-open-union, mono-traversable, png-chunk-yaftee, tools-yj, typelevel-tools-yj, yaftee, yaftee-basic-monads, yaftee-conduit, yaftee-conduit-bytestring, yaftee-conduit-bytestring-ft, yaftee-conduit-mono-traversable

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +3/−0
Setup.hs +2/−0
png-chunk-yaftee.cabal +80/−0
src/Control/Monad/Yaftee/Pipe/Png/Chunk.hs +192/−0
test/Spec.hs +2/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `png-chunk-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,3 @@+# png-chunk-yaftee++PNG's chunk codec on Yaftee

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ png-chunk-yaftee.cabal view

@@ -0,0 +1,80 @@+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:           png-chunk-yaftee+version:        0.1.0.0+synopsis:       PNG's chunk codec on Yaftee+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/png-chunk-yaftee#readme>+category:       Codec,Graphics,Image+homepage:       https://github.com/YoshikuniJujo/png-chunk-yaftee#readme+bug-reports:    https://github.com/YoshikuniJujo/png-chunk-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/png-chunk-yaftee++library+  exposed-modules:+      Control.Monad.Yaftee.Pipe.Png.Chunk+  other-modules:+      Paths_png_chunk_yaftee+  autogen-modules:+      Paths_png_chunk_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+    , bitarray-bs ==0.1.*+    , bytestring-ft ==0.1.*+    , higher-order-open-union ==0.1.*+    , mono-traversable ==1.0.*+    , tools-yj ==0.1.*+    , typelevel-tools-yj ==0.1.*+    , yaftee ==0.1.*+    , yaftee-basic-monads ==0.1.*+    , yaftee-conduit ==0.1.*+    , yaftee-conduit-bytestring ==0.1.*+    , yaftee-conduit-bytestring-ft ==0.1.*+    , yaftee-conduit-mono-traversable ==0.1.*+  default-language: Haskell2010++test-suite png-chunk-yaftee-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_png_chunk_yaftee+  autogen-modules:+      Paths_png_chunk_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+    , bitarray-bs ==0.1.*+    , bytestring-ft ==0.1.*+    , higher-order-open-union ==0.1.*+    , mono-traversable ==1.0.*+    , png-chunk-yaftee+    , tools-yj ==0.1.*+    , typelevel-tools-yj ==0.1.*+    , yaftee ==0.1.*+    , yaftee-basic-monads ==0.1.*+    , yaftee-conduit ==0.1.*+    , yaftee-conduit-bytestring ==0.1.*+    , yaftee-conduit-bytestring-ft ==0.1.*+    , yaftee-conduit-mono-traversable ==0.1.*+  default-language: Haskell2010

+ src/Control/Monad/Yaftee/Pipe/Png/Chunk.hs view

@@ -0,0 +1,192 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Monad.Yaftee.Pipe.Png.Chunk (++	-- * DATA TYPE++	C(..),++	-- * DECODE++	decode, hDecode, decodeRun_, DecodeStates,++	-- * ENCODE++	encode, hEncode, encodeRun_, EncodeStates++	) where++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Yaftee.Eff qualified as Eff+import Control.Monad.Yaftee.Pipe qualified as Pipe+import Control.Monad.Yaftee.Pipe.Tools qualified as PipeT+import Control.Monad.Yaftee.Pipe.ByteString qualified as PipeBS+import Control.Monad.Yaftee.Pipe.ByteString.FingerTree.OnDemand+	qualified as OnDemand+import Control.Monad.Yaftee.Pipe.MonoTraversable.Crc32+	qualified as PipeCrc32+import Control.Monad.Yaftee.State qualified as State+import Control.Monad.Yaftee.Except qualified as Except+import Control.Monad.Yaftee.Fail qualified as Fail+import Control.Monad.Yaftee.IO qualified as IO+import Control.HigherOpenUnion qualified as U+import Data.Foldable+import Data.MonoTraversable+import Data.Word+import Data.Word.Word8 qualified as Word8+import Data.Word.Crc32 qualified as Crc32+import Data.ByteString.FingerTree qualified as BSF+import Data.ByteString.FingerTree.Bits qualified as BSF+import System.IO	++import Data.HigherFunctor qualified as F+import Data.TypeLevel.List++import Numeric+++decode :: forall nm -> (+	U.Member Pipe.P es, OnDemand.Members nm es,+	U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) =>+	Int -> Eff.E es BSF.ByteString C ()+decode nm n = void $ OnDemand.onDemand nm Pipe.=$= PipeCrc32.crc32 nm Pipe.=$= do+	State.putN nm $ OnDemand.RequestBytes 8+	fh <- Pipe.await+	when (fh /= fileHeader) . Except.throw @String+		$ "Not PNG file: " ++ show fh+	chunks nm n++hDecode :: forall nm -> (+	U.Member Pipe.P es, OnDemand.Members nm es,+	U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es,+	U.Base IO.I es ) =>+	Handle -> Int -> Int -> Eff.E es BSF.ByteString C ()+hDecode nm h n n' = void $+	PipeBS.hGet n h Pipe.=$=+	PipeT.convert BSF.fromStrict Pipe.=$=+	decode nm n'++chunks :: forall nm -> (+	U.Member Pipe.P es, OnDemand.Members nm es,+	U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) =>+	Int -> Eff.E es BSF.ByteString C ()+chunks nm d = fix \go -> do+	b <- chunk1 nm d+	if b then go else Pipe.yield EndOfTheWorld++chunk1 :: forall nm -> (+	U.Member Pipe.P es, OnDemand.Members nm es,+	U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) =>+	Int -> Eff.E es BSF.ByteString C Bool+chunk1 nm d = do+	State.putN nm $ OnDemand.RequestBytes 4+	n <- Word8.toBitsBE @_ @Int <$> Pipe.await+	PipeCrc32.reset nm+	State.putN nm $ OnDemand.RequestBytes 4+	cn <- Pipe.await+--	trace ("chunk1: yield Begin: " ++ show cn) (Pipe.yield $ Begin n cn)+	Pipe.yield $ Begin n cn+	for_ (split d n) \n' -> do+		State.putN nm $ OnDemand.RequestBytes n'+		Pipe.yield . Body =<< Pipe.await+	PipeCrc32.complement nm+	c1 <- State.getN @Crc32.C nm+	State.putN nm $ OnDemand.RequestBytes 4+	c0 <- Crc32.fromWord . Word8.toBitsBE @_ @Word32 <$> Pipe.await+	when (c1 /= c0) $ Except.throw @String+		$ "corrupted -- crc32 mismatch: " +++			showHex (Crc32.toWord c0) "" ++ " " ++ showHex (Crc32.toWord c1) ""+--	trace ("chunk1: yield End: " ++ show cn) $ Pipe.yield End+	Pipe.yield End+	pure $ cn /= "IEND"+	where+	split n = fix \go -> \case+		0 -> []+		m | n < m -> n : go (m - n) | otherwise -> [m]++decodeRun_ ::+	F.Loose (U.U es) =>+	Eff.E (DecodeStates nm `Append` es) i o r -> Eff.E es i o ()+decodeRun_ = void . (`State.runN` Crc32.initial)++type DecodeStates nm = '[State.Named nm Crc32.C]++data C	= Begin Int BSF.ByteString+	| Body BSF.ByteString | End+	| EndOfTheWorld+	deriving Show++fileHeader :: BSF.ByteString+fileHeader = "\137PNG\r\n\SUB\n"++type instance Element C = Word8++instance MonoFoldable C where+	ofoldMap f = \case+		Begin _ bs -> ofoldMap f bs+		Body bs -> ofoldMap f bs; _ -> mempty+	ofoldr o v = \case+		Begin _ bs -> ofoldr o v bs+		Body bs -> ofoldr o v bs; _ -> v+	ofoldl' o v = \case+		Begin _ bs -> ofoldl' o v bs+		Body bs -> ofoldl' o v bs; _ -> v+	ofoldr1Ex o = \case+		Begin _ bs -> ofoldr1Ex o bs+		Body bs -> ofoldr1Ex o bs; _ -> error "instance MonoFoldable C: bad"+	ofoldl1Ex' o = \case+		Begin _ bs -> ofoldl1Ex' o bs+		Body bs -> ofoldl1Ex' o bs; _ -> error "instance MonoFoldable C: bad"++encode :: forall nm -> (+	U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es,+	U.Member (Except.E String) es, U.Member Fail.F es ) =>+	Eff.E es C BSF.ByteString ()+encode nm = void $+	PipeCrc32.crc32 nm+	Pipe.=$= do+		Pipe.yield fileHeader+		fix \go -> (`when` go) =<< encodeChunk1 nm++hEncode :: forall nm -> (+	U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es,+	U.Member (Except.E String) es, U.Member Fail.F es, U.Base IO.I es ) =>+	Handle -> Eff.E es C o ()+hEncode nm ho = void $ encode nm+	Pipe.=$= PipeT.convert BSF.toStrict+	Pipe.=$= PipeBS.hPutStr ho++encodeChunk1 :: forall nm -> (+	U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es,+	U.Member (Except.E String) es, U.Member Fail.F es ) =>+	Eff.E es C BSF.ByteString Bool+encodeChunk1 nm = do+	PipeCrc32.reset nm+	Begin n cn <- Pipe.await+	Pipe.yield . BSF.fromBitsBE' @Word32 $ fromIntegral n+	Pipe.yield cn+	fix \go -> Pipe.await >>= \case+		Body bd -> Pipe.yield bd >> go+		End -> pure ()+		_ -> Except.throw @String "encodeChunk1: bad"+	PipeCrc32.complement nm+	c <- State.getN @Crc32.C nm+	Pipe.yield . BSF.fromBitsBE' $ Crc32.toWord c+	pure $ cn /= "IEND"++encodeRun_ :: forall nm es i o r .+	F.Loose (U.U es) =>+	Eff.E (EncodeStates nm `Append` es) i o r ->+	Eff.E es i o ()+encodeRun_ = void . OnDemand.run @nm . PipeCrc32.run @nm++type EncodeStates nm = State.Named nm Crc32.C ': OnDemand.States nm

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"