packages feed

png-file (empty) → 0.0.1.0

raw patch · 9 files changed

+883/−0 lines, 9 filesdep +arraydep +basedep +binary-filesetup-changed

Dependencies added: array, base, binary-file, bytestring, monads-tf, template-haskell, zlib

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * 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.++  * Neither the name of the Yoshikuni Jujo 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 EVEN 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ png-file.cabal view
@@ -0,0 +1,41 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		png-file+version:	0.0.1.0+stability:	Experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://skami.iocikun.jp/haskell/packages/png-file++license:	BSD3+license-file:	LICENSE++category:	File+synopsis:	read/write png file+description:++    It's just alpha version now.++source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/png-file.git++source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/png-file.git+    tag:	0.0.1.0++library+    hs-source-dirs:	src+    exposed-modules:	File.Binary.PNG+    other-modules:+        File.Binary.PNG.Data,+        File.Binary.PNG.Chunks,+        File.Binary.PNG.Chunks.CRC,+        File.Binary.PNG.Chunks.Each,+        Language.Haskell.TH.Tools+    build-depends:+        base > 3 && < 5, binary-file, bytestring, zlib, array,+        template-haskell, monads-tf+    ghc-options:	-Wall
+ src/File/Binary/PNG.hs view
@@ -0,0 +1,63 @@+module File.Binary.PNG (+	getChunks,+	putChunks,++	mkChunks,+	ihdr, IHDR(..),+	plte,+	body,+	others,+	ICCP(..),++	TypeChunk(..),+	typeChunk,+	Chunk(..),+	makePNGHeader,+	bsToPNGImage,+	pngImageToBS,+	PNGImageL(..),+	PNGImageLColor(..),++	readIccp+) where++import Prelude hiding (concat)+import Data.List (find)+import Data.Maybe (fromJust)+import Data.ByteString.Lazy (ByteString, toChunks, fromChunks, concat)+import Codec.Compression.Zlib (+	decompress, compressWith, defaultCompressParams, CompressParams(..),+	bestCompression, WindowBits(..))+import File.Binary.PNG.DataChunks (+	Chunk(..), TypeChunk(..), typeChunk, IHDR(..), PLTE, IDAT(..),+	ICCP(..),+	getChunks, putChunks, makePNGHeader, bsToPNGImage, PNGImageL(..),+	PNGImageLColor(..), pngImageToBS, readIccp)++--------------------------------------------------------------------------------++body :: [Chunk] -> ByteString+body = decompress . concat . map (idat_body . (\(ChunkIDAT i) -> i)) .+	filter ((== T_IDAT) . typeChunk)++mkBody :: ByteString -> [Chunk]+mkBody = map (ChunkIDAT . IDAT . fromChunks . (: [])) . toChunks .+	compressWith defaultCompressParams {+		compressLevel = bestCompression,+		compressWindowBits = WindowBits 10+	 }++ihdr :: [Chunk] -> IHDR+ihdr = (\(ChunkIHDR i) -> i) . fromJust . find ((== T_IHDR) . typeChunk)++plte :: [Chunk] -> Maybe PLTE+plte c = do+	ChunkPLTE pl <- find ((== T_PLTE) . typeChunk) c+	return pl++others :: [Chunk] -> [Chunk]+others = filter $ (`notElem` [T_IHDR, T_PLTE, T_IDAT, T_IEND]) . typeChunk++mkChunks :: IHDR -> Maybe PLTE -> [Chunk] -> ByteString -> [Chunk]+mkChunks i (Just p) cs b = ChunkIHDR i : ChunkPLTE p : mkBody b ++ cs+mkChunks i Nothing cs b = ChunkIHDR i : mkBody b ++ cs
+ src/File/Binary/PNG/Chunks.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}++module File.Binary.PNG.Chunks (+	Chunk(..),+	TypeChunk(..),+	typeChunk,++	getChunks,+	putChunks,++	IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..),+	TRNS,+	CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..),+	ITXT, TEXT(..), ZTXT,+	BKGD(..), HIST, PHYS, SPLT,+	TIME,+	DATA(..)+) where++import Control.Applicative ((<$>))+import Control.Arrow (first)+import Control.Monad (unless)+import Data.Monoid (mempty)+import Data.List (isPrefixOf)+import Data.ByteString.Lazy (ByteString, append)+import qualified Data.ByteString.Lazy as BSL (length)+import Language.Haskell.TH (+	newName, nameBase, litP, stringL,+	cxt, instanceD, tySynInstD, clause, normalB,+	conT, appT, conP, varP, wildP, tupP, conE, varE, appE, appsE, infixApp)+import Language.Haskell.TH.Tools (wrapTypes, makeTypes, nameTypes, mapTypesFun)+import File.Binary (binary, Field(..), Binary(..))+import File.Binary.Instances ()+import File.Binary.Instances.BigEndian ()+import File.Binary.PNG.Chunks.CRC (crc, checkCRC)+import File.Binary.PNG.Chunks.Each (+	IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..),+	TRNS, CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..), ITXT, TEXT(..), ZTXT,+	BKGD(..), HIST, PHYS, SPLT, TIME, DATA(..),+	chunkNames, beforePLTE, beforeIDAT, anyPlace)+++--------------------------------------------------------------------------------++wrapTypes "Chunk" chunkNames ("ChunkOthers", [''ByteString, ''ByteString]) [''Show]+makeTypes "TypeChunk" ''Chunk "Chunk" "T_"+nameTypes ''TypeChunk "T_" 'T_Others ''ByteString++(:[]) <$> do+	let	removePrefix prefix str+			| prefix `isPrefixOf` str = drop (length prefix) str+			| otherwise = str+	instanceD (cxt []) (conT ''Field `appT` conT ''Chunk) [+		tySynInstD ''FieldArgument [conT ''Chunk] [t| (Int, ByteString) |],+		mapTypesFun 'fromBinary ''Chunk $ \con _ -> do+			[n, typ] <- mapM newName ["n", "typ"]+			let (t, c) = if con /= 'ChunkOthers+				then (litP $ stringL $ removePrefix "Chunk" $+					nameBase con, conE con)+				else (varP typ, conE con `appE` varE typ)+			flip (clause [tupP [varP n, t]]) [] $ normalB $ infixApp+				(varE 'fmap `appE` (varE 'first `appE` c))+				(varE '(.))+				(varE 'fromBinary `appE` varE n),+		mapTypesFun 'toBinary ''Chunk $ \con _ -> do+			[n, dt] <- mapM newName ["n", "dt"]+			let d = conP con $ if con /= 'ChunkOthers+				then [varP dt] else [wildP, varP dt]+			flip (clause [tupP [varP n, wildP], d]) [] $ normalB $+				appsE [varE 'toBinary, varE n, varE dt]]++bplte, bidat, aplace :: [TypeChunk]+[bplte, bidat, aplace] =+	map (map nameToTypeChunk) [beforePLTE, beforeIDAT, anyPlace]++getChunks :: Binary b => b -> Either String [Chunk]+getChunks b = do+	(p, rest) <- fromBinary () b+	unless (rest == mempty) $ fail "couldn't read whole binary"+	return $ map chunkData $ chunks p++putChunks :: Binary b => [Chunk] -> Either String b+putChunks cs = do+	ret <- mapM createChunk $ sortChunks cs+	toBinary () $ PNGFile $ ret++createChunk :: Chunk -> Either String ChunkStructure+createChunk cd = do+	let name = typeChunkToName $ typeChunk cd+	ret <- toBinary (undefined, name)  cd+	return $ ChunkStructure {+		chunkSize = fromIntegral $ BSL.length ret,+		chunkName = name,+		chunkData = cd,+		chunkCRC = CRC }++sortChunks :: [Chunk] -> [Chunk]+sortChunks cs = concatMap (($ cs) . filterChunks)+	[[T_IHDR], bplte, [T_PLTE], bidat, [T_IDAT], aplace, [T_IEND]]+	where+	filterChunks ts = filter $ (`elem` ts) . typeChunk++[binary|++PNGFile deriving Show++1: 0x89+3: "PNG"+2: "\r\n"+1: "\SUB"+1: "\n"+repeat (){[ChunkStructure]}: chunks++|]++[binary|++ChunkStructure deriving Show++4: chunkSize+4{ByteString}: chunkName+(chunkSize, chunkName){Chunk}: chunkData+(chunkName, chunkData, (chunkSize, chunkName)){CRC}: chunkCRC++|]++data CRC = CRC deriving Show++instance Field CRC where+	type FieldArgument CRC = (ByteString, Chunk, (Int, ByteString))+	fromBinary (name, body, arg) b = do+		let (bs, rest) = getBytes 4 b+		ret <- toBinary arg body+		if checkCRC (name `append` ret) bs+			then return (CRC, rest)+			else fail "bad crc"+	toBinary (name, body, arg) _ = do+		ret <- toBinary arg body+		return $ makeBinary $ crc $ name `append` ret
+ src/File/Binary/PNG/Chunks/CRC.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++module File.Binary.PNG.Chunks.CRC (checkCRC, crc) where++import Prelude hiding (reverse)+import Data.Array (Array, listArray, (!))+import Data.Word (Word32)+import Data.Bits ((.&.), xor, shiftR)+import Data.ByteString.Lazy (ByteString, cons', append, reverse)+import qualified Data.ByteString.Lazy as BSL (foldl)+import Data.ByteString.Lazy.Char8 ()++--------------------------------------------------------------------------------++checkCRC :: ByteString -> ByteString -> Bool+checkCRC str c = crc (str `append` reverse c) == "\x21\x44\xdf\x1c"++crc :: ByteString -> ByteString+crc = reverse . word32ToBS . xor 0xffffffff . BSL.foldl crc' 0xffffffff+	where+	crc' c x = table ! (c .&. 0xff `xor` fromIntegral x) `xor` shiftR c 8++table :: Array Word32 Word32+table = listArray (0, 255) $ map (\n -> iterate crc8bit n !! 8) [0 .. 255]++crc8bit :: Word32 -> Word32+crc8bit c+	| c .&. 1 == 0 = shiftR c 1+	| otherwise = 0xedb88320 `xor` shiftR c 1++word32ToBS :: Word32 -> ByteString+word32ToBS 0 = ""+word32ToBS w = fromIntegral (w .&. 0xff) `cons'` word32ToBS (w `shiftR` 8)
+ src/File/Binary/PNG/Chunks/Each.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}++module File.Binary.PNG.Chunks.Each (+	IHDR(..), PLTE(..), RGB8(..), IDAT(..), IEND(..),+	TRNS,+	CHRM(..), GAMA(..), ICCP(..), SBIT, SRGB(..),+	ITXT, TEXT(..), ZTXT,+	BKGD(..), HIST, PHYS, SPLT, TIME,+	DATA(..),++	chunkNames, critical, beforePLTE, beforeIDAT, anyPlace+) where++import Data.Monoid (mconcat)+import Data.ByteString.Lazy (ByteString, append)+import File.Binary (binary, Field(..), Binary(..))+import File.Binary.Instances ()+import File.Binary.Instances.BigEndian ()+import File.Binary.Instances.MSB0 ()+import qualified Data.ByteString.Lazy.Char8 as BSLC++--------------------------------------------------------------------------------++chunkNames, critical, beforePLTE, beforeIDAT, anyPlace :: [String]+chunkNames = critical ++ beforePLTE ++ beforeIDAT ++ anyPlace+critical = ["IHDR", "PLTE", "IDAT", "IEND"]+beforePLTE = ["cHRM", "gAMA", "iCCP", "sBIT", "sRGB", "bKGD", "hIST", "tRNS"]+beforeIDAT = ["pHYs", "sPLT"]+anyPlace = ["tIME", "iTXt", "tEXt", "zTXt"]++type TRNS = DATA+-- type ICCP = DATA+type SBIT = DATA+type ITXT = DATA+type ZTXT = DATA+type HIST = DATA+type PHYS = DATA+type SPLT = DATA+type TIME = DATA++[binary|++IHDR deriving Show++arg :: Int++4: width+4: height+1: depth+: False+: False+: False+: False+: False+{Bool}: alpha+{Bool}: color+{Bool}: palet+1: compressionType+1: filterType+1: interlaceType++|]++[binary|++PLTE deriving Show++arg :: Int++replicate (arg `div` 3) (){[RGB8]}: colors++|]++data RGB8 = RGB8 { red :: Int, green :: Int, blue :: Int } deriving Show++instance Field RGB8 where+	type FieldArgument RGB8 = ()+	toBinary () RGB8{ red = r, green = g, blue = b } = do+		r' <- toBinary 1 r+		g' <- toBinary 1 g+		b' <- toBinary 1 b+		return $ mconcat [r', g', b']+	fromBinary () bin = do+		(r, bin') <- fromBinary 1 bin+		(g, bin'') <- fromBinary 1 bin'+		(b, bin''') <- fromBinary 1 bin''+		return (RGB8{ red = r, green = g, blue = b } , bin''')++[binary|++IDAT deriving Show++arg :: Int++arg{ByteString}: idat_body++|]++[binary|IEND deriving Show arg :: Int|]++[binary|++CHRM deriving Show++arg :: Int++replicate (arg `div` 4) 4{[Int]}: chrms++|]++[binary|++GAMA deriving Show++arg :: Int++4: gamma++|]++[binary|++ICCP deriving Show++arg :: Int++{NullString}: iccp_name+1: iccp_con+(arg - length (nullString iccp_name) - 2){ByteString}: iccp_body++|]++data NullString = NullString { nullString :: String } deriving Show++instance Field NullString where+	type FieldArgument NullString = ()+	toBinary () (NullString str) =+		return $ makeBinary $ (`append` "\NUL") $ BSLC.pack str+	fromBinary () bin = do+		let (ret, rest) = spanBytes (/= 0) bin+		return (NullString $ BSLC.unpack ret, snd $ unconsByte rest)++[binary|++SRGB deriving Show++arg :: Int++1: srgb++|]++[binary|++TEXT deriving Show++arg :: Int++replicate arg (){String}: text++|]++[binary|++BKGD deriving Show++arg :: Int++arg{ByteString}: bkgd++|]++[binary|++DATA deriving Show++arg :: Int++arg{ByteString}: dat++|]
+ src/File/Binary/PNG/Data.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE+	TypeFamilies,+	FlexibleContexts,+	ScopedTypeVariables,+	TupleSections,+	OverloadedStrings,+	PackageImports #-}++module File.Binary.PNG.Data (+	PNG(..), PNGImage(..), PNGColorType(..), PNGHeader(..),+	PNGImageL(..), PNGImageLColor(..), readIccp,+) where++import qualified Data.ByteString.Lazy as BSL+import Data.Word+import Data.Int+import Data.Maybe+import Data.Bits+import Codec.Compression.Zlib+import "monads-tf" Control.Monad.Error++data PNG pi = PNG PNGValues [(String, BSL.ByteString)] pi++data PNGValues = PNGValues {+	pngChrm :: PNGChrm,+	pngGama :: Int,+	pngIccp :: (String, BSL.ByteString)+ }++readIccp :: BSL.ByteString -> BSL.ByteString+readIccp = decompress++data PNGChrm = PNGChrm {+	pngChrmWhite :: (Int, Int),+	pngChrmRed :: (Int, Int),+	pngChrmGreen :: (Int, Int),+	pngChrmBlue :: (Int, Int)+ }++data PNGHeader = PNGHeader {+	pngWidth :: Int,+	pngHeight :: Int,+	pngDepth :: Int,+	pngColorType :: PNGColorType,+	pngCompType :: Int,+	pngFilterType :: Int,+	pngInterlaceType :: Int,+	pngPalette :: [(Int, Int, Int)]+ } deriving Show++data PNGColorType+	= PNGTypeIndex { piTrans :: [Int] }+	| PNGTypeGrey { pgTrans :: Maybe Int } | PNGTypeGreyAlpha+	| PNGTypeColor { pcTrans :: Maybe (Int, Int, Int) } | PNGTypeColorAlpha+	deriving Show++class PNGColor (PNGImageColor pi) => PNGImage pi where+	type PNGImageColor pi+	type PNGImageError pi++	makePNGImage :: PNGHeader -> BSL.ByteString -> pi+	fromPNGImage :: pi -> (PNGHeader, BSL.ByteString)++	goNext :: pi -> Either (PNGImageError pi) pi+	getXY :: pi -> (Int, Int)++	goUp :: pi -> Either (PNGImageError pi) pi+	goDown :: pi -> Either (PNGImageError pi) pi+	goLeft :: pi -> Either (PNGImageError pi) pi+	goRight :: pi -> Either (PNGImageError pi) pi++	getPixel :: pi -> PNGImageColor pi+	setPixel :: pi -> PNGImageColor pi -> pi++--	toPalet :: pi -> Either (PNGImageError pi) pi+--	toGrey :: pi -> Either (PNGImageError pi) pi+--	fromAlpha :: pi -> Either (PNGImageError pi) pi+	toInterlace :: pi -> pi+	fromInterlace :: pi -> pi++class PNGColor pc where++data PNGImageL = PNGImageL {+	pilInterlace :: Bool,+	pilBits :: Int,+	pilBackLines :: [([PNGImageLColor], [PNGImageLColor])],+	pilForwardLines :: [([PNGImageLColor], [PNGImageLColor])]}+	deriving Show++data PNGImageLColor = PNGImageLColor Int Int Int Int deriving Show++instance PNGImage PNGImageL where+	type PNGImageColor PNGImageL = PNGImageLColor+	type PNGImageError PNGImageL = String+	makePNGImage = makePNGImageL+	fromPNGImage = fromPNGImageL++	goUp = pngImageLUp+	goDown = pngImageLDown+	goLeft = pngImageLLeft+	goRight = pngImageLRight++instance PNGColor PNGImageLColor where++pngImageLUp, pngImageLDown, pngImageLLeft, pngImageLRight ::+	PNGImageL -> Either String PNGImageL+pngImageLUp (PNGImageL _ _ [] _) = fail "can't go up"+pngImageLUp (PNGImageL False bits (u : us) ds) =+	return $ PNGImageL False bits us (u : ds)+pngImageLDown (PNGImageL _ _ _ []) = fail "can't go down"+pngImageLDown (PNGImageL False bits us (d : ds)) =+	return $ PNGImageL False bits (d : us) ds+pngImageLLeft (PNGImageL False bits us ds) = do+	us' <- mapM gl us+	ds' <- mapM gl ds+	return $ PNGImageL False bits us' ds'+	where+	gl ([], _) = fail "can't go left"+	gl (l : ls, rs) = return (ls, l : rs)+pngImageLRight (PNGImageL False bits us ds) = do+	us' <- mapM gr us+	ds' <- mapM gr ds+	return $ PNGImageL False bits us' ds'+	where+	gr (_, []) = fail "can't go right"+	gl (ls, r : rs) = return (r : ls, rs)++fromPNGImageL :: PNGImageL -> (PNGHeader, BSL.ByteString)+fromPNGImageL pil@(PNGImageL False 8 us ds) = (+	PNGHeader {+		pngWidth = pilWidth pil,+		pngHeight = pilHeight pil,+		pngDepth = 8,+		pngColorType = PNGTypeColor Nothing,+		pngCompType = 0,+		pngFilterType = 0,+		pngInterlaceType = 0,+		pngPalette = []+	 },+	BSL.pack $+		filterPNGImageL (replicate (w + 1) $ PNGImageLColor 0 0 0 65535)+			$ map (\(ls, rs) -> ls ++ rs) $ us ++ ds+--		concatMap (\(ls, rs) ->+--		0 : concatMap pilColorToWord8 (ls ++ rs)) $ us ++ ds+ )+	where+	w = case (us, ds) of+		((rs, ls) : _, _) -> length rs + length ls+		(_, (rs, ls) : _) -> length rs + length ls++pilWidth, pilHeight :: PNGImageL -> Int+pilWidth (PNGImageL False _ ((ls, rs) : _) _) = length ls + length rs+pilWidth (PNGImageL False _ _ ((ls, rs) : _)) = length ls + length rs+pilHeight (PNGImageL False _ us ds) = length us + length ds++filterPNGImageL :: [PNGImageLColor] -> [[PNGImageLColor]] -> [Word8]+filterPNGImageL _ [] = []+filterPNGImageL pre (l : ls) = 4 :+	filterLinePNGImageL pre (PNGImageLColor 0 0 0 65535) l +++	filterPNGImageL (PNGImageLColor 0 0 0 65535 : l) ls++filterLinePNGImageL :: [PNGImageLColor] -> PNGImageLColor -> [PNGImageLColor] -> [Word8]+filterLinePNGImageL _ _ [] = []+filterLinePNGImageL pre left (px : pxs) =+	pilColorToWord8f 4 pre left px +++	filterLinePNGImageL (tail pre) px pxs++pilColorToWord8f ::+	Int -> [PNGImageLColor] -> PNGImageLColor -> PNGImageLColor -> [Word8]+pilColorToWord8f 4 pre left px = let+	PNGImageLColor rlu glu blu 65535 : PNGImageLColor ru gu bu 65535 : _ = pre+	PNGImageLColor rl gl bl 65535 = left+	PNGImageLColor rpx gpx bpx 65535 = px in [+{-+		fi rpx - ((fi ru + fi rl) `div` 2),+		fi gpx - ((fi gu + fi gl) `div` 2),+		fi bpx - ((fi bu + fi bl) `div` 2)+-}+		fi rpx - paeth' (fi rl) (fi ru) (fi rlu),+		fi gpx - paeth' (fi gl) (fi gu) (fi glu),+		fi bpx - paeth' (fi bl) (fi bu) (fi blu)+	 ]+	where+	fi = fromIntegral . (`shiftR` 8)++pilColorToWord8 :: PNGImageLColor -> [Word8]+pilColorToWord8 (PNGImageLColor r g b 65535) = [fi r, fi g, fi b]+	where+	fi = fromIntegral . (`shiftR` 8)++makePNGImageL :: PNGHeader -> BSL.ByteString -> PNGImageL+makePNGImageL PNGHeader {+	pngWidth = w,+	pngHeight = h,+	pngDepth = 8,+	pngColorType = PNGTypeColor Nothing,+	pngCompType = 0,+	pngFilterType = 0,+	pngInterlaceType = 0+ } bs = PNGImageL False 8 [] $ map ([] ,) $ bsToImageA w bs++makePNGImageL PNGHeader {+	pngWidth = w,+	pngHeight = h,+	pngDepth = 2,+	pngColorType = PNGTypeIndex [],+	pngCompType = 0,+	pngFilterType = 0,+	pngInterlaceType = 0,+	pngPalette = p+ } bs = PNGImageL False 8 [] $ map ([] ,) $+	groupN w $ map (intsToPNGImageLColor . (p !!)) $ concatMap toIndexes2 $+		map BSL.tail $ groupNBS (w `div` 4 + 1) bs++groupN :: Int -> [a] -> [[a]]+groupN _ [] = []+groupN n xs = take n xs : groupN n (drop n xs)++groupNBS :: Int -> BSL.ByteString -> [BSL.ByteString]+groupNBS n_ bs+	| BSL.null bs = []+	| otherwise = BSL.take n bs : groupNBS n_ (BSL.drop n bs)+	where+	n = fromIntegral n_++intsToPNGImageLColor :: (Int, Int, Int) -> PNGImageLColor+intsToPNGImageLColor = convert++toIndexes2 :: BSL.ByteString -> [Int]+toIndexes2 bs = concatMap word2Int2 $ BSL.unpack bs++word2Int2 :: Word8 -> [Int]+word2Int2 w = map fromIntegral [+	w `shiftR` 6, (w .&. 0x30) `shiftR` 4,+	(w .&. 0x0c) `shiftR` 2, w .&. 0x03]++bsToImageA :: Int -> BSL.ByteString -> [[PNGImageLColor]]+bsToImageA w = map (map convert) . bsToImage w++convert (r, g, b) = PNGImageLColor+	(toRGB16 r) (toRGB16 g) (toRGB16 b) (255 `shiftL` 8 .|. 255)++-- toRGB16 :: Word8 -> Int+toRGB16 w = fromIntegral w `shiftL` 8 .|. fromIntegral w++setpre :: Int -> BSL.ByteString -> BSL.ByteString -> BSL.ByteString+setpre w pre rgb+	| fromIntegral (BSL.length pre) == w * 3 + 3 = BSL.drop 3 pre `BSL.append` rgb+	| otherwise = error "bad pre" -- pre `append` rgb++bsToImage w bs = reverse $ map reverse $+	bsToImage' w (BSL.replicate (fromIntegral w * 3 + 3) 0) bs []++bsToImage' :: Int -> BSL.ByteString -> BSL.ByteString -> [[(Word8, Word8, Word8)]] ->+	[[(Word8, Word8, Word8)]]+bsToImage' w pre bs rets+	| BSL.null bs = rets+	| otherwise = let+		Just (filter, dat') = BSL.uncons bs+		(pre', ret, dat'') = bsToLine filter w 0 pre Nothing [] dat' in+		bsToImage' w pre' dat'' (ret : rets)++bsToLine :: Word8 -> Int -> Int -> BSL.ByteString ->+	Maybe (Word8, Word8, Word8) ->+	[(Word8, Word8, Word8)] -> BSL.ByteString ->+	(BSL.ByteString, [(Word8, Word8, Word8)], BSL.ByteString)+bsToLine filter w x pre left ret dat+	| x < w = let+		tToL (r, g, b) = [r, g, b]+		lToT [r, g, b] = (r, g, b)+		l = fromMaybe (0, 0, 0) left+		lu = (\[r, g, b] -> (r, g, b)) $+			maybe [0, 0, 0] (const $ take' 3 pre) left+		color'@[r, g, b] = getColor filter+			(tToL l) (take' 3 $ BSL.drop 3 pre) (tToL lu) (take' 3 dat)+		color = (r, g, b) in+		bsToLine filter w (x + 1) (setpre w pre $ BSL.pack color')+			(Just color) (color : ret) $ BSL.drop 3 dat+	| otherwise = (pre, ret, dat)++zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]+zipWith4 _ [] [] [] [] = []+zipWith4 f (x : xs) (y : ys) (z : zs) (w : ws) = f x y z w : zipWith4 f xs ys zs ws++getColor 0 left up leftup rgb = rgb+getColor 1 left up leftup rgb = zipWith (+) left rgb+getColor 2 left up leftup rgb = zipWith (+) up rgb+getColor 3 left up leftup rgb = zipWith3 (\l u p -> p + (l + u) `div` 2) left up rgb+getColor 4 left up leftup rgb = zipWith4 getByte4'' left up leftup rgb++getByte4'' :: Word8 -> Word8 -> Word8 -> Word8 -> Word8+getByte4'' left up leftup rgb = paeth' left up leftup + rgb++paeth' :: Word8 -> Word8 -> Word8 -> Word8+paeth' a b c = let+	[a', b', c'] = map fromIntegral [a, b, c]+	p :: Int = a' + b' - c'+	pa = abs $ p - a'+	pb = abs $ p - b'+	pc = abs $ p - c' in+	if pa <= pb && pa <= pc then a else+		if pb <= pc then b else c++take' :: Int64 -> BSL.ByteString -> [Word8]+take' n = BSL.unpack . BSL.take n
+ src/Language/Haskell/TH/Tools.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.TH.Tools (+	mapTypesFun,+	wrapTypes,+	makeTypes,+	nameTypes+) where++import Language.Haskell.TH (+	Info(TyConI), reify, Name, mkName, newName, nameBase, stringL,+	DecsQ, DecQ, Dec(FunD, DataD), cxt, sigD, dataD, funD,+	Con(NormalC), normalC, ClauseQ, clause, normalB,+	TypeQ, Type, conT, appT, arrowT, conP, varP, wildP, litP,+	conE, varE, appE, litE, strictType, notStrict)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first, (&&&))+import Control.Monad (replicateM)+import Data.List (isPrefixOf)+import Data.String (fromString)+import Data.Char (toLower, toUpper)++--------------------------------------------------------------------------------++mapTypesFun :: Name -> Name -> (Name -> [Type] -> ClauseQ) -> DecQ+mapTypesFun fname typ f = do+	TyConI (DataD _ _ _ cons _) <- reify typ+	clauses <- (`mapM` cons) $ \(NormalC n a) -> f n $ map snd a+	return $ FunD fname clauses++wrapTypes :: String -> [String] -> (String, [Name]) -> [Name] -> DecsQ+wrapTypes name types other deriv = let upper = map toUpper in fmap (: []) $+	flip (dataD (cxt []) (mkName name) []) deriv $ map+		(normalC <$> fst <*> map (strictType notStrict . conT) . snd) $+			(++ [first mkName other]) $ flip map types $+				mkName . (name ++) &&& (: []) . mkName . upper++makeTypes :: String -> Name -> String -> String -> DecsQ+makeTypes name dat preold prenew = do+	TyConI (DataD _ _ _ cs _) <- reify dat+	let	(datN, funN) = mkName &&& mkName . headToLower $ name+		((ns, tns), as) = first (id &&& map chpre) $ unzip $+			map (\(NormalC n a) -> (n, map return $ init a)) cs+		mkClause n a tn = do+			t <- replicateM (length a) (newName "typ")+			flip (clause [conP n (map varP t ++ [wildP])]) [] $+				normalB $ foldl (\c -> appE c . varE) (conE tn) t+	dd <- dataD (cxt []) datN [] (zipWith normalC tns as) [''Eq, ''Show]+	sd <- sigD funN $ conT dat --> conT datN+	fd <- funD funN $ zipWith3 mkClause ns as tns+	return [dd, sd, fd]+	where chpre = mkName . (prenew ++) . removePrefix preold . nameBase++removePrefix :: String -> String -> String+removePrefix pre str+	| pre `isPrefixOf` str = drop (length pre) str+	| otherwise = str++nameTypes :: Name -> String -> Name -> Name -> DecsQ+nameTypes typ pre o st = do+	TyConI (DataD _ _ _ cons _) <- reify typ+	let	types = filter (/= o) $ map (\(NormalC n _) -> n) cons+		cs = map (removePrefix pre . nameBase) types+	(++) <$> nameToType typ cs types o <*> typeToName typ types cs o st++nameToType :: Name -> [String] -> [Name] -> Name -> DecsQ+nameToType typ strs types o = do+	str <- newName "str"+	let	pats = map ((: []) . litP . stringL) strs ++ [[varP str]]+		bodys = map normalB $ map conE types +++			[conE o `appE` (varE 'fromString `appE` varE str)]+	(\sd fd -> [sd, fd])+		<$> sigD fname (conT ''String --> conT typ)+		<*> funD fname (zipWith3 clause pats bodys $ repeat [])+	where fname = mkName $ ("nameTo" ++) $ nameBase typ++typeToName :: Name -> [Name] -> [String] -> Name -> Name -> DecsQ+typeToName typ ts ss o st = do+	str <- newName "str"+	let	pats = map ((: []) . ($ []) . conP) ts ++ [[conP o [varP str]]]+		bodys = map normalB $ map (litE . stringL) ss ++ [varE str]+	(\sd fd -> [sd, fd])+		<$> sigD fname (conT typ --> conT st)+		<*> funD fname (zipWith3 clause pats bodys $ repeat [])+	where fname = mkName $ (++ "ToName") $ headToLower $ nameBase typ++(-->) :: TypeQ -> TypeQ -> TypeQ+t1 --> t2 = arrowT `appT` t1 `appT` t2++headToLower :: String -> String+headToLower "" = ""+headToLower (c : cs) = toLower c : cs