binary-file 0.13.2 → 0.14.1

raw patch · 14 files changed

+548/−600 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• binary-file.cabal +15/−9
• examples/readPNG.hs +37/−74
• src/Classes.hs +0/−124
• src/File/Binary.hs +3/−3
• src/File/Binary/Classes.hs +15/−0
• src/File/Binary/Data/BigEndian.hs +0/−15
• src/File/Binary/Data/LittleEndian.hs +0/−15
• src/File/Binary/Instances.hs +81/−0
• src/File/Binary/Instances/BigEndian.hs +38/−0
• src/File/Binary/Instances/LittleEndian.hs +26/−0
• src/File/Binary/Parse.hs +143/−0
• src/File/Binary/Quote.hs +190/−0
• src/ParseBinaryStructure.hs +0/−166
• src/QuoteBinaryStructure.hs +0/−194

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.13.2+version:	0.14.1 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -21,7 +21,8 @@     exam.hs:     .     > import File.Binary-    > import File.Binary.Data.LittleEndian+    > import File.Binary.Instances+    > import File.Binary.Instances.LittleEndian     > import System.Environment     > import Data.ByteString.Lazy as BSL     >@@ -63,8 +64,8 @@     > 4: resolutionV     > 4: color_num     > 4: important_color_num-    > ((), Just color_num)<[(Int, Int, Int)]>: colors-    > ((), image_size)<String>: image+    > ((), Just color_num)[OPENBRACKET](Int, Int, Int)[CLOSEBRACKET]: colors+    > ((), image_size)[OPENBRACKET]String[CLOSEBRACKET]: image     >     > |]     .@@ -78,14 +79,19 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git-    tag:	0.13.2+    tag:	0.14.1  library     hs-source-dirs:	src-    exposed-modules:	File.Binary,-        File.Binary.Data.LittleEndian,-        File.Binary.Data.BigEndian-    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Classes+    exposed-modules:+        File.Binary,+        File.Binary.Instances+        File.Binary.Instances.LittleEndian,+        File.Binary.Instances.BigEndian+    other-modules:+        File.Binary.Classes,+        File.Binary.Parse,+        File.Binary.Quote     build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring,         monads-tf     ghc-options:	-Wall

