binary-file 0.6 → 0.12.6

raw patch · 7 files changed

+454/−221 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• binary-file.cabal +26/−10
• src/Classes.hs +147/−0
• src/File/Binary.hs +6/−1
• src/File/Binary/Data/BigEndian.hs +12/−0
• src/File/Binary/Data/LittleEndian.hs +12/−0
• src/ParseBinaryStructure.hs +135/−45
• src/QuoteBinaryStructure.hs +116/−165

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.6+version:	0.12.6 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -19,24 +19,33 @@     exam.hs:     .     > import File.Binary+    > import File.Binary.Data.LittleEndian     > import System.Environment     > import Data.ByteString as BS     >     > main = do     >	[inf, outf] <- getArgs     >-    >	-- cnt <- readBinaryFile inf     >   cnt <- BS.readFile inf-    >	let bmp = readBitmap cnt-    >	print $ readBitmap cnt+    >	let bmp = readBitmap $ cnt `BS.append` replicate 20 ' '+    >	print bmp     >     >	let out = writeBitmap bmp {     >		authorFirst = "Yoshikuni ",     >		authorSecond = "Jujo      "     >	 }-    >	-- writeBinaryFile outf out     >   BS.writeFile outf out     >+    > 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, zero]+    >    toType _ str = let+    >        (b, rest) = toType 1 str+    >        (g, rest') = toType 1 rest+    >        (r, rest'') = toType 1 rest' in+    >        ((b, g, r), dp 1 rest'')+    >     > [binary|     >     > Bitmap@@ -46,6 +55,7 @@     > 2: 0     > 2: 0     > 4: offset+    >     > 4: 40     > 4: bitmapWidth     > 4: bitmapHeight@@ -57,18 +67,24 @@     > 4: verticalResolution     > 4: numberOfColors     > 4: importantColors-    > 4<(Int, Int, Int)>[numberOfColors]: colors-    > -- bitsPerPixel/8[imageSize*8/bitsPerPixel]: image-    > imageSize<ByteString>: image+    > ((), Just numberOfColors)<[(Int, Int, Int)]>: colors+    > imageSize<BS.ByteString>: image+    >     > 10<String>: authorFirst     > 10<String>: authorSecond     >      > |]     . +source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/binary-file.git+ library     hs-source-dirs:	src-    exposed-modules:	File.Binary-    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Here+    exposed-modules:	File.Binary,+        File.Binary.Data.LittleEndian,+        File.Binary.Data.BigEndian+    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Here, Classes     build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring     ghc-options:	-Wall

@@ -0,0 +1,147 @@+{-# LANGUAGE+	TemplateHaskell,+	TypeSynonymInstances,+	FlexibleInstances,+	TypeFamilies,+	OverloadedStrings #-}++module Classes (+	RetType(..),+	Str(..),+	retTypeInt,+	fii, fiiBE,+	tii, tiiBE,+	Endian(..)+) where++import qualified Data.ByteString as BS+import ParseBinaryStructure+import Data.Char+import Language.Haskell.TH++class RetType r where+	type Argument r+	fromType :: Str s => Argument r -> r -> s+	toType :: Str s => Argument r -> s -> (r, s)++instance RetType r => RetType [r] where+	type Argument [r] = (Argument r, Maybe Int)+	fromType (a, _) rs = cc $ map (fromType a) rs+	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 . (: [])+	toType _ str = (head $ ts str, dp 1 str)++instance RetType BS.ByteString where+	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+	dp :: Int -> a -> a+	ts :: a -> String+	fs :: String -> a+	fbs :: BS.ByteString -> a+	tbs :: a -> BS.ByteString+	ti :: a -> Integer+	fi :: Int -> Integer -> a+	tiBE :: a -> Integer+	fiBE :: Int -> Integer -> a+	cc :: [a] -> a+	zero :: a+	len :: a -> Int+	empty :: a -> Bool+	rev :: a -> a++instance Str String where+	tk = take+	dp = drop+	ts = id+	fs = id+	fbs = ts+	tbs = fs+	ti = readInt LittleEndian+	fi = intToBin LittleEndian+	tiBE = readInt BigEndian+	fiBE = intToBin BigEndian+	cc = concat+	zero = "\0"+	len = length+	empty = null+	rev = reverse++fii, fiiBE :: Str a => Int -> Int -> a+fii n = fi n . fromIntegral+fiiBE n = fiBE n . fromIntegral+tii, tiiBE :: Str a => Int -> a -> (Int, a)+tii _ str = (fromIntegral $ ti $ tk 4 str, dp 4 str)+tiiBE _ str = (fromIntegral $ tiBE $ tk 4 str, dp 4 str)++instance Str BS.ByteString where+	tk = BS.take+	dp = BS.drop+	ts = map (chr . fromIntegral) . BS.unpack+	fs = BS.pack . map (fromIntegral . ord)+	fbs = id+	tbs = id+	ti = readInt LittleEndian . map (chr . fromIntegral) . BS.unpack+	fi n = BS.pack . map (fromIntegral . ord) . intToBin LittleEndian n+	tiBE = readInt BigEndian . map (chr . fromIntegral) . BS.unpack+	fiBE n = BS.pack . map (fromIntegral . ord) . intToBin BigEndian n+	cc = BS.concat+	zero = BS.singleton 0+	len = BS.length+	empty = (== 0) . BS.length+	rev = BS.reverse++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 :: Str 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')

@@ -1,7 +1,12 @@ module File.Binary ( 	readBinaryFile, 	writeBinaryFile,-	binary+	binary,+	RetType(..),+	Str(..),+	tii, tiiBE,+	fii, fiiBE+--	times  ) where  import QuoteBinaryStructure

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}++module File.Binary.Data.BigEndian where++import Classes++-- retTypeInt BigEndian++instance RetType Int where+	type Argument Int = Int+	fromType n = rev . fi n . fromIntegral+	toType n s = (fromIntegral $ ti $ rev $ tk n s, dp n s)

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}++module File.Binary.Data.LittleEndian where++import Classes++-- retTypeInt LittleEndian++instance RetType Int where+	type Argument Int = Int+	fromType n = fi n . fromIntegral+	toType n s = (fromIntegral $ ti $ tk n s, dp n s)

