packages feed

binary-file 0.12.6 → 0.12.8

raw patch · 6 files changed

+351/−438 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.12.6+version:	0.12.8 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -70,21 +70,28 @@     > ((), Just numberOfColors)<[(Int, Int, Int)]>: colors     > imageSize<BS.ByteString>: image     >-    > 10<String>: authorFirst-    > 10<String>: authorSecond+    > ((), Just 10)<String>: authorFirst+    > ((), Just 10)<String>: authorSecond     >      > |]     . +extra-source-files:	examples/readPNG.hs+ source-repository	head     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git +source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/binary-file.git+    tag:	0.12.7+ library     hs-source-dirs:	src     exposed-modules:	File.Binary,         File.Binary.Data.LittleEndian,         File.Binary.Data.BigEndian-    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Here, Classes+    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Classes     build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring     ghc-options:	-Wall
+ examples/readPNG.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances #-}++import File.Binary+import File.Binary.Data.BigEndian+import System.Environment+import Data.Word+import qualified Data.ByteString as BS++main = do+	[fin, fout] <- getArgs+	cnt <- readBinaryFile fin+	let (png, rest) = readPNG () cnt+	print $ png+	writeBinaryFile fout $ writePNG () png++test = readPNG () `fmap` readBinaryFile "tmp/out.png"++instance RetType Word32 where+	type Argument Word32 = Int+	fromType n = rev . fi n . fromIntegral+	toType n s = (fromIntegral $ ti $ rev $ tk n s, dp n s)++instance RetType Chank where+	type Argument Chank = ()+	fromType = writeChank+	toType = readChank++instance RetType (Int, Int, Int) where+	type Argument (Int, Int, Int) = ()+	fromType _ (b, g, r) = cc [fromType 1 b, fromType 1 g, fromType 1 r]+	toType _ s = let+		(b, rest) = toType 1 s+		(g, rest') = toType 1 rest+		(r, rest'') = toType 1 rest' in+		((b, g, r), rest'')++[binary|++PNG++1: 0x89+3: "PNG"+2: "\r\n"+1: "\SUB"+1: "\n"+((), Nothing)<[Chank]>: chanks++|]++data ChankBody+	= ChankIHDR IHDR+	| ChankGAMA GAMA+	| ChankSRGB SRGB+	| ChankCHRM CHRM+	| ChankPLTE PLTE+	| ChankBKGD BKGD+	| ChankIDAT IDAT+	| ChankTEXT TEXT+	| ChankIEND IEND+	| Others String+	deriving Show++instance RetType ChankBody where+	type Argument ChankBody = (Int, String)+	fromType _ (ChankIHDR ihdr) = writeIHDR () ihdr+	fromType _ (ChankGAMA gama) = writeGAMA () gama+	fromType _ (ChankSRGB srgb) = writeSRGB () srgb+	fromType _ (ChankCHRM chrm) = writeCHRM () chrm+	fromType (n, _) (ChankPLTE plte) = writePLTE n plte+	fromType _ (ChankBKGD bkgd) = writeBKGD () bkgd+	fromType (n, _) (ChankIDAT idat) = writeIDAT n idat+	fromType (n, _) (ChankTEXT text) = writeTEXT n text+	fromType _ (ChankIEND iend) = writeIEND () iend+	fromType (n, _) (Others str) = fromType ((), Just n) str+	toType (_, "IHDR") str = let (ihdr, rest) = readIHDR () str in+		(ChankIHDR ihdr, rest)+	toType (_, "gAMA") str = let (gama, rest) = readGAMA () str in+		(ChankGAMA gama, rest)+	toType (_, "sRGB") str = let (srgb, rest) = readSRGB () str in+		(ChankSRGB srgb, rest)+	toType (_, "cHRM") str = let (chrm, rest) = readCHRM () str in+		(ChankCHRM chrm, rest)+	toType (n, "PLTE") str = let (plte, rest) = readPLTE n str in+		(ChankPLTE plte, rest)+	toType (_, "bKGD") str = let (bkgd, rest) = readBKGD () str in+		(ChankBKGD bkgd, rest)+	toType (n, "IDAT") str = let (idat, rest) = readIDAT n str in+		(ChankIDAT idat, rest)+	toType (n, "tEXt") str = let (text, rest) = readTEXT n str in+		(ChankTEXT text, rest)+	toType (_, "IEND") str = let (iend, rest) = readIEND () str in+		(ChankIEND iend, rest)+	toType (n, _) str = let (others, rest) = toType ((), Just n) str in+		(Others others, rest)++[binary|++Chank++4: chankSize+((), Just 4)<String>: chankName+(chankSize, chankName)<ChankBody>: chankData+-- ((), Just chankSize)<String>: chankData+4<Word32>:chankCRC++|]++[binary|++IHDR++4: width+4: height+1: depth+1: colorType+1: compressionType+1: filterType+1: interlaceType++|]++[binary|++GAMA++4: gamma++|]++[binary|++SRGB++1: srgb++|]++[binary|++CHRM++4: chrm1+4: chrm2+4: chrm3+4: chrm4+4: chrm5+4: chrm6+4: chrm7+4: chrm8++|]++[binary|++PLTE++<Int>++((), Just (arg `div` 3))<[(Int, Int, Int)]>: colors++|]++[binary|++BKGD++1: bkgd++|]++[binary|++IDAT++<Int>++arg<BS.ByteString>: idat++|]++[binary|++TEXT++<Int>++((), Just arg)<String>: text++|]++[binary|++IEND++|]
src/Classes.hs view
@@ -8,17 +8,21 @@ module Classes ( 	RetType(..), 	Str(..),-	retTypeInt, 	fii, fiiBE, 	tii, tiiBE,-	Endian(..)+	readInt ) where  import qualified Data.ByteString as BS-import ParseBinaryStructure import Data.Char-import Language.Haskell.TH +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 RetType r where 	type Argument r 	fromType :: Str s => Argument r -> r -> s@@ -30,32 +34,6 @@ 	toType (a, Just b) s = (b `times` toType a) s 	toType (a, Nothing) s = whole (toType a) s -retTypeInt :: Endian -> DecsQ-retTypeInt endian = fmap (:[]) $-	instanceD (cxt []) (appT (conT ''RetType) (conT ''Int)) [argt, dfii, dtii]-	where-	argt = tySynInstD ''Argument [conT ''Int] $ conT ''Int-	dfii = valD (varP 'fromType) (normalB $ fiiend) []-	dtii = valD (varP 'toType) (normalB $ tiiend) []-	sffx = case endian of-		LittleEndian -> ""-		BigEndian -> "BE"-	fiiend = varE $ mkName $ "fii" ++ sffx-	tiiend = varE $ mkName $ "tii" ++ sffx--{--instance RetType Int where-	fromType = fii-	toType = tii--}--{--instance RetType String where-	type Argument String = Int-	fromType _ = fs-	toType _ str = (ts str, undefined)--}- instance RetType Char where 	type Argument Char = () 	fromType _ = fs . (: [])@@ -65,7 +43,6 @@ 	type Argument BS.ByteString = Int 	fromType _ = fbs 	toType n str = (tbs $ tk n str, dp n str)---	toType n str = (tbs $ tk n str, fs $ show (len str) ++ show n ++ "hoge hoge hage hage ") -- dp n str)  class Str a where 	tk :: Int -> a -> a
− src/Here.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}--module Here (printf, here) where--import Language.Haskell.TH-import Language.Haskell.TH.Quote--printf :: QuasiQuoter-printf = QuasiQuoter {-	quoteExp = buildFun . parsePrintf,-	quotePat = undefined,-	quoteType = undefined,-	quoteDec = undefined- }--data Printf-	= Lit Char-	| String-	| Dec-	| Float-	| Show-	| Char-	deriving (Show, Eq)--parsePrintf :: String -> [Printf]-parsePrintf (c : _) = [Lit c]--buildFun :: [Printf] -> ExpQ-buildFun [Lit c] = [| putChar c |]--here :: QuasiQuoter-here = QuasiQuoter {-	quoteExp = litE . stringL . tail,-	quotePat = undefined,-	quoteType = undefined,-	quoteDec = undefined- }
src/ParseBinaryStructure.hs view
@@ -1,181 +1,68 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts, FlexibleInstances #-} +{-# OPTIONS_GHC+	-fno-warn-unused-do-bind+	-fno-warn-unused-matches+	-fno-warn-name-shadowing+	-fno-warn-orphans #-}+ module ParseBinaryStructure (-	Endian(..),-	BinaryStructure(..),+	parseBinaryStructure,++	BinaryStructure,+	binaryStructureName,+	binaryStructureArgType,+	binaryStructureBody,+ 	BinaryStructureItem,-	Expression(..),-	Type(..), 	bytesOf, 	typeOf,-	sizeOf, 	valueOf,-	parseBinaryStructure,-	readInt,-	isRepeat,-	getRepeat++	Expression,+	Str(..),+	RetType(..),+	fii, fiiBE,+	tii, tiiBE ) where  import Text.Peggy-import Here-import Control.Arrow-import Data.Char-import Language.Haskell.TH hiding (Type)-import Numeric hiding (readInt)--main :: IO ()-main = do-	putStrLn "ParseBinaryStructure"-	print $ parseBinaryStructure [here|--BitmapFileHeader--set big_endian--2: 19778-4: fileSize-2: 0-2: 0-4: offset--4: 40-4: bitmapWidth-4: bitmapHeight-2: 1-2: bitPerPic-4: compress-4: imageDataSize-4: horizontalDensity-4: verticalDensity-4: colorIndexNumber-4: neededIndexNumber--(4, colorIndexNumber)<[Int]>: colors-4<(Int,Int,Int)>[colorIndexNumber]: colors--- 1[3]: image-imageSize<ByteString>: image-10<String>: author-10<ByteString>: hoge-10<Some>: some-10: "abc\n\r\SUB"-10: 0x89--repeat {--Chank--4: chankSize-4<String>: chankData-chankSize<String>: chankData-4<Word32>:chankCRC--}--|]--data Expression-	= Multiple Expression Expression-	| Division Expression Expression-	| Addition Expression Expression-	| Variable String-	| Number Int-	| ExpressionQ {expressionQ :: Name -> ExpQ}--instance Show Expression where-	show _ = "Expression"--sumExp :: [Expression] -> Expression-sumExp [] = Number 0-sumExp (e1 : e2) = Addition e1 $ sumExp e2--data ConstantValue-	= ConstantInt Int-	| ConstantString String-	deriving Show--constantInt endian (ConstantInt v) = v-constantInt endian (ConstantString v) = fromIntegral $ readInt endian v--data Type---	= Tuple [Type]-	= Type { typeQ :: TypeQ } -- String--instance Show Type where-	show _ = "Type"--data VariableValue-	= VariableValue { variableValue :: String }-	deriving Show--data BinaryStructureItem-	= BinaryStructureItem {-		binaryStructureItemBytes :: Expression,-		binaryStructureItemType :: Type,-		binaryStructureItemListSize :: Maybe Expression, -- (Either Int String),-		binaryStructureItemValue :: Either ConstantValue VariableValue -- Int String-	 }-	| Repeat { getRepeat :: BinaryStructure }-	deriving Show--isRepeat (Repeat _) = True-isRepeat _ = False--bytesOf :: BinaryStructureItem -> Expression-bytesOf (Repeat BinaryStructure{binaryStructureBody = body}) =-	sumExp $ map bytesOf body-bytesOf BinaryStructureItem { binaryStructureItemBytes = b } = b--typeOf :: BinaryStructureItem -> Type-typeOf (Repeat BinaryStructure{binaryStructureName = name}) =-	Type $ appT listT $ conT $ mkName name-typeOf BinaryStructureItem{binaryStructureItemType = t} = t--sizeOf :: BinaryStructureItem -> Maybe Expression-sizeOf (Repeat BinaryStructure{}) = Nothing-sizeOf BinaryStructureItem{binaryStructureItemListSize = s} = s--valueOf :: Endian -> BinaryStructureItem -> Either Int String-valueOf endian BinaryStructureItem { binaryStructureItemValue = v } =-	(constantInt endian +++ variableValue) v-valueOf endian (Repeat BinaryStructure{binaryStructureName = name}) =-	Right $ "repeat" ++ name+import Language.Haskell.TH+import Numeric -binaryStructureItem :: Expression -> Type -> Maybe Expression ->-	Either ConstantValue VariableValue -> BinaryStructureItem-binaryStructureItem = BinaryStructureItem+import Classes -data Endian = BigEndian | LittleEndian deriving Show+parseBinaryStructure :: String -> BinaryStructure+parseBinaryStructure src = case parseString top "<code>" src of+	Right bs -> bs+	Left ps -> error $ show ps  data BinaryStructure = BinaryStructure { 	binaryStructureName :: String,-	binaryStructureEndian :: Endian,+	binaryStructureArgType :: TypeQ, 	binaryStructureBody :: [BinaryStructureItem]- } deriving Show+ } -parseBinaryStructure :: String -> BinaryStructure-parseBinaryStructure src = case parseString top "<code>" src of-	Right bs -> bs-	Left ps -> error $ show ps+data BinaryStructureItem = BinaryStructureItem {+	bytesOf :: Expression,+	typeOf :: TypeQ,+	valueOf :: Either (Either Int String) String+ } -readInt :: Endian -> String -> Integer-readInt LittleEndian "" = 0-readInt LittleEndian (c : cs) = fromIntegral (ord c) + 2 ^ 8 * readInt LittleEndian cs-readInt BigEndian str = readInt LittleEndian $ reverse str+type Expression	= Name -> Name -> ExpQ -tupT :: [TypeQ] -> TypeQ-tupT ts = foldl appT (tupleT $ length ts) ts+applyOp :: Name -> Expression -> Expression -> Expression+applyOp op e1 e2 ret arg = infixApp (e1 ret arg) (varE op) (e2 ret arg)  [peggy|  top :: BinaryStructure-	= emptyLines name emptyLines endian emptyLines dat*-				{ BinaryStructure $2 $4 $6 }-	/ emptyLines name emptyLines dat*-				{ BinaryStructure $2 LittleEndian $4 }+	= emptyLines name emptyLines argType dat*+				{ BinaryStructure $2 $4 $5 } -endian :: Endian-	= "set" spaces "big_endian"-				{ BigEndian }+argType :: TypeQ+	= typ [\n]+		{ $1 }+	/ ""			{ conT $ mkName "()" }  emptyLines :: () 	= "--" [^\n]* [\n]	{ () }@@ -190,18 +77,16 @@  dat :: BinaryStructureItem 	= expr typ size? ':' spaces val emptyLines-				{ binaryStructureItem $1 $2 $3 $5 }-	/ "repeat" spaces "{" top "}"-				{ Repeat $2 }-typ :: Type+				{ BinaryStructureItem $1 $2 $5 }++typ :: TypeQ 	= [<] typeGen [>]	{ $2 }-	/ ""			{ Type $ conT $ mkName "Int" }+	/ ""			{ conT $ mkName "Int" } -typeGen :: Type-	= [(] tupleGen_ [)]	{ Type $ tupT $2 }-	/ [\[] typeGen [\]]	{ Type $ appT listT $ typeQ $2 }---	= [(] tupleGen [)]	{ Tuple $2 }-	/ [A-Z][.a-zA-Z0-9]*	{ Type $ conT $ mkName $ $1 : $2 }+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 }@@ -212,40 +97,32 @@ 	/ typeGen_ spaces "," spaces typeGen_ 				{ [$1, $4] } -tupleGen :: [Type]-	= typeGen spaces "," spaces tupleGen-				{ $1 : $4 }-	/ typeGen spaces "," spaces typeGen-				{ [$1, $4] }----	= [\(] [\)]		{ ExpressionQ $ const $ conE $ mkName "()" } expr :: Expression-	= expr '*' expr		{ Multiple $1 $2 }-	/ expr '/' expr		{ Division $1 $2 }-	/ expr '+' expr		{ Addition $1 $2 }-	/ num			{ ExpressionQ $ const $ litE $ integerL $ fromIntegral $1 }-	/ var			{ ExpressionQ $ appE (varE $ mkName $1) . varE }-	/ [(] tupleExpr [)]	{ ExpressionQ $2 }-	/ 'Just' spaces expr	{ ExpressionQ $ \ret -> appE (conE $ mkName "Just") $-					expressionQ $2 ret }-	/ 'Nothing'		{ ExpressionQ $ const $ conE $ mkName "Nothing" }----	/ [(] expr ', ' expr [)]---				{ ExpressionQ $ \ret -> tupE---					[expressionQ $2 ret, expressionQ $3 ret] }+	= 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			{ const $ const $ litE $ integerL $ fromIntegral $1 }+	/ var			{ if $1 == "arg"+					then const varE+					else const . appE (varE $ mkName $1) . varE }+	/ [(] tupleExpr [)]	{ $2 }+	/ 'Just' spaces expr	{ \ret arg -> appE (conE $ mkName "Just") $+					$2 ret arg }+	/ 'Nothing'		{ const $ const $ conE $ mkName "Nothing" } -tupleExpr :: Name -> ExpQ-	= expr ', ' expr	{ \ret -> tupE-					[expressionQ $1 ret, expressionQ $2 ret] }-	/ ""			{ const $ conE $ mkName "()" }+tupleExpr :: Expression+	= expr ', ' expr	{ \ret arg -> tupE+					[$1 ret arg, $2 ret arg] }+	/ expr+	/ ""			{ const $ const $ conE $ mkName "()" }  size :: Expression 	= '[' expr ']' -val :: Either ConstantValue VariableValue-	= num			{ Left $ ConstantInt $1 }-	/ var			{ Right $ VariableValue $1 }-	/ stringLit		{ Left $ ConstantString $1 }+val :: Either (Either Int String) String+	= num			{ Left $ Left $1 }+	/ var			{ Right $ $1 }+	/ stringLit		{ Left $ Right $1 }  stringLit :: String 	= '\"' strL '\"'
src/QuoteBinaryStructure.hs view
@@ -20,20 +20,10 @@ import Language.Haskell.TH.Quote import Data.Traversable hiding (mapM) import Data.Either-import Control.Applicative-import Control.Arrow import Data.Maybe-import Data.Char-import Data.Bits  import ParseBinaryStructure-import Classes -import qualified Data.ByteString as BS--main = do-	runQ (mkHaskellTree $ parseBinaryStructure "BinaryFileHeader") >>= print- binary :: QuasiQuoter binary = QuasiQuoter { 	quoteExp = undefined,@@ -43,91 +33,50 @@  }  mkHaskellTree :: BinaryStructure -> DecsQ-mkHaskellTree BinaryStructure{-	binaryStructureName = bsn,-	binaryStructureEndian = endian,-	binaryStructureBody = body } = do-		d <- mkData endian bsn body-		r <- mkReader endian bsn body-		w <- mkWriter endian bsn body-		i <- retTypeInt endian+mkHaskellTree bs = do+		d <- mkData bsn body+		r <- mkReader bsn body+		w <- mkWriter bsn body 		return $ d ++ [r, w]+	where+	bsn = binaryStructureName bs+	body = binaryStructureBody bs -mkWriter :: Endian -> String -> [BinaryStructureItem] -> DecQ-mkWriter endian bsn body = do+mkWriter :: String -> [BinaryStructureItem] -> DecQ+mkWriter bsn body = do+	arg <- newName "arg" 	bs <- newName "bs" 	let run = appE (varE 'cc) $ listE $ map-		(\bsi -> writeField endian bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi)-			(valueOf endian bsi))-		body+		(\bsi -> writeField bs arg (bytesOf bsi) (valueOf bsi)) body 	funD (mkName $ "write" ++ bsn)-		[clause [varP bs] (normalB run) []]+		[clause [varP arg, varP bs] (normalB run) []] -writeField :: Endian -> Name -> Expression -> Type -> Maybe Expression ->-	Either Int String -> ExpQ-writeField endian bs size (Type _) Nothing (Left n) =-	appsE [fiend, expression bs size, litE $ integerL $ fromIntegral n]+writeField :: Name -> Name -> Expression -> Either (Either Int String) String -> ExpQ+writeField bs arg size (Left (Left n)) =+	appsE [fiend', expression bs arg size, sigE (litE $ integerL $ fromIntegral n)+		(conT ''Int)] 	where-	fiend = case endian of-		LittleEndian -> varE 'fii-		BigEndian -> varE 'fiiBE-writeField endian bs bytes typ size (Right v) =-	fieldValueToStr endian bs bytes (isJust size) typ $ getField bs v--fiend :: Endian -> ExpQ-fiend endian = case endian of-	LittleEndian -> varE 'fii-	BigEndian -> varE 'fiiBE+	fiend' = varE 'fromType+writeField _ _ _ (Left (Right s)) =+	appsE [varE 'fs, litE $ stringL s]+writeField bs arg bytes (Right v) =+	fieldValueToStr bs arg bytes False $ getField bs v -fieldValueToStr :: Endian -> Name -> Expression -> Bool -> Type -> ExpQ -> ExpQ-fieldValueToStr endian bs size False (Type typ) =-	appE $ appE (varE 'fromType) (expression bs size)-fieldValueToStr endian bs size True typ = \val -> do-	runIO $ do-		putStrLn "there"+fieldValueToStr :: Name -> Name -> Expression -> Bool -> ExpQ -> ExpQ+fieldValueToStr bs arg size False =+	appE $ appE (varE 'fromType) (expression bs arg size)+fieldValueToStr bs arg size True = \val -> 	appE (varE 'cc) $ appsE [-		varE 'map, appE (varE 'fromType) (expression bs size), val]-	where-	addZero = appE $ correctSize' $ expression bs size-	-fieldValueToStr endian bs size bool typ = error $ show (endian, bs, size, bool, typ)--addZeros :: Int -> ExpQ-addZeros ln = do-	lst <- newName "lst"-	let bdy = infixApp (varE lst) (varE '(++)) $-		appsE [varE 'replicate, litE $ integerL $ fromIntegral ln, varE 'zero]-	lam1E (varP lst) bdy--correctSize' :: ExpQ -> ExpQ-correctSize' size = do-	lst <- newName "lst"-	let bdy = infixApp (varE lst) (varE '(++)) $-		appsE [varE 'replicate,-			infixApp size (varE '(-)) $ appE (varE 'length) $ varE lst,-			varE 'zero]-	lam1E (varP lst) bdy--correctSize :: ExpQ -> ExpQ -> ExpQ-correctSize size list = infixApp list (varE '(++)) $-	appsE [varE 'replicate,-		infixApp size (varE '(-)) $ appE (varE 'length) list,-		varE 'zero]--newNameList :: Int -> Q [Name]-newNameList 0 = return []-newNameList n = liftA2 (:) (newName "x") $ newNameList (n - 1)--mapTuple :: (Type -> ExpQ) -> [Type] -> ExpQ-mapTuple f ts = varE 'show+		varE 'map, appE (varE 'fromType) (expression bs arg size), val] -mkReader :: Endian -> String -> [BinaryStructureItem] -> DecQ-mkReader endian bsn body = do+mkReader :: String -> [BinaryStructureItem] -> DecQ+mkReader bsn body = do+	arg <- newName "arg" 	cs <- newName "cs" 	ret <- newName "ret" 	funD (mkName $ "read" ++ bsn)-		[clause [varP cs] (normalB $ mkLetRec ret $-			mkBody endian bsn body cs) []]+		[clause [varP arg, varP cs] (normalB $ mkLetRec ret $+			mkBody bsn arg body cs) []]  mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ mkLetRec n f = do@@ -135,108 +84,67 @@ 	letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $ 		tupE [varE n, varE rest] -mkBody :: Endian -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ-mkBody endian bsn body cs ret = do+mkBody :: String -> Name -> [BinaryStructureItem] -> Name -> Name -> ExpQ+mkBody bsn arg 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 endian) body-	toPair2 (n, nn) = return $ (mkName n, VarE nn)-	mkValD v = valD (varP v) (normalB $ litE $ integerL 45) []+	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 val <- valueOf endian item = do+	    | Left (Left val) <- valueOf item = do 		cs'' <- newName "cs" 		let t = dropE' n $ varE cs' 		let p = val `equal` appE (varE 'fst)-			(appE tiend $ takeE' n $ varE cs')+			(appE (appE (varE 'toType) arg') $ 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 endian item, Just expr <- sizeOf item = do+	    | Left (Right val) <- valueOf item = do 		cs'' <- newName "cs"-		def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs''])-			(normalB (appsE-				[(varE 'times), expression ret expr,-					appE (varE 'toType) arg, varE cs']))-				[]-		return ([def], cs'')-	    | Right var <- valueOf endian item, Nothing <- sizeOf item,-		Type typ <- typeOf item = do+		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 'toType) arg) $ varE cs') []+			(normalB $ appE (appE (varE 'toType) arg') $ varE cs') [] 		return ([def], cs'')-	    | otherwise = error $ show $ typeOf item+	    | otherwise = error "bad" 	    where-	    n = expression ret $ bytesOf item-	    tiend' = varE 'toType-	    tiend = case endian of-		LittleEndian -> appE (varE 'tii) (litE $ integerL 4)-		BigEndian -> appE (varE 'tiiBE) (litE $ integerL 4)-	    arg = expression ret $ bytesOf item--strToTupple :: Int -> ExpQ-strToTupple n = (toTupple n) `dot` appE (varE 'map) (varE 'ord) `dot`-	appE (varE 'take) (litE $ integerL $ fromIntegral n)--dot :: ExpQ -> ExpQ -> ExpQ-dot f1 f2 = infixApp f1 (varE '(.)) f2--toTupple :: Int -> ExpQ-toTupple n = do-	nl <- newNameList n-	lam1E (listP $ map varP nl) (tupE $ map varE nl)+	    n = expression ret arg $ bytesOf item+	    arg' = expression ret arg $ bytesOf item -expression :: Name -> Expression -> ExpQ-expression ret (Variable v) = appE (varE $ mkName v) (varE ret)-expression _ (Number n) = litE $ integerL $ fromIntegral n-expression ret (Division x y) = divE (expression ret x) (expression ret y)-expression ret (Multiple x y) = multiE' (expression ret x) (expression ret y)-expression ret (Addition x y) = addE' (expression ret x) (expression ret y)-expression ret (ExpressionQ e) = e ret+expression :: Name -> Name -> Expression -> ExpQ+expression ret arg e = e ret arg  getField :: Name -> String -> ExpQ getField bs v = appE (varE $ mkName v) (varE bs) -multiE :: Int -> ExpQ -> ExpQ-multiE x y = infixE (Just $ litE $ integerL $ fromIntegral x) (varE '(*)) (Just y)--multiE' :: ExpQ -> ExpQ -> ExpQ-multiE' x y = infixE (Just x) (varE '(*)) (Just y)--addE' :: ExpQ -> ExpQ -> ExpQ-addE' x y = infixE (Just x) (varE '(+)) (Just y)--divE :: ExpQ -> ExpQ -> ExpQ-divE x y = infixE (Just x) (varE 'div) (Just y)- equal :: Int -> ExpQ -> ExpQ-equal x y = infixE (Just $ litE $ integerL $ fromIntegral x) (varE '(==)) (Just y)+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] -takeE'' :: ExpQ -> ExpQ -> ExpQ-takeE'' n xs = appE (varE 'tbs) $ appsE [varE 'tk, 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 [] f = return ([], 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'')--makeData :: BinaryStructure -> DecsQ-makeData BinaryStructure{-	binaryStructureName = bsn,-	binaryStructureEndian = endian,-	binaryStructureBody = body } = mkData endian bsn body+	return (ys ++ zs, s'')  mkInstance :: String -> DecQ mkInstance name =@@ -247,42 +155,28 @@ 			(normalB $ varE $ mkName $ "read" ++ name) [] 	 ] -mkData :: Endian -> String -> [BinaryStructureItem] -> DecsQ-mkData endian bsn body = do+mkData :: String -> [BinaryStructureItem] -> DecsQ+mkData bsn body = do 	d <- dataD (cxt []) name [] [con] [''Show]-	mkInstance bsn-	ds <- mapM makeData $ map getRepeat $ filter isRepeat body-	return $ [d] ++ concat ds+	_ <- mkInstance bsn+	return [d] 	where 	name = mkName bsn 	con = recC (mkName bsn) vsts  	vsts = flip map (filter isRight body) $ \item ->-		case (sizeOf item, typeOf item) of-			(sz, tp) -> varStrictType-				(mkName $ fromRight $ valueOf endian item) $-					strictType notStrict $-						mkType (isJust sz) tp+		varStrictType (mkName $ fromRight $ valueOf item) $+			strictType notStrict $ mkType False $ typeOf item 	isRight item-		| Right _ <- valueOf endian item = True+		| Right _ <- valueOf item = True 		| otherwise = False -mkType :: Bool -> Type -> TypeQ+mkType :: Bool -> TypeQ -> TypeQ mkType True t = appT listT $ mkType False t-mkType False (Type typ) = typ--appsT :: [TypeQ] -> TypeQ-appsT [t] = t-appsT (t1 : t2 : ts) = appsT (appT t1 t2 : ts)--mkTupleReader :: [Type] -> ExpQ-mkTupleReader _ = varE 'show+mkType False typ = typ +fromRight :: Either a b -> b fromRight = either (error "not Right") id--devideN :: Int -> [a] -> [[a]]-devideN _ [] = []-devideN n xs = take n xs : devideN n (drop n xs)  times :: Int -> (s -> (ret, s)) -> s -> ([ret], s) times 0 _ s = ([], s)