@@ -1,66 +1,31 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  import File.Binary-import File.Binary.Data.BigEndian+import File.Binary.Instances()+import File.Binary.Instances.BigEndian import System.Environment import Data.Word import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSLC import Codec.Compression.Zlib import CRC (crc) import Control.Applicative+import Data.Monoid +main :: IO () main = do 	[fin, fout] <- getArgs---	cnt <- readBinaryFile fin 	cnt <- BS.readFile fin-	let (png, rest) = fromBinary () cnt+	let (png, _) = fromBinary () cnt  	putStrLn $ take 1000 (show png) ++ "..." ---	writeBinaryFile fout $ toBinary () png---	BS.writeFile fout $ writePNG () png--	let	ChankIDAT idt = chankData $ chanks png !! 6-		dat = idat idt-{- ----		dec = decompress dat-		recomp = compressWith defaultCompressParams {-			compressLevel = bestCompression,---			compressLevel = bestSpeed,-			compressWindowBits = WindowBits 15-		 } dec-{--	print $ length dat-	print $ length recomp--}--	let	chank6 = chanks png !! 6-		newDat = chank6 {-			chankSize = fromIntegral $ BSL.length recomp,-			chankData = ChankIDAT $ IDAT recomp,-			chankCRC = crc $ "IDAT" ++ BSL.unpack recomp-		 }-		new = png {-			chanks = take 6 (chanks png) ++ [newDat] ++-				drop 7 (chanks png)-		 }-{--	print new--}--	print $ dat == recomp---- -}----	BS.writeFile fout $ toBinary () new- 	let	dat = makeData png 		decomp = decompress dat 		recomp = compressWith defaultCompressParams { 			compressLevel = bestCompression,---			compressLevel = bestSpeed, 			compressWindowBits = WindowBits 10 		 } decomp 		newData = makeDataChank recomp@@ -68,12 +33,6 @@ 			chanks = headerChanks png ++ newData ++ 				footerChanks png 		 }-{--		newnew = png {-			chanks = head (chanks png) : newData ++-				[last $ chanks png]-		 }--} 	BS.writeFile fout $ toBinary () newnew 	print $ dat == recomp @@ -112,7 +71,7 @@ 2: "\r\n" 1: "\SUB" 1: "\n"-((), Nothing)<[Chank]>: chanks+((), Nothing){[Chank]}: chanks  |] @@ -121,15 +80,15 @@ Chank  4: chankSize-((), Just 4)<String>: chankName-(chankSize, chankName)<ChankBody>: chankData-4<Word32>:chankCRC+((), Just 4){String}: chankName+(chankSize, chankName){ChankBody}: chankData+4{Word32}:chankCRC  |]  instance Field Word32 where 	type FieldArgument Word32 = Int-	toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral+	toBinary n = makeBinary . BSL.pack . intToWords n 	fromBinary n s = (fromIntegral $ toIntgr $ BSL.reverse t, d) 		where 		(t, d) = getBytes n s@@ -146,7 +105,7 @@  mkNum :: [Integer] -> Integer mkNum [] = 0-mkNum (x : xs) = x + 2 ^ 8 * mkNum xs+mkNum (x : xs) = x + 2 ^ (8 :: Integer) * mkNum xs  data ChankBody 	= ChankIHDR IHDR@@ -163,32 +122,32 @@  instance Field ChankBody where 	type FieldArgument ChankBody = (Int, String)-	toBinary _ (ChankIHDR ihdr) = toBinary () ihdr-	toBinary _ (ChankGAMA gama) = toBinary () gama-	toBinary _ (ChankSRGB srgb) = toBinary () srgb+	toBinary _ (ChankIHDR c) = toBinary () c+	toBinary _ (ChankGAMA c) = toBinary () c+	toBinary _ (ChankSRGB c) = toBinary () c 	toBinary (n, _) (ChankCHRM chrm) = toBinary n chrm 	toBinary (n, _) (ChankPLTE plte) = toBinary n plte-	toBinary _ (ChankBKGD bkgd) = toBinary () bkgd-	toBinary (n, _) (ChankIDAT idat) = toBinary n idat-	toBinary (n, _) (ChankTEXT text) = toBinary n text-	toBinary _ (ChankIEND iend) = toBinary () iend+	toBinary _ (ChankBKGD c) = toBinary () c+	toBinary (n, _) (ChankIDAT c) = toBinary n c+	toBinary (n, _) (ChankTEXT c) = toBinary n c+	toBinary _ (ChankIEND c) = toBinary () c 	toBinary (n, _) (Others str) = toBinary ((), Just n) str 	fromBinary (_, "IHDR") str = let (ihdr, rest) = fromBinary () str in 		(ChankIHDR ihdr, rest) 	fromBinary (_, "gAMA") str = let (gama, rest) = fromBinary () str in 		(ChankGAMA gama, rest)-	fromBinary (_, "sRGB") str = let (srgb, rest) = fromBinary () str in-		(ChankSRGB srgb, rest)+	fromBinary (_, "sRGB") str = let (c, rest) = fromBinary () str in+		(ChankSRGB c, rest) 	fromBinary (n, "cHRM") str = let (chrm, rest) = fromBinary n str in 		(ChankCHRM chrm, rest) 	fromBinary (n, "PLTE") str = let (plte, rest) = fromBinary n str in 		(ChankPLTE plte, rest)-	fromBinary (_, "bKGD") str = let (bkgd, rest) = fromBinary () str in-		(ChankBKGD bkgd, rest)-	fromBinary (n, "IDAT") str = let (idat, rest) = fromBinary n str in-		(ChankIDAT idat, rest)-	fromBinary (n, "tEXt") str = let (text, rest) = fromBinary n str in-		(ChankTEXT text, rest)+	fromBinary (_, "bKGD") str = let (c, rest) = fromBinary () str in+		(ChankBKGD c, rest)+	fromBinary (n, "IDAT") str = let (c, rest) = fromBinary n str in+		(ChankIDAT c, rest)+	fromBinary (n, "tEXt") str = let (c, rest) = fromBinary n str in+		(ChankTEXT c, rest) 	fromBinary (_, "IEND") str = let (iend, rest) = fromBinary () str in 		(ChankIEND iend, rest) 	fromBinary (n, _) str = let (others, rest) = fromBinary ((), Just n) str in@@ -230,7 +189,7 @@  arg :: Int -(4, Just (arg `div` 4))<[Int]>: chrms+(4, Just (arg `div` 4)){[Int]}: chrms  |] @@ -240,13 +199,14 @@  arg :: Int -((), Just (arg `div` 3))<[(Int, Int, Int)]>: colors+((), Just (arg `div` 3)){[(Int, Int, Int)]}: colors  |]  instance Field (Int, Int, Int) where 	type FieldArgument (Int, Int, Int) = ()-	toBinary _ (b, g, r) = concatBinary [toBinary 1 b, toBinary 1 g, toBinary 1 r]+	toBinary _ (b, g, r) =+		mconcat [toBinary 1 b, toBinary 1 g, toBinary 1 r] 	fromBinary _ s = let 		(b, rest) = fromBinary 1 s 		(g, rest') = fromBinary 1 rest@@ -267,18 +227,21 @@  arg :: Int -arg<BSL.ByteString>: idat---((), Just arg)<String>: idat+arg{BSL.ByteString}: idat+--((), Just arg){String}: idat  |]  [binary|  TEXT+{-+test {- hoge -}+-}  arg :: Int -((), Just arg)<String>: text+((), Just arg){String}: text  |] 

@@ -1,124 +0,0 @@-{-# LANGUAGE-	TypeSynonymInstances,-	FlexibleInstances,-	TypeFamilies,-	OverloadedStrings #-}--module Classes (-	Field(..),-	Binary(..),-	fii, tii,-	readInt,-	dp, fs, ti, cc,-	lintToBin-) where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSLC-import Data.Char-import Control.Arrow--data Endian = BigEndian | LittleEndian deriving Show--readInt :: Endian -> String -> Integer-readInt LittleEndian "" = 0-readInt LittleEndian (c : cs) = fromIntegral (ord c) + 2 ^ (8 :: Integer) * readInt LittleEndian cs-readInt BigEndian str = readInt LittleEndian $ reverse str--class Field r where-	type FieldArgument r-	fromBinary :: Binary s => FieldArgument r -> s -> (r, s)-	toBinary :: Binary s => FieldArgument r -> r -> s--instance Field r => Field [r] where-	type FieldArgument [r] = (FieldArgument r, Maybe Int)-	fromBinary (a, Just b) s = (b `times` fromBinary a) s-	fromBinary (a, Nothing) s = whole (fromBinary a) s-	toBinary (a, _) rs = cc $ map (toBinary a) rs--instance Field Char where-	type FieldArgument Char = ()-	fromBinary _ str = (head $ BSLC.unpack t, d)-		where-		(t, d) = getBytes 1 str-	toBinary _ = fs . (: [])--instance Field BS.ByteString where-	type FieldArgument BS.ByteString = Int-	fromBinary n str =-		first (BS.concat . BSL.toChunks) $ getBytes n str-	toBinary _ = makeBinary . BSL.fromChunks . (: [])--class Binary a where-	getBytes :: Int -> a -> (BSL.ByteString, a)-	makeBinary :: BSL.ByteString -> a-	concatBinary :: [a] -> a-	emptyBinary :: a -> Bool--empty :: Binary a => a -> Bool-empty = emptyBinary--cc :: Binary a => [a] -> a-cc = concatBinary--ti :: Binary a => a -> Integer-ti = readInt LittleEndian . BSLC.unpack . fst . getBytes 100--fs :: Binary a => String -> a-fs = makeBinary . BSLC.pack--dp :: Binary a => Int -> a -> a-dp n = snd . getBytes n--instance Binary String where-	getBytes n = BSLC.pack . take n &&& drop n-	makeBinary = BSLC.unpack--	concatBinary = concat-	emptyBinary = null--fii :: Binary a => Int -> Int -> a-fii n = makeBinary . BSLC.pack . intToBin LittleEndian n . fromIntegral-tii :: Binary a => Int -> a -> (Int, a)-tii _ str = let-	(t, d) = getBytes 4 str in-	(fromIntegral $ ti t, d)--instance Binary BSL.ByteString where-	getBytes n = BSL.take (fromIntegral n) &&& BSL.drop (fromIntegral n)-	makeBinary = id--	concatBinary = BSL.concat-	emptyBinary = (== 0) . BSL.length--instance Binary BS.ByteString where-	getBytes n = BSL.fromChunks . (: []) . BS.take n &&& BS.drop n-	makeBinary = BS.concat . BSL.toChunks--	concatBinary = BS.concat-	emptyBinary = (== 0) . BS.length--lintToBin :: Int -> Integer -> String-lintToBin = intToBin LittleEndian--intToBin :: Endian -> Int -> Integer -> String-intToBin LittleEndian 0 _ = ""-intToBin LittleEndian n x = chr (fromIntegral $ x `mod` 256) :-	intToBin LittleEndian (fromIntegral n - 1) (x `div` 256)-intToBin BigEndian n x = reverse $ intToBin LittleEndian n x--times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)-times 0 _ s = ([], s)-times n f s = let-	(ret, rest) = f s-	(rets, rest') = times (n - 1) f rest in-	(ret : rets, rest')--whole :: Binary s => (s -> (ret, s)) -> s -> ([ret], s)-whole f s-	| empty s = ([], s)-	| otherwise = let-		(ret, rest) = f s-		(rets, rest') = whole f rest in-		(ret : rets, rest')

@@ -4,12 +4,12 @@ 	binary, 	Field(..), 	Binary(..),-	tii, -- tiiBE,-	fii, -- fiiBE+--	tii, -- tiiBE,+--	fii, -- fiiBE --	times  ) where -import QuoteBinaryStructure+import File.Binary.Quote import System.IO  readBinaryFile :: FilePath -> IO String

@@ -0,0 +1,15 @@+{-# LANGUAGE TypeFamilies #-}++module File.Binary.Classes (Field(..), Binary(..)) where++import Data.Monoid (Monoid)+import Data.ByteString.Lazy (ByteString)++class Field r where+	type FieldArgument r+	fromBinary :: Binary s => FieldArgument r -> s -> (r, s)+	toBinary :: Binary s => FieldArgument r -> r -> s++class (Eq b, Monoid b) => Binary b where+	getBytes :: Int -> b -> (ByteString, b)+	makeBinary :: ByteString -> b

@@ -1,15 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module File.Binary.Data.BigEndian (-	lintToBin-) where--import Classes-import qualified Data.ByteString.Lazy.Char8 as BSLC---- retTypeInt BigEndian--instance Field Int where-	type FieldArgument Int = Int-	fromBinary n s = (fromIntegral $ ti $ BSLC.reverse $ fst $ getBytes n s, dp n s)-	toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral

@@ -1,15 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--module File.Binary.Data.LittleEndian where--import Classes-import qualified Data.ByteString.Lazy.Char8 as BSLC---- retTypeInt LittleEndian--instance Field Int where-	type FieldArgument Int = Int-	fromBinary n s = (fromIntegral $ ti t, d)-		where-		(t, d) = getBytes n s-	toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral

@@ -0,0 +1,81 @@+{-# LANGUAGE+	TypeFamilies,+	TypeSynonymInstances,+	FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module File.Binary.Instances () where++import File.Binary.Classes (Field(..), Binary(..))+import qualified Data.ByteString as BS+	(ByteString, take, drop, concat)+import qualified Data.ByteString.Lazy as BSL+	(ByteString, take, drop, toChunks, fromChunks)+import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, unpack)+import Control.Arrow (first, (&&&))+import Data.Monoid++instance Field BS.ByteString where+	type FieldArgument BS.ByteString = Int+	fromBinary n str =+		first (BS.concat . BSL.toChunks) $ getBytes n str+	toBinary _ = makeBinary . BSL.fromChunks . (: [])++instance Field Char where+	type FieldArgument Char = ()+	fromBinary _ str = (head $ BSLC.unpack t, d)+		where+		(t, d) = getBytes 1 str+	toBinary _ = makeBinary . BSLC.pack . (: [])++instance Field r => Field [r] where+	type FieldArgument [r] = (FieldArgument r, Maybe Int)+	fromBinary (a, Just b) s = (b `times` fromBinary a) s+	fromBinary (a, Nothing) s = whole (fromBinary a) s+	toBinary (a, _) rs = mconcat $ map (toBinary a) rs++times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)+times 0 _ s = ([], s)+times n f s = let+	(ret, rest) = f s+	(rets, rest') = times (n - 1) f rest in+	(ret : rets, rest')++whole :: Binary s => (s -> (ret, s)) -> s -> ([ret], s)+whole f s+	| s == mempty = ([], s)+	| otherwise = let+		(ret, rest) = f s+		(rets, rest') = whole f rest in+		(ret : rets, rest')++--------------------------------------------------------------------------------++instance Binary String where+	getBytes n = BSLC.pack . take n &&& drop n+	makeBinary = BSLC.unpack++{-+	appendBinary = (++)+	emptyBinary = null+-}++instance Binary BSL.ByteString where+	getBytes n = BSL.take (fromIntegral n) &&& BSL.drop (fromIntegral n)+	makeBinary = id++{-+	appendBinary = BSL.append+	concatBinary = BSL.concat+	emptyBinary = (== 0) . BSL.length+-}++instance Binary BS.ByteString where+	getBytes n = BSL.fromChunks . (: []) . BS.take n &&& BS.drop n+	makeBinary = BS.concat . BSL.toChunks++{-+	appendBinary = BS.append+	concatBinary = BS.concat+	emptyBinary = (== 0) . BS.length+-}

@@ -0,0 +1,38 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module File.Binary.Instances.BigEndian (+	intToWords+) where++import File.Binary.Classes+import qualified Data.ByteString.Lazy as BSL+import Data.Word++instance Field Int where+	type FieldArgument Int = Int+	fromBinary n s = (+		wordsToInt $ BSL.unpack $ fst $ getBytes n s,+		snd $ getBytes n s+	 )+--	toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral+	toBinary n = makeBinary . BSL.pack . intToWords n++wordsToInt :: Integral i => [Word8] -> i+wordsToInt = foldl (\i w -> i * 256 + fromIntegral w) 0++intToWords :: Integral i => Int -> i -> [Word8]+intToWords = itw []+	where+	itw result 0 _ = result+	itw result n i =+		itw (fromIntegral (i `mod` 256) : result) (n - 1) (i `div` 256)++instance Field Integer where+	type FieldArgument Integer = Int+	fromBinary n s = (+		wordsToInt $ BSL.unpack $ fst $ getBytes n s,+		snd $ getBytes n s+	 )+--	toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral+	toBinary n = makeBinary . BSL.pack . intToWords n

@@ -0,0 +1,26 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module File.Binary.Instances.LittleEndian where++import File.Binary.Classes+import qualified Data.ByteString.Lazy as BSL+import Data.Word+import Control.Arrow++instance Field Int where+	type FieldArgument Int = Int+	fromBinary n = first (wordsToInt . BSL.unpack) . getBytes n+	toBinary n = makeBinary . BSL.pack . intToWords n++instance Field Integer where+	type FieldArgument Integer = Int+	fromBinary n = first (wordsToInt . BSL.unpack) . getBytes n+	toBinary n = makeBinary . BSL.pack . intToWords n++wordsToInt :: Integral i => [Word8] -> i+wordsToInt = foldr (\w i -> fromIntegral w + 256 * i) 0++intToWords :: Integral i => Int -> i -> [Word8]+intToWords 0 _ = []+intToWords n i = fromIntegral (i `mod` 256) : intToWords (n - 1) (i `div` 256)

@@ -0,0 +1,143 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts, PackageImports #-}++{-# OPTIONS_GHC+	-fno-warn-name-shadowing+	-fno-warn-unused-binds+	-fno-warn-unused-matches+	-fno-warn-unused-do-bind #-}++module File.Binary.Parse (+	parse,+	BinaryStructure, bsName, bsArgName, bsArgType, bsBody,+	BinaryStructureItem, bytesOf, typeOf, valueOf,+	Value(..), variables,+	Expression, expression,+) where++import Prelude hiding (exp)+import Control.Applicative ((<$>), (<*>))+import "monads-tf" Control.Monad.Reader (Reader, runReader, ask)+import Numeric (readHex)++import Text.Peggy (peggy, parseString, space, defaultDelimiter)+import Language.Haskell.TH (+	ExpQ, litE, varE, conE, appE, tupE, integerL, uInfixE, parensE,+	TypeQ, appT, conT, listT, tupleT, Name, mkName)++--------------------------------------------------------------------------------++parse :: String -> BinaryStructure+parse = either (error . show) id . parseString top ""++data BinaryStructure = BinaryStructure {+	bsName :: Name,+	bsArgName :: Name,+	bsArgType :: TypeQ,+	bsBody :: [BinaryStructureItem]+ }++data BinaryStructureItem = BinaryStructureItem {+	bytesOf :: Expression,+	typeOf :: TypeQ,+	valueOf :: Value+ }++type Expression	= Reader (ExpQ, ExpQ, Name) ExpQ++expression :: ExpQ -> ExpQ -> Name -> Expression -> ExpQ+expression ret arg argn e = runReader e (ret, arg, argn)++data Value+	= Constant { constant :: Either Integer String }+	| Variable { variable :: Name }++variables :: [Value] -> [Name]+variables =+	map variable . filter (\v -> case v of Variable _ -> True; _ -> False)++[peggy|++top :: BinaryStructure+	= emp lname arg dat*		{ BinaryStructure $2 (fst $3) (snd $3) $4 }++arg :: (Name, TypeQ)+	= emp var sp '::' sp typ	{ ($2, $5) }+	/ ''				{ (mkName "_", conT $ mkName "()") }++dat :: BinaryStructureItem+	= emp exp sp typS sp ':' sp val	{ BinaryStructureItem $2 $4 $7 }++typS :: TypeQ+	= '{' typ '}'			{ $1 }+	/ ''				{ conT $ mkName "Int" }++val :: Value+	= var				{ Variable $1 }+	/ num				{ Constant $ Left $1 }+	/ string			{ Constant $ Right $1 }++exp :: Expression+	= exp sp op sp expOp1		{ uInfixE <$> $1 <*> $3 <*> $5 }+	/ expOp1++expOp1 :: Expression+	= expOp1 sp exp1		{ appE <$> $1 <*> $3 }+	/ exp1++exp1 :: Expression+	= '(' tupExp ')'+	/ '(' exp ')'			{ parensE <$> $1 }+	/ '()'				{ return $ conE $ mkName "()" }+	/ num				{ return $ litE $ integerL $1 }+	/ lname				{ return $ conE $1 }+	/ var				{ flip fmap ask $ \(ret, arg, argn) ->+						if $1 == argn+							then arg+							else appE (varE $1) ret }+op :: Expression+	= [!\\#$%&*+./<=>?@^|~-:]+	{ return $ varE $ mkName $1 }+	/ '`' var '`'			{ return $ varE $1 }+tupExp :: Expression = exp (sp ',' sp exp)++	{ (.) tupE . (:) <$> $1 <*> mapM (\(_, _, e) -> e) $2 }++typ :: TypeQ+	= typ typ1			{ appT $1 $2 }+	/ typ1++typ1 :: TypeQ+	= '(' tupType ')'		{ foldl appT (tupleT $ length $1) $1 }+	/ '(' typ ')'+	/ '()'				{ conT $ mkName "()" }+	/ '[' typ ']'			{ appT listT $1 }+	/ lname				{ conT $1 }+tupType :: [TypeQ]+	= typ sp (',' sp typ)+	{ $1 : map snd $3 }++lname :: Name+	= (ln '.')* ln			{ mkName $ concatMap (++ ".") $1 ++ $2 }++var :: Name+	= (ln '.')* sn			{ mkName $ concatMap (++ ".") $1 ++ $2 }++num :: Integer+	= '0x' [0-9a-fA-F]+		{ fst $ head $ readHex $1 }+	/ [1-9][0-9]*			{ read $ $1 : $2 }+	/ '0'				{ 0 }++string :: String = '\"' char* '\"'+char :: Char = [^\\\"] / '\\' esc+esc :: Char+	= 'n'						{ '\n' }+	/ 'r'						{ '\r' }+	/ '\\'						{ '\\' }+	/ 'SUB'						{ '\SUB' }++ln :: String = [A-Z][_a-zA-Z0-9]*			{ $1 : $2 }+sn :: String = [a-z][_a-zA-Z0-9]*			{ $1 : $2 }++sp :: () = (comm / [ \t])*				{ () }+emp :: () = (comm / lcomm / [ \n])*			{ () }+lcomm :: Char = '--' [^\n]* [\n]			{ ' ' }+comm :: Char = '{-' (!'{-' !'-}' . / comm)* '-}'	{ ' ' }++|]

@@ -0,0 +1,190 @@+{-# LANGUAGE+	TemplateHaskell,+	TupleSections,+	PatternGuards,+	TypeSynonymInstances,+	FlexibleInstances #-}++module File.Binary.Quote (+	binary,+	Field(..),+	Binary(..),+--	fii, -- fiiBE,+--	tii, -- tiiBE,+	times+) where++import Prelude hiding (sequence)++import Language.Haskell.TH hiding (Type)+import Language.Haskell.TH.Quote+import Data.Traversable hiding (mapM)+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as BSLC++import File.Binary.Parse+import File.Binary.Classes++import Data.Monoid++binary :: QuasiQuoter+binary = QuasiQuoter {+	quoteExp = undefined,+	quotePat = undefined,+	quoteType = undefined,+	quoteDec = mkHaskellTree . parse+ }++mkHaskellTree :: BinaryStructure -> DecsQ+mkHaskellTree bs = do+		d <- mkData bsn body+		i <- mkInst bsn argn typ body+		return $ d ++ [i]+	where+	bsn = bsName bs+	argn = bsArgName bs+	typ = bsArgType bs+	body = bsBody bs++mkInst :: Name -> Name -> TypeQ -> [BinaryStructureItem] -> DecQ+mkInst bsn argn typ body =+	instanceD (cxt []) (appT (conT ''Field) (conT bsn)) [+		tySynInstD ''FieldArgument [conT bsn] typ,+		reading "fromBinary" bsn argn body,+		writing "toBinary" argn body+	 ]++writing :: String -> Name -> [BinaryStructureItem] -> DecQ+writing name argn body = do+	arg <- newName "_arg"+	bs <- newName "_bs"+	let run = appE (varE 'mconcat) $ listE $ map+		(\bsi -> writeField bs arg argn (bytesOf bsi) (valueOf bsi)) body+	funD (mkName name)+		[clause [varP arg, varP bs] (normalB run) []]++writeField :: Name -> Name -> Name -> Expression -> Value -> ExpQ+writeField bs arg argn size (Constant (Left n)) =+	appsE [fiend', expression (varE bs) (varE arg) argn size,+		sigE (litE $ integerL $ fromIntegral n)+		(conT ''Int)]+	where+	fiend' = varE 'toBinary+writeField _ _ _ _ (Constant (Right s)) =+	appsE [varE 'fs, litE $ stringL s]+writeField bs arg argn bytes (Variable v) =+	fieldValueToStr bs arg argn bytes False $ getField bs v++fs :: Binary a => String -> a+fs = makeBinary . BSLC.pack++fieldValueToStr :: Name -> Name -> Name -> Expression -> Bool -> ExpQ -> ExpQ+fieldValueToStr bs arg argn size False =+	appE $ appE (varE 'toBinary) (expression (varE bs) (varE arg) argn size)+fieldValueToStr bs arg argn size True = \val ->+	appE (varE 'mconcat) $ appsE [+		varE 'map, appE (varE 'toBinary) (expression (varE bs) (varE arg) argn size), val]++reading :: String -> Name -> Name -> [BinaryStructureItem] -> DecQ+reading name bsn argn body = do+	arg <- newName "_arg"+	cs <- newName "cs1"+	ret <- newName "ret"+	funD (mkName name) [clause [varP arg, varP cs]+		(normalB $ mkLetRec ret $ mkBody bsn arg argn body cs) []]++mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ+mkLetRec n f = do+	rest <- newName "rest"+	letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $+		tupE [varE n, varE rest]++mkBody :: Name -> Name -> Name -> [BinaryStructureItem] -> Name -> Name -> ExpQ+mkBody bsn arg argn body cs ret = do+	namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp"+	(defs, rest) <- gather cs body $ mkDef namePairs+	letE (map return defs) $ tupE+		[recConE bsn (map toPair2 namePairs), varE rest]+	where+	names = variables $ map valueOf body+	toPair2 (n, nn) = return (n, VarE nn)+	mkDef :: [(Name, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name)+	mkDef np item cs'+	    | Constant (Left val) <- valueOf item = do+		cs'' <- newName "cs"+		let	t = dropE' n $ varE cs'+			p = val `equal` appE (varE 'fst)+				(appE (appE (varE 'fromBinary) arg') $+					takeE' n $ varE cs')+			e = [e| error "bad value" |]+		d <- valD (varP cs'') (normalB $ condE p t e) []+		return ([d], cs'')+	    | Constant (Right val) <- valueOf item = do+		cs'' <- newName "cs"+		let t = dropE' n $ varE cs'+		let p = val `equal'` takeE' n (varE cs')+		let e = [e| error "bad value" |]+		d <- valD (varP cs'') (normalB $ condE p t e) []+		return ([d], cs'')+	    | Variable var <- valueOf item = do+		cs'' <- newName "cs"+		def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs''])+			(normalB $ appE (appE (varE 'fromBinary) arg') $ varE cs') []+		return ([def], cs'')+	    | otherwise = error "bad"+	    where+	    n = expression (varE ret) (varE arg) argn $ bytesOf item+	    arg' = expression (varE ret) (varE arg) argn $ bytesOf item++getField :: Name -> Name -> ExpQ+getField bs v = appE (varE v) (varE bs)++equal :: Integer -> ExpQ -> ExpQ+equal x y = infixE (Just $ sigE (litE $ integerL x) (conT ''Integer))+	(varE '(==)) (Just y)++equal' :: String -> ExpQ -> ExpQ+equal' x y = infixE (Just $ litE $ stringL x) (varE '(==)) (Just y)++takeE' :: ExpQ -> ExpQ -> ExpQ+takeE' n xs = -- appE (varE 'ts) $ appsE [varE 'tk, n, xs]+	appE (varE 'BSLC.unpack) $ appE (varE 'fst) $ appsE [varE 'getBytes, n, xs]++dropE' :: ExpQ -> ExpQ -> ExpQ+dropE' n xs = appsE [varE 'dp, n, xs]++dp :: Binary a => Int -> a -> a+dp n = snd . getBytes n++gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m ([b], s)+gather s [] _ = return ([], s)+gather s (x : xs) f = do+	(ys, s') <- f x s+	(zs, s'') <- gather s' xs f+	return (ys ++ zs, s'')++mkData :: Name -> [BinaryStructureItem] -> DecsQ+mkData bsn body = do+	d <- dataD (cxt []) name [] [con] [''Show]+	return [d]+	where+	name = bsn+	con = recC bsn vsts++	vsts = flip map (filter isRight body) $ \item ->+		varStrictType (variable $ valueOf item) $+			strictType notStrict $ mkType False $ typeOf item+	isRight item+		| Variable _ <- valueOf item = True+		| otherwise = False++mkType :: Bool -> TypeQ -> TypeQ+mkType True t = appT listT $ mkType False t+mkType False typ = typ++times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)+times 0 _ s = ([], s)+times n f s = let+	(ret, rest) = f s+	(rets, rest') = times (n - 1) f rest in+	(ret : rets, rest')

@@ -1,166 +0,0 @@-{-# LANGUAGE-	TemplateHaskell,-	QuasiQuotes,-	FlexibleContexts,-	FlexibleInstances,-	PackageImports #-}--{-# OPTIONS_GHC-	-fno-warn-unused-do-bind-	-fno-warn-unused-matches-	-fno-warn-name-shadowing-	-fno-warn-orphans #-}--module ParseBinaryStructure (-	parseBinaryStructure,--	BinaryStructure,-	binaryStructureName,-	binaryStructureArgName,-	binaryStructureArgType,-	binaryStructureBody,--	BinaryStructureItem,-	bytesOf,-	typeOf,-	valueOf,--	Expression,-	expression,-	Binary(..),-	Field(..),-	fii, tii,-	dp, fs, cc-) where--import Text.Peggy-import Language.Haskell.TH-import Numeric--import Classes--import "monads-tf" Control.Monad.Reader-import Control.Applicative--parseBinaryStructure :: String -> BinaryStructure-parseBinaryStructure src = case parseString top "<code>" src of-	Right bs -> bs-	Left ps -> error $ show ps--data BinaryStructure = BinaryStructure {-	binaryStructureName :: String,-	binaryStructureArgName :: String,-	binaryStructureArgType :: TypeQ,-	binaryStructureBody :: [BinaryStructureItem]- }--data BinaryStructureItem = BinaryStructureItem {-	bytesOf :: Expression,-	typeOf :: TypeQ,-	valueOf :: Either (Either Int String) String- }--type Expression	= Reader (Name, Name, String) ExpQ--expression :: Name -> Name -> String -> Expression -> ExpQ-expression ret arg argn e = runReader e (ret, arg, argn)--applyOp :: Name -> Expression -> Expression -> Expression-applyOp op re1 re2 = flip infixApp (varE op) <$> re1 <*> re2--[peggy|--top :: BinaryStructure-	= emptyLines name emptyLines argType dat*-				{ BinaryStructure $2 (fst $4) (snd $4) $5 }--argType :: (String, TypeQ)-	= spaces var spaces '::' spaces typeGen [\n]+-				{ ($2, $5) }-	/ ""			{ ("_", conT $ mkName "()") }--emptyLines :: ()-	= "--" [^\n]* [\n]	{ () }-	/ [ \n]*		{ () }--spaces :: ()-	= [ ]*			{ () }---name :: String-	= [A-Z][a-zA-Z0-9]*	{ $1 : $2 }--dat :: BinaryStructureItem-	= expr typ size? ':' spaces val emptyLines-				{ BinaryStructureItem $1 $2 $5 }--typ :: TypeQ-	= [<] typeGen [>]	{ $2 }-	/ ""			{ conT $ mkName "Int" }--typeGen :: TypeQ-	= [(] tupleGen_ [)]	{ foldl appT (tupleT $ length $2) $2 }-	/ [\[] typeGen [\]]	{ appT listT $ $2 }-	/ [A-Z][.a-zA-Z0-9]*	{ conT $ mkName $ $1 : $2 }--typeGen_ :: TypeQ-	= [A-Z][.a-zA-Z0-9]*	{ conT $ mkName $ $1 : $2 }--tupleGen_ :: [TypeQ]-	= typeGen_ spaces "," spaces tupleGen_-				{ $1 : $4 }-	/ typeGen_ spaces "," spaces typeGen_-				{ [$1, $4] }--expr :: Expression-	= expr spaces '*' spaces expr		{ applyOp (mkName "*") $1 $4 }-	/ expr spaces '`div`' spaces expr	{ applyOp (mkName "div") $1 $4 }-	/ expr spaces '+' spaces expr		{ applyOp (mkName "+") $1 $4 }-	/ num			{ return $ litE $ integerL $ fromIntegral $1 }-	/ var			{ ask >>= \(ret, arg, argn) -> return $-					if $1 == argn-						then varE arg-						else appE (varE $ mkName $1) $-							varE ret }-	/ [(] tupleExpr [)]	{ $2 }-	/ 'Just' spaces expr	{ appE (conE $ mkName "Just") <$> $2 }-	/ 'Nothing'		{ return $ conE $ mkName "Nothing" }--tupleExpr :: Expression-	= expr ', ' expr	{ (\e1 e2 -> tupE [e1, e2]) <$> $1 <*> $2 }-	/ expr-	/ ""			{ return $ conE $ mkName "()" }--size :: Expression-	= '[' expr ']'--val :: Either (Either Int String) String-	= num			{ Left $ Left $1 }-	/ var			{ Right $ $1 }-	/ stringLit		{ Left $ Right $1 }--stringLit :: String-	= '\"' strL '\"'--strL :: String-	= charLit*--charLit :: Char-	= [^\\\"]-	/ "\\" escLit--escLit :: Char-	= "n"			{ '\n' }-	/ "r"			{ '\r' }-	/ "\\"			{ '\\' }-	/ "SUB"			{ '\SUB' }--var :: String-	= [a-z][_a-zA-Z0-9]*	{ $1 : $2 }--num :: Int-	= '0x' [0-9a-fA-F]+	{ fst $ head $ readHex $1 }-	/ [1-9][0-9]*		{ read $ $1 : $2 }-	/ '0'			{ 0 }--|]

@@ -1,194 +0,0 @@-{-# LANGUAGE-	TemplateHaskell,-	TupleSections,-	PatternGuards,-	TypeSynonymInstances,-	FlexibleInstances #-}--module QuoteBinaryStructure (-	binary,-	Field(..),-	Binary(..),-	fii, -- fiiBE,-	tii, -- tiiBE,-	times-) where--import Prelude hiding (sequence)--import Language.Haskell.TH hiding (Type)-import Language.Haskell.TH.Quote-import Data.Traversable hiding (mapM)-import Data.Either-import Data.Maybe-import qualified Data.ByteString.Lazy.Char8 as BSLC--import ParseBinaryStructure--binary :: QuasiQuoter-binary = QuasiQuoter {-	quoteExp = undefined,-	quotePat = undefined,-	quoteType = undefined,-	quoteDec = mkHaskellTree . parseBinaryStructure- }--mkHaskellTree :: BinaryStructure -> DecsQ-mkHaskellTree bs = do-		d <- mkData bsn body-		i <- mkInst bsn argn typ body-		return $ d ++ [i]-	where-	bsn = binaryStructureName bs-	argn = binaryStructureArgName bs-	typ = binaryStructureArgType bs-	body = binaryStructureBody bs--mkInst :: String -> String -> TypeQ -> [BinaryStructureItem] -> DecQ-mkInst bsn argn typ body =-	instanceD (cxt []) (appT (conT ''Field) (conT $ mkName bsn)) [-		tySynInstD ''FieldArgument [conT $ mkName bsn] typ,-		reading "fromBinary" bsn argn body,-		writing "toBinary" argn body-	 ]--writing :: String -> String -> [BinaryStructureItem] -> DecQ-writing name argn body = do-	arg <- newName "arg"-	bs <- newName "bs"-	let run = appE (varE 'cc) $ listE $ map-		(\bsi -> writeField bs arg argn (bytesOf bsi) (valueOf bsi)) body-	funD (mkName name)-		[clause [varP arg, varP bs] (normalB run) []]--writeField :: Name -> Name -> String -> Expression -> Either (Either Int String) String -> ExpQ-writeField bs arg argn size (Left (Left n)) =-	appsE [fiend', expression bs arg argn size, sigE (litE $ integerL $ fromIntegral n)-		(conT ''Int)]-	where-	fiend' = varE 'toBinary-writeField _ _ _ _ (Left (Right s)) =-	appsE [varE 'fs, litE $ stringL s]-writeField bs arg argn bytes (Right v) =-	fieldValueToStr bs arg argn bytes False $ getField bs v--fieldValueToStr :: Name -> Name -> String -> Expression -> Bool -> ExpQ -> ExpQ-fieldValueToStr bs arg argn size False =-	appE $ appE (varE 'toBinary) (expression bs arg argn size)-fieldValueToStr bs arg argn size True = \val ->-	appE (varE 'cc) $ appsE [-		varE 'map, appE (varE 'toBinary) (expression bs arg argn size), val]--reading :: String -> String -> String -> [BinaryStructureItem] -> DecQ-reading name bsn argn body = do-	arg <- newName "arg"-	cs <- newName "cs"-	ret <- newName "ret"-	funD (mkName name) [clause [varP arg, varP cs]-		(normalB $ mkLetRec ret $ mkBody bsn arg argn body cs) []]--mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ-mkLetRec n f = do-	rest <- newName "rest"-	letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $-		tupE [varE n, varE rest]--mkBody :: String -> Name -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ-mkBody bsn arg argn body cs ret = do-	namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp"-	(defs, rest) <- gather cs body $ mkDef namePairs-	letE (map return defs) $ tupE-		[recConE (mkName bsn) (map toPair2 namePairs), varE rest]-	where-	names = rights $ map valueOf body-	toPair2 (n, nn) = return (mkName n, VarE nn)-	mkDef :: [(String, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name)-	mkDef np item cs'-	    | Left (Left val) <- valueOf item = do-		cs'' <- newName "cs"-		let	t = dropE' n $ varE cs'-			p = val `equal` appE (varE 'fst)-				(appE (appE (varE 'fromBinary) arg') $-					takeE' n $ varE cs')-			e = [e| error "bad value" |]-		d <- valD (varP cs'') (normalB $ condE p t e) []-		return ([d], cs'')-	    | Left (Right val) <- valueOf item = do-		cs'' <- newName "cs"-		let t = dropE' n $ varE cs'-		let p = val `equal'` takeE' n (varE cs')-		let e = [e| error "bad value" |]-		d <- valD (varP cs'') (normalB $ condE p t e) []-		return ([d], cs'')-	    | Right var <- valueOf item = do-		cs'' <- newName "cs"-		def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs''])-			(normalB $ appE (appE (varE 'fromBinary) arg') $ varE cs') []-		return ([def], cs'')-	    | otherwise = error "bad"-	    where-	    n = expression ret arg argn $ bytesOf item-	    arg' = expression ret arg argn $ bytesOf item--getField :: Name -> String -> ExpQ-getField bs v = appE (varE $ mkName v) (varE bs)--equal :: Int -> ExpQ -> ExpQ-equal x y = infixE (Just $ sigE (litE $ integerL $ fromIntegral x) (conT ''Int))-	(varE '(==)) (Just y)--equal' :: String -> ExpQ -> ExpQ-equal' x y = infixE (Just $ litE $ stringL x) (varE '(==)) (Just y)--takeE' :: ExpQ -> ExpQ -> ExpQ-takeE' n xs = -- appE (varE 'ts) $ appsE [varE 'tk, n, xs]-	appE (varE 'BSLC.unpack) $ appE (varE 'fst) $ appsE [varE 'getBytes, n, xs]--dropE' :: ExpQ -> ExpQ -> ExpQ-dropE' n xs = appsE [varE 'dp, n, xs]--gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m ([b], s)-gather s [] _ = return ([], s)-gather s (x : xs) f = do-	(ys, s') <- f x s-	(zs, s'') <- gather s' xs f-	return (ys ++ zs, s'')--mkInstance :: String -> DecQ-mkInstance name =-	instanceD (cxt []) (appT (conT ''Field) (conT $ mkName name)) [-		valD (varP $ 'toBinary)-			(normalB $ varE $ mkName $ "write" ++ name) [],-		valD (varP $ 'fromBinary)-			(normalB $ varE $ mkName $ "read" ++ name) []-	 ]--mkData :: String -> [BinaryStructureItem] -> DecsQ-mkData bsn body = do-	d <- dataD (cxt []) name [] [con] [''Show]-	_ <- mkInstance bsn-	return [d]-	where-	name = mkName bsn-	con = recC (mkName bsn) vsts--	vsts = flip map (filter isRight body) $ \item ->-		varStrictType (mkName $ fromRight $ valueOf item) $-			strictType notStrict $ mkType False $ typeOf item-	isRight item-		| Right _ <- valueOf item = True-		| otherwise = False--mkType :: Bool -> TypeQ -> TypeQ-mkType True t = appT listT $ mkType False t-mkType False typ = typ--fromRight :: Either a b -> b-fromRight = either (error "not Right") id--times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)-times 0 _ s = ([], s)-times n f s = let-	(ret, rest) = f s-	(rets, rest') = times (n - 1) f rest in-	(ret : rets, rest')