@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}  module ParseBinaryStructure (+	Endian(..), 	BinaryStructure(..), 	BinaryStructureItem, 	Expression(..),@@ -10,13 +11,17 @@ 	sizeOf, 	valueOf, 	parseBinaryStructure,-	readInt+	readInt,+	isRepeat,+	getRepeat ) 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@@ -25,6 +30,8 @@  BitmapFileHeader +set big_endian+ 2: 19778 4: fileSize 2: 0@@ -43,73 +50,105 @@ 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-	deriving Show+	| 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 (ConstantInt v) = v-constantInt (ConstantString v) = readInt v+constantInt endian (ConstantInt v) = v+constantInt endian (ConstantString v) = fromIntegral $ readInt endian v -data Type = String | Int | ByteString | Tuple [Type] deriving (Show, Eq)+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- } 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 = binaryStructureItemBytes+bytesOf (Repeat BinaryStructure{binaryStructureBody = body}) =+	sumExp $ map bytesOf body+bytesOf BinaryStructureItem { binaryStructureItemBytes = b } = b  typeOf :: BinaryStructureItem -> Type-typeOf = binaryStructureItemType+typeOf (Repeat BinaryStructure{binaryStructureName = name}) =+	Type $ appT listT $ conT $ mkName name+typeOf BinaryStructureItem{binaryStructureItemType = t} = t  sizeOf :: BinaryStructureItem -> Maybe Expression-sizeOf = binaryStructureItemListSize+sizeOf (Repeat BinaryStructure{}) = Nothing+sizeOf BinaryStructureItem{binaryStructureItemListSize = s} = s -valueOf :: BinaryStructureItem -> Either Int String-valueOf = (constantInt +++ variableValue) . binaryStructureItemValue+valueOf :: Endian -> BinaryStructureItem -> Either Int String+valueOf endian BinaryStructureItem { binaryStructureItemValue = v } =+	(constantInt endian +++ variableValue) v+valueOf endian (Repeat BinaryStructure{binaryStructureName = name}) =+	Right $ "repeat" ++ name  binaryStructureItem :: Expression -> Type -> Maybe Expression -> 	Either ConstantValue VariableValue -> BinaryStructureItem binaryStructureItem = BinaryStructureItem -{--type BinaryStructureItem = (Int, Either Int String)--bytesOf :: (Int, Either Int String) -> Int-bytesOf = fst--valueOf :: (Int, Either Int String) -> Either Int String-valueOf = snd--binaryStructureItem :: Int -> Either Int String -> BinaryStructureItem-binaryStructureItem = (,)--}+data Endian = BigEndian | LittleEndian deriving Show  data BinaryStructure = BinaryStructure { 	binaryStructureName :: String,+	binaryStructureEndian :: Endian, 	binaryStructureBody :: [BinaryStructureItem]  } deriving Show @@ -118,16 +157,26 @@ 	Right bs -> bs 	Left ps -> error $ show ps -readInt :: String -> Int-readInt "" = 0-readInt (c : cs) = ord c + 2 ^ 8 * readInt cs+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 +tupT :: [TypeQ] -> TypeQ+tupT ts = foldl appT (tupleT $ length ts) ts+ [peggy|  top :: BinaryStructure-	= emptyLines name emptyLines dat*-				{ BinaryStructure $2 $4 }+	= emptyLines name emptyLines endian emptyLines dat*+				{ BinaryStructure $2 $4 $6 }+	/ emptyLines name emptyLines dat*+				{ BinaryStructure $2 LittleEndian $4 } +endian :: Endian+	= "set" spaces "big_endian"+				{ BigEndian }+ emptyLines :: () 	= "--" [^\n]* [\n]	{ () } 	/ [ \n]*		{ () }@@ -142,43 +191,84 @@ dat :: BinaryStructureItem 	= expr typ size? ':' spaces val emptyLines 				{ binaryStructureItem $1 $2 $3 $5 }+	/ "repeat" spaces "{" top "}"+				{ Repeat $2 } typ :: Type 	= [<] typeGen [>]	{ $2 }-	/ ""			{ Int }+	/ ""			{ Type $ conT $ mkName "Int" }  typeGen :: Type-	= [(] tupleGen [)]	{ Tuple $2 }-	/ "String"		{ String }-	/ "ByteString"		{ ByteString }-	/ "Int"			{ Int }+	= [(] 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+	= [A-Z][.a-zA-Z0-9]*	{ conT $ mkName $ $1 : $2 }++tupleGen_ :: [TypeQ]+	= typeGen_ spaces "," spaces tupleGen_+				{ $1 : $4 }+	/ 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 }-	/ num			{ Number $1 }-	/ var			{ Variable $1 }+	/ 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] }++tupleExpr :: Name -> ExpQ+	= expr ', ' expr	{ \ret -> tupE+					[expressionQ $1 ret, expressionQ $2 ret] }+	/ ""			{ const $ conE $ mkName "()" }+ size :: Expression 	= '[' expr ']'  val :: Either ConstantValue VariableValue 	= num			{ Left $ ConstantInt $1 } 	/ var			{ Right $ VariableValue $1 }-	/ stringL		{ Left $ ConstantString $1 }+	/ stringLit		{ Left $ ConstantString $1 } -stringL :: String-	= '\"' [^\"]* '\"'+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 }+	= [a-z][_a-zA-Z0-9]*	{ $1 : $2 }  num :: Int-	= [0-9]+		{ read $1 }+	= '0x' [0-9a-fA-F]+	{ fst $ head $ readHex $1 }+	/ [1-9][0-9]*		{ read $ $1 : $2 }+	/ '0'			{ 0 }  |]

@@ -6,7 +6,12 @@ 	FlexibleInstances #-}  module QuoteBinaryStructure (-	binary+	binary,+	RetType(..),+	Str(..),+	fii, fiiBE,+	tii, tiiBE,+	times ) where  import Prelude hiding (sequence)@@ -22,6 +27,7 @@ import Data.Bits  import ParseBinaryStructure+import Classes  import qualified Data.ByteString as BS @@ -39,64 +45,52 @@ mkHaskellTree :: BinaryStructure -> DecsQ mkHaskellTree BinaryStructure{ 	binaryStructureName = bsn,+	binaryStructureEndian = endian, 	binaryStructureBody = body } = do-		d <- mkData bsn body---		dbg <- debugReadType-		r <- mkReader bsn body-		w <- mkWriter bsn body-		return [d, r, w]+		d <- mkData endian bsn body+		r <- mkReader endian bsn body+		w <- mkWriter endian bsn body+		i <- retTypeInt endian+		return $ d ++ [r, w] -mkWriter :: String -> [BinaryStructureItem] -> DecQ-mkWriter bsn body = do+mkWriter :: Endian -> String -> [BinaryStructureItem] -> DecQ+mkWriter endian bsn body = do 	bs <- newName "bs" 	let run = appE (varE 'cc) $ listE $ map-		(\bsi -> writeField bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi) (valueOf bsi))+		(\bsi -> writeField endian bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi)+			(valueOf endian bsi)) 		body 	funD (mkName $ "write" ++ bsn) 		[clause [varP bs] (normalB run) []] -writeField :: Name -> Expression -> Type -> Maybe Expression ->+writeField :: Endian -> Name -> Expression -> Type -> Maybe Expression -> 	Either Int String -> ExpQ-writeField bs size Int Nothing (Left n) =-	appsE [varE 'fi, expression bs size, litE $ integerL $ fromIntegral n]-writeField bs bytes typ size (Right v) =-	fieldValueToStr bs bytes (isJust size) typ $ getField bs v+writeField endian bs size (Type _) Nothing (Left n) =+	appsE [fiend, expression bs size, litE $ integerL $ fromIntegral n]+	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 -fieldValueToStr :: Name -> Expression -> Bool -> Type -> ExpQ -> ExpQ-fieldValueToStr bs size False Int = appE $ appE (varE 'fi) (expression bs size)-fieldValueToStr bs size True Int = appE (varE 'cc) . appE (appsE [varE 'map,-	appE (varE 'fi) (expression bs size)])-fieldValueToStr bs size False String = appE $ varE 'fs-fieldValueToStr bs size False ByteString = appE $ varE 'fbs-fieldValueToStr bs size False (Tuple ts) = \val -> do-	nl <- newNameList $ length ts-	let	def = valD (tupP $ map varP nl) (normalB val) []-		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl-	 in	letE [def] $ appE (varE 'cc) $ listE bdy-fieldValueToStr bs size True (Tuple ts) = \val -> do+fiend :: Endian -> ExpQ+fiend endian = case endian of+	LittleEndian -> varE 'fii+	BigEndian -> varE 'fiiBE++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 "here"-		print ts-	nl <- newNameList $ length ts-	let	ps = tupP $ map varP nl-		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl-	 in	appE (varE 'cc) $ appsE [-			varE 'map,-			lamE [ps] $ appE (varE 'cc) $ addZero $ listE bdy,-			val]+		putStrLn "there"+	appE (varE 'cc) $ appsE [+		varE 'map, appE (varE 'fromType) (expression bs size), val] 	where-	addZero = -- appE $ addZeros 1-		appE $ correctSize' $ expression bs size-{--	let	ps = tupP $ map varP nl-		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl-	 in	appE (varE 'cc) $ appE (correctSize' $ expression bs size) $ appsE [-			varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val]--}-{--	 in	appE (varE 'cc) $ correctSize (expression bs size) $ appsE [-			varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val]--}+	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@@ -107,7 +101,6 @@  correctSize' :: ExpQ -> ExpQ correctSize' size = do---	let size = litE $ IntegerL 100 	lst <- newName "lst" 	let bdy = infixApp (varE lst) (varE '(++)) $ 		appsE [varE 'replicate,@@ -128,90 +121,62 @@ mapTuple :: (Type -> ExpQ) -> [Type] -> ExpQ mapTuple f ts = varE 'show -intToBin :: Int -> Int -> String-intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x)--intToBinGen :: Integer -> Integer -> String-intToBinGen 0 _ = ""-intToBinGen n x = chr (fromIntegral $ x `mod` 256) :-	intToBinGen (n - 1) (x `div` 256)---- readerType :: String -> DecQ--- readerType = sigD (mkName $ "read" ++ bsn) [t| Str a => a ->---- debugReadType :: DecQ = [d| readBitmap :: Str a => a -> Bitmap |]--mkReader :: String -> [BinaryStructureItem] -> DecQ-mkReader bsn body = do+mkReader :: Endian -> String -> [BinaryStructureItem] -> DecQ+mkReader endian bsn body = do 	cs <- newName "cs" 	ret <- newName "ret" 	funD (mkName $ "read" ++ bsn)-		[clause [varP cs] (normalB $ mkLetRec ret $ mkBody bsn body cs) []]+		[clause [varP cs] (normalB $ mkLetRec ret $+			mkBody endian bsn body cs) []]  mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ-mkLetRec n f = letE [valD (varP n) (normalB $ f n) []] $ varE n+mkLetRec n f = do+	rest <- newName "rest"+	letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $+		tupE [varE n, varE rest] -mkBody :: String -> [BinaryStructureItem] -> Name -> Name -> ExpQ-mkBody bsn body cs ret = do+mkBody :: Endian -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ+mkBody endian bsn body cs ret = do 	namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp"-	defs <- gather cs body $ mkDef namePairs-	letE (map return defs) $ recConE (mkName bsn) (map toPair2 namePairs)+	(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+	names = rights $ map (valueOf endian) body 	toPair2 (n, nn) = return $ (mkName n, VarE nn) 	mkValD v = valD (varP v) (normalB $ litE $ integerL 45) [] 	mkDef :: [(String, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name) 	mkDef np item cs'-	    | Left val <- valueOf item = do+	    | Left val <- valueOf endian item = do 		cs'' <- newName "cs" 		let t = dropE' n $ varE cs'-		let p = val `equal` appE (varE 'ti) (takeE' n $ varE cs')+		let p = val `equal` appE (varE 'fst)+			(appE tiend $ 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, Nothing <- sizeOf item, Int <- typeOf item = do-		cs'' <- newName "cs"-		def <- valD (varP $ fromJust $ lookup var np)-			(normalB $ appE (varE 'ti) $ takeE' n $ varE cs') []-		next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') []-		return ([def, next], cs'')-	    | Right var <- valueOf item, Nothing <- sizeOf item, ByteString <- typeOf item = do-		cs'' <- newName "cs"-		def <- valD (varP $ fromJust $ lookup var np)-			(normalB $ takeE'' n $ varE cs') []-		next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') []-		return ([def, next], cs'')-	    | Right var <- valueOf item, Nothing <- sizeOf item = do+	    | Right var <- valueOf endian item, Just expr <- sizeOf item = do 		cs'' <- newName "cs"-		def <- valD (varP $ fromJust $ lookup var np)-			(normalB $ takeE' n $ varE cs') []-		next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') []-		return ([def, next], cs'')-	    | Right var <- valueOf item, Just expr <- sizeOf item, Tuple ts <- typeOf item =-		if all (== Int) ts then do-			cs'' <- newName "cs"-			def <- valD (varP $ fromJust $ lookup var np)-				(normalB $-					appsE [varE 'map, strToTupple $ length ts,-					appsE [varE 'devideN, n,-				takeE' (multiE' n $ expression ret expr) $ varE cs']]) []-			next <- valD (varP cs'') (normalB $-				dropE' (multiE' n $ expression ret expr) $ varE cs') []-			return ([def, next], cs'')-		    else error "hogeru"-	    | Right var <- valueOf item, Just expr <- sizeOf item = do+		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 		cs'' <- newName "cs"-		def <- valD (varP $ fromJust $ lookup var np)-			(normalB $-				appsE [varE 'map, varE 'ti,-				appsE [varE 'devideN, n,-			takeE' (multiE' n $ expression ret expr) $ varE cs']]) []-		next <- valD (varP cs'') (normalB $-			dropE' (multiE' n $ expression ret expr) $ varE cs') []-		return ([def, next], cs'')+		def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs''])+			(normalB $ appE (appE (varE 'toType) arg) $ varE cs') []+		return ([def], cs'') 	    | otherwise = error $ show $ typeOf item 	    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`@@ -230,6 +195,8 @@ 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  getField :: Name -> String -> ExpQ getField bs v = appE (varE $ mkName v) (varE bs)@@ -240,37 +207,52 @@ 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) --- takeE :: Int -> ExpQ -> ExpQ--- takeE n xs = appsE [varE 'tk, litE $ integerL $ fromIntegral n, xs]- 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 :: Int -> ExpQ -> ExpQ--- dropE n xs = appsE [varE 'dp, litE $ integerL $ fromIntegral 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]-gather s [] f = return []+gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m ([b], s)+gather s [] f = return ([], s) gather s (x : xs) f = do 	(ys, s') <- f x s-	zs <- gather s' xs f-	return $ ys ++ zs+	(zs, s'') <- gather s' xs f+	return $ (ys ++ zs, s'') -mkData :: String -> [BinaryStructureItem] -> DecQ-mkData bsn body =-	dataD (cxt []) name [] [con] [''Show]+makeData :: BinaryStructure -> DecsQ+makeData BinaryStructure{+	binaryStructureName = bsn,+	binaryStructureEndian = endian,+	binaryStructureBody = body } = mkData endian bsn body++mkInstance :: String -> DecQ+mkInstance name =+	instanceD (cxt []) (appT (conT ''RetType) (conT $ mkName name)) [+		valD (varP $ 'fromType)+			(normalB $ varE $ mkName $ "write" ++ name) [],+		valD (varP $ 'toType)+			(normalB $ varE $ mkName $ "read" ++ name) []+	 ]++mkData :: Endian -> String -> [BinaryStructureItem] -> DecsQ+mkData endian bsn body = do+	d <- dataD (cxt []) name [] [con] [''Show]+	mkInstance bsn+	ds <- mapM makeData $ map getRepeat $ filter isRepeat body+	return $ [d] ++ concat ds 	where 	name = mkName bsn 	con = recC (mkName bsn) vsts@@ -278,18 +260,16 @@ 	vsts = flip map (filter isRight body) $ \item -> 		case (sizeOf item, typeOf item) of 			(sz, tp) -> varStrictType-				(mkName $ fromRight $ valueOf item) $-					strictType notStrict $ mkType (isJust sz) tp -- conT ''Int+				(mkName $ fromRight $ valueOf endian item) $+					strictType notStrict $+						mkType (isJust sz) tp 	isRight item-		| Right _ <- valueOf item = True+		| Right _ <- valueOf endian item = True 		| otherwise = False  mkType :: Bool -> Type -> TypeQ mkType True t = appT listT $ mkType False t-mkType False Int = conT ''Int-mkType False String = conT ''String-mkType False ByteString = conT ''BS.ByteString-mkType False (Tuple ts) = appsT $ tupleT (length ts) : map (mkType False) ts+mkType False (Type typ) = typ  appsT :: [TypeQ] -> TypeQ appsT [t] = t@@ -304,38 +284,9 @@ devideN _ [] = [] devideN n xs = take n xs : devideN n (drop n xs) -class Str a where-	tk :: Int -> a -> a-	dp :: Int -> a -> a-	ts :: a -> String-	fs :: String -> a-	fbs :: BS.ByteString -> a-	tbs :: a -> BS.ByteString-	ti :: a -> Int-	fi :: Int -> Int -> a-	cc :: [a] -> a-	zero :: a--instance Str String where-	tk = take-	dp = drop-	ts = id-	fs = id-	fbs = ts-	tbs = fs-	ti = readInt-	fi = intToBin-	cc = concat-	zero = "\0"--instance Str BS.ByteString where-	tk = BS.take-	dp = BS.drop-	ts = map (chr . fromIntegral) . BS.unpack-	fs = BS.pack . map (fromIntegral . ord)-	fbs = id-	tbs = id-	ti = readInt . map (chr . fromIntegral) . BS.unpack-	fi n = BS.pack . map (fromIntegral . ord) . intToBin n-	cc = BS.concat-	zero = BS.singleton 0+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')