packages feed

binary-file 0.14.3 → 0.15.0

raw patch · 16 files changed

+555/−351 lines, 16 files

Files

binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.14.3+version:	0.15.0 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -74,9 +74,13 @@  extra-source-files:     examples/readPNG.hs,+    examples/CRC.hs,     examples/readBitmap.hs,     examples/readHex.hs,     examples/tiny.hs+    examples/bits.hs+    examples/bitsb.hs+    examples/bitslb.hs  source-repository	head     type:	git@@ -85,7 +89,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git-    tag:	0.14.3+    tag:	0.15.0  library     hs-source-dirs:	src
+ examples/CRC.hs view
@@ -0,0 +1,29 @@+module CRC (crc, testCRC) where++import Data.Array+import Data.Bits+import Data.Char+import Data.Word+import Numeric++--------------------------------------------------------------------------------++crc :: String -> Word32+crc = xor 0xffffffff . foldl crc' 0xffffffff+	where+	crc' :: Word32 -> Char -> Word32+	crc' c x = table ! i `xor` shiftR c 8+		where+		i = (c `xor` fromIntegral (ord x)) .&. 0xff+	table :: Array Word32 Word32+	table = listArray (0, 255) $ map (\n -> foldl table' n [0 .. 7]) [0 .. 255]+	table' :: Word32 -> Int -> Word32+	table' c _+		| c .&. 1 == 0 = shiftR c 1+		| otherwise = xor 0xedb88320 $ shiftR c 1++testCRC :: IO ()+testCRC = p . crc =<< getContents+	where+	p :: Word32 -> IO ()+	p c = putStrLn $ "0x" ++ showHex c ""
+ examples/bits.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, ScopedTypeVariables #-}++import File.Binary (binary, Field(..))+import File.Binary.Instances ()+import File.Binary.Instances.LittleEndian (BitsInt)++main :: IO ()+main = do+	let (bits :: Bits, "") = fromBinary () "hello"+	print bits+	print (toBinary () bits :: String)++[binary|++Bits deriving Show++{Bool}: b0+{Bool}: b1+4{BitsInt}: b2345+{Bool}: b6+{Bool}: b7+{Bool}: c0+{Bool}: c1+{Bool}: c2+{Bool}: c3+{Bool}: c4+{Bool}: c5+{Bool}: c6+{Bool}: c7+((), Nothing){[Bool]}: rests++|]
+ examples/bitsb.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, ScopedTypeVariables #-}++import File.Binary (binary, Field(..))+import File.Binary.Instances ()+import File.Binary.Instances.BigEndian (BitsInt)++main :: IO ()+main = do+	let (bits :: Bits, "") = fromBinary () "hello"+	print bits+	print (toBinary () bits :: String)++[binary|++Bits deriving Show++{Bool}: b0+{Bool}: b1+4{BitsInt}: b2345+{Bool}: b6+{Bool}: b7+{Bool}: c0+{Bool}: c1+{Bool}: c2+{Bool}: c3+{Bool}: c4+{Bool}: c5+{Bool}: c6+{Bool}: c7+((), Nothing){[Bool]}: rests++|]
+ examples/bitslb.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TypeFamilies #-}++import File.Binary (binary, Field(..))+import File.Binary.Instances ()+import qualified File.Binary.Instances.LittleEndian as L (BitsInt)+import qualified File.Binary.Instances.BigEndian as B (BitsInt)++--------------------------------------------------------------------------------++main :: IO ()+main = do+	let (bits :: Bits, "") = fromBinary () "he" -- "\x1b\xf0"+	print bits+	print (toBinary () bits :: String)++[binary|++Bits deriving Show++2{L.BitsInt}: little1+2{L.BitsInt}: little2+2{B.BitsInt}: big1+3{B.BitsInt}: big2+3{B.BitsInt}: big3+4{L.BitsInt} : little3+-- {Bool}: bb0+-- {Bool}: bb1+-- {Bool}: bb2+-- {Bool}: bb3++|]
examples/readBitmap.hs view
@@ -1,22 +1,31 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -import File.Binary-import File.Binary.Instances.LittleEndian()-import File.Binary.Instances()-import System.Environment-import qualified Data.ByteString.Lazy as BSL-import Data.Monoid+import File.Binary (binary, Field(..), Binary(..), readBinaryFile, writeBinaryFile)+import File.Binary.Instances.LittleEndian ()+import File.Binary.Instances ()+import Data.ByteString.Lazy (singleton)+import Data.Monoid (mconcat)+import Control.Applicative ((<$>))+import System.Environment (getArgs) +--------------------------------------------------------------------------------+ main :: IO () main = do-	[inf] <- getArgs-	cnt <- readBinaryFile inf-	let (bmp, rest) = fromBinary () cnt :: (Bitmap, String)-	print bmp-	print $ colors bmp-	print rest+	[inf, outf] <- getArgs+	bmp <- readBitmap inf+	putStrLn $ take 1000 (show bmp) ++ "..."+	writeBitmap outf bmp +readBitmap :: FilePath -> IO Bitmap+readBitmap fp = do+	(bmp, "") <- fromBinary () <$> readBinaryFile fp+	return bmp++writeBitmap :: FilePath -> Bitmap -> IO ()+writeBitmap fp = writeBinaryFile fp . toBinary ()+ instance Field (Int, Int, Int) where 	type FieldArgument (Int, Int, Int) = () 	fromBinary _ s = let@@ -28,7 +37,7 @@ 		toBinary 1 b, 		toBinary 1 g, 		toBinary 1 r,-		makeBinary $ BSL.singleton 0+		makeBinary $ singleton 0 	 ]  [binary|
examples/readHex.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} -import File.Binary-import File.Binary.Instances-import File.Binary.Instances.LittleEndian-import System.Environment-import Control.Applicative-import Numeric+import File.Binary (binary, Field(..), readBinaryFile)+import File.Binary.Instances ()+import File.Binary.Instances.LittleEndian ()+import System.Environment (getArgs)+import Numeric (showHex)+import Data.List (intercalate)+import Control.Applicative ((<$>)) +--------------------------------------------------------------------------------++main :: IO () main = do-	cnt <- readBinaryFile . head =<< getArgs-	putStrLn $ unlines $ map unwords $ groupN 16 $ map (two . flip showHex "") $-		hex $ fst (fromBinary () cnt :: (Hex, String))+	(h, "") <- fromBinary () <$> (readBinaryFile . head =<< getArgs)+	putStr $ unlines $ map (intercalate "-" . map unwords) $ groupN 2 $+		groupN 8 $ map (two . flip showHex "") $ hex h -two s = replicate (2 - l) '0' ++ s-	where-	l = length s+two :: String -> String+two s = let l = length s in replicate (2 - l) '0' ++ s  groupN :: Int -> [a] -> [[a]] groupN _ [] = []
examples/readPNG.hs view
@@ -1,67 +1,76 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, FlexibleInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -import File.Binary-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 Codec.Compression.Zlib+import Prelude hiding (concat)+import File.Binary (binary, Field(..), Binary(..))+import File.Binary.Instances ()+import File.Binary.Instances.BigEndian () import CRC (crc)-import Control.Applicative-import Data.Monoid+import Codec.Compression.Zlib (+	decompress, compressWith, defaultCompressParams, CompressParams(..),+	bestCompression, WindowBits(..))+import qualified Data.ByteString as BS (ByteString, length, readFile, writeFile)+import qualified Data.ByteString.Char8 as BSC (unpack)+import Data.ByteString.Lazy+	(ByteString, pack, unpack, concat, toChunks, fromChunks)+import Data.Word (Word8, Word32)+import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR)+import Data.Monoid (mconcat)+import Control.Applicative ((<$>))+import Control.Arrow(first)+import System.Environment (getArgs) +--------------------------------------------------------------------------------+ main :: IO () main = do 	[fin, fout] <- getArgs-	cnt <- BS.readFile fin-	let (png, _) = fromBinary () cnt+	png <- readPNG fin -	putStrLn $ take 1000 (show png) ++ "..."+	putStrLn $ take 800 (show png) ++ "..." -	let	dat = makeData png+	let	dat = concatIDATs $ body png 		decomp = decompress dat 		recomp = compressWith defaultCompressParams { 			compressLevel = bestCompression, 			compressWindowBits = WindowBits 10 		 } decomp-		newData = makeDataChank recomp-		newnew = png {-			chanks = headerChanks png ++ newData ++-				footerChanks png-		 }-	BS.writeFile fout $ toBinary () newnew-	print $ dat == recomp+		newIDAT = map makeIDAT $ toChunks recomp+		new = png { chunks = header png ++ newIDAT ++ footer png }+	writePNG fout new -headerChanks :: PNG -> [Chank]-headerChanks PNG{ chanks = cs } =-	filter ((`notElem` ["IEND", "IDAT"]) . chankName) cs+	putStrLn ""+	putStrLn $ take 800 (show new) ++ "..." -footerChanks :: PNG -> [Chank]-footerChanks PNG{ chanks = cs } = filter ((== "IEND") . chankName) cs+readPNG :: FilePath -> IO PNG+readPNG fp = do+	(png, "") <- fromBinary () <$> BS.readFile fp+	return png -makeData :: PNG -> BSL.ByteString-makeData PNG{ chanks = cs } =-	BSL.concat $ map (idat . cidat . chankData) $-		filter ((== "IDAT") . chankName) cs+writePNG :: FilePath -> PNG -> IO ()+writePNG fout = BS.writeFile fout . toBinary () -makeDataChank :: BSL.ByteString -> [Chank]-makeDataChank = map makeOneDataChank . BSL.toChunks+header :: PNG -> [Chunk]+header PNG{ chunks = cs } =+	filter ((`notElem` ["IEND", "IDAT"]) . chunkName) cs -makeOneDataChank :: BS.ByteString -> Chank-makeOneDataChank bs = Chank {-	chankSize = fromIntegral $ BS.length bs,-	chankName = "IDAT",-	chankData = ChankIDAT $ IDAT $ BSL.fromChunks [bs],-	chankCRC = crc $ "IDAT" ++ BSC.unpack bs- }+body :: PNG -> [IDAT]+body PNG { chunks = cs } =+	map (cidat . chunkData) $ filter ((== "IDAT") . chunkName) cs -test :: IO PNG-test = fst . fromBinary () <$> readBinaryFile "tmp/sample.png"+footer :: PNG -> [Chunk]+footer PNG{ chunks = cs } = filter ((== "IEND") . chunkName) cs +concatIDATs :: [IDAT] -> ByteString+concatIDATs = concat . map idat++makeIDAT :: BS.ByteString -> Chunk+makeIDAT bs = Chunk {+	chunkSize = fromIntegral $ BS.length bs,+	chunkName = "IDAT",+	chunkData = ChunkIDAT $ IDAT $ fromChunks [bs],+	chunkCRC = crc $ "IDAT" ++ BSC.unpack bs }+ [binary|  PNG deriving Show@@ -71,80 +80,70 @@ 2: "\r\n" 1: "\SUB" 1: "\n"-((), Nothing){[Chank]}: chanks+((), Nothing){[Chunk]}: chunks  |]  [binary| -Chank deriving Show+Chunk deriving Show -4: chankSize-((), Just 4){String}: chankName-(chankSize, chankName){ChankBody}: chankData-4{Word32}:chankCRC+4: chunkSize+((), Just 4){String}: chunkName+(chunkSize, chunkName){ChunkBody}: chunkData+4{Word32}:chunkCRC  |]  instance Field Word32 where 	type FieldArgument Word32 = Int-	toBinary n = makeBinary . BSL.pack . intToWords n-	fromBinary n s = (fromIntegral $ toIntgr $ BSL.reverse t, d)-		where-		(t, d) = getBytes n s+	toBinary n = makeBinary . pack . intToWords n+	fromBinary n = first (wordsToInt . unpack) . getBytes n -toIntgr :: BSL.ByteString -> Integer-toIntgr = mkNum . map fromIntegral . BSL.unpack+intToWords :: (Bits i, Integral i) => Int -> i -> [Word8]+intToWords = itw []+	where+	itw r 0 _ = r+	itw r n i = itw (fromIntegral (i .&. 0xff) : r) (n - 1) (i `shiftR` 8) -mkNum :: [Integer] -> Integer-mkNum [] = 0-mkNum (x : xs) = x + 2 ^ (8 :: Integer) * mkNum xs+wordsToInt :: Bits i => [Word8] -> i+wordsToInt = foldl (\r w -> r `shiftL` 8 .|. fromIntegral w) 0 -data ChankBody-	= ChankIHDR IHDR-	| ChankGAMA GAMA-	| ChankSRGB SRGB-	| ChankCHRM CHRM-	| ChankPLTE PLTE-	| ChankBKGD BKGD-	| ChankIDAT { cidat :: IDAT }-	| ChankTEXT TEXT-	| ChankIEND IEND+data ChunkBody+	= ChunkIHDR IHDR+	| ChunkGAMA GAMA+	| ChunkSRGB SRGB+	| ChunkCHRM CHRM+	| ChunkPLTE PLTE+	| ChunkBKGD BKGD+	| ChunkIDAT { cidat :: IDAT }+	| ChunkTEXT TEXT+	| ChunkIEND IEND 	| Others String 	deriving Show -instance Field ChankBody where-	type FieldArgument ChankBody = (Int, String)-	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 c) = toBinary () c-	toBinary (n, _) (ChankIDAT c) = toBinary n c-	toBinary (n, _) (ChankTEXT c) = toBinary n c-	toBinary _ (ChankIEND c) = toBinary () c+instance Field ChunkBody where+	type FieldArgument ChunkBody = (Int, String)+	toBinary _ (ChunkIHDR c) = toBinary () c+	toBinary _ (ChunkGAMA c) = toBinary () c+	toBinary _ (ChunkSRGB c) = toBinary () c+	toBinary (n, _) (ChunkCHRM chrm) = toBinary n chrm+	toBinary (n, _) (ChunkPLTE plte) = toBinary n plte+	toBinary _ (ChunkBKGD c) = toBinary () c+	toBinary (n, _) (ChunkIDAT c) = toBinary n c+	toBinary (n, _) (ChunkTEXT c) = toBinary n c+	toBinary _ (ChunkIEND 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 (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 (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-		(Others others, rest)+	fromBinary (_, "IHDR") = first ChunkIHDR . fromBinary ()+	fromBinary (_, "gAMA") = first ChunkGAMA . fromBinary ()+	fromBinary (_, "sRGB") = first ChunkSRGB . fromBinary ()+	fromBinary (n, "cHRM") = first ChunkCHRM . fromBinary n+	fromBinary (n, "PLTE") = first ChunkPLTE . fromBinary n+	fromBinary (_, "bKGD") = first ChunkBKGD . fromBinary ()+	fromBinary (n, "IDAT") = first ChunkIDAT . fromBinary n+	fromBinary (n, "tEXt") = first ChunkTEXT . fromBinary n+	fromBinary (_, "IEND") = first ChunkIEND . fromBinary ()+	fromBinary (n, _) = first Others . fromBinary ((), Just n)  [binary| @@ -153,7 +152,14 @@ 4: width 4: height 1: depth-1: colorType+: False+: False+: False+: False+: False+{Bool}: alpha+{Bool}: color+{Bool}: palet 1: compressionType 1: filterType 1: interlaceType@@ -191,6 +197,7 @@ [binary|  PLTE deriving Show+ arg :: Int  ((), Just (arg `div` 3)){[(Int, Int, Int)]}: colors@@ -199,13 +206,12 @@  instance Field (Int, Int, Int) where 	type FieldArgument (Int, Int, Int) = ()-	toBinary _ (b, g, r) =-		mconcat [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+		(r, rest) = fromBinary 1 s 		(g, rest') = fromBinary 1 rest-		(r, rest'') = fromBinary 1 rest' in-		((b, g, r), rest'')+		(b, rest'') = fromBinary 1 rest' in+		((r, g, b), rest'')  [binary| @@ -221,8 +227,7 @@  arg :: Int -arg{BSL.ByteString}: idat---((), Just arg){String}: idat+arg{ByteString}: idat  |]
examples/tiny.hs view
@@ -1,23 +1,25 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, ScopedTypeVariables #-} -import File.Binary-import File.Binary.Instances-import File.Binary.Instances.LittleEndian-import System.Directory-import System.IO-import Control.Applicative-import Numeric-import System.Environment+import File.Binary (binary, Field(..), readBinaryFile, writeBinaryFile)+import File.Binary.Instances ()+-- import File.Binary.Instances.LittleEndian ()+import File.Binary.Instances.BigEndian ()+import Control.Applicative ((<$>))+import Numeric (showHex)+import System.Environment (getArgs) -size = 4+-------------------------------------------------------------------------------- +size :: Int+size = 2++main :: IO () main = do 	n <- read . head <$> getArgs 	writeBinaryFile "tmp/out/tiny.dat" $ toBinary n $ Tiny 0x0123456789abcdef-	(t ::Tiny, rest) <- fromBinary n <$> readBinaryFile "tmp/out/tiny.dat"+	(t ::Tiny, "") <- fromBinary n <$> readBinaryFile "tmp/out/tiny.dat" 	print t 	putStrLn $ flip showHex "" $ value t-	print rest  [binary| @@ -26,6 +28,14 @@ arg :: Int  4: "tiny"+: True+: False+: False+: False+: True+: False+: False+: True Main.size * arg{Integer}: value  |]
src/File/Binary.hs view
@@ -1,9 +1,6 @@ module File.Binary (-	Field(..),-	Binary(..),-	binary,-	readBinaryFile,-	writeBinaryFile+	Field(..), Binary(..), binary,+	readBinaryFile, writeBinaryFile  ) where  import File.Binary.Quote (Field(..), Binary(..), binary)@@ -13,4 +10,4 @@ readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents  writeBinaryFile :: FilePath -> String -> IO ()-writeBinaryFile f txt = withBinaryFile f WriteMode $ \hdl -> hPutStr hdl txt+writeBinaryFile f = withBinaryFile f WriteMode . flip hPutStr
src/File/Binary/Classes.hs view
@@ -1,14 +1,43 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, TupleSections #-} -module File.Binary.Classes (Field(..), Binary(..)) where+module File.Binary.Classes (Field(..), Binary(..), pop, push) where -import Data.Monoid (Monoid)-import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy (ByteString, unpack, singleton)+import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import Data.Monoid (Monoid, mappend, mempty)+import Control.Arrow (first, second) -class Field r where-	type FieldArgument r-	fromBinary :: Binary s => FieldArgument r -> s -> (r, s)-	toBinary :: Binary s => FieldArgument r -> r -> s+type AddBits b = ([Bool], b)++class Field f where+	type FieldArgument f+	fromBinary :: Binary b => FieldArgument f -> b -> (f, b)+	toBinary :: Binary b => FieldArgument f -> f -> b+	fromBits :: Binary b => FieldArgument f -> AddBits b -> (f, AddBits b)+	consToBits :: Binary b => FieldArgument f -> f -> AddBits b -> AddBits b++	fromBits a ([], b) = second ([] ,) $ fromBinary a b+	fromBits _ _ = error "fromBits: not bytes (1 byte = 8 bits)"+	consToBits a f ([], b) = ([], toBinary a f `mappend` b)+	consToBits _ _ _ = error "consToBits: not bytes (1 byte = 8 bits)"++	fromBinary a b = case fromBits a ([], b) of+		(f, ([], rest)) -> (f, rest)+		_ -> error "fromBinary: not bytes (1 byte = 8 bits)"+	toBinary a f = case consToBits a f ([], mempty) of+		([], bin) -> bin+		_ -> error "toBinary: not bytes (1 byte = 8 bits)"++pop :: Binary b => b -> AddBits b+pop = first (wtbs (8 :: Int) . head . unpack) . getBytes 1+	where+	wtbs 0 _ = []+	wtbs n w = toEnum (fromIntegral $ 1 .&. w) : wtbs (n - 1) (w `shiftR` 1)++push :: Binary b => AddBits b -> b+push = uncurry $ mappend . makeBinary . singleton . bstw+	where+	bstw = foldr (\b w -> w `shiftL` 1 .|. fromIntegral (fromEnum b)) 0  class (Eq b, Monoid b) => Binary b where 	getBytes :: Int -> b -> (ByteString, b)
src/File/Binary/Instances.hs view
@@ -1,86 +1,62 @@-{-# LANGUAGE-	TypeFamilies,-	TypeSynonymInstances,-	FlexibleInstances #-}+{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances, PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module File.Binary.Instances () where +import Prelude hiding (take, drop) 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 Data.ByteString.Lazy (ByteString, take, drop, toChunks, fromChunks)+import Data.ByteString.Lazy.Char8 (pack, unpack)+import qualified Data.ByteString as BS (ByteString, take, drop, concat)+import Control.Monad (replicateM)+import "monads-tf" Control.Monad.State (StateT(..), runState, gets)+import "monads-tf" Control.Monad.Identity (Identity(..))+import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, (&&&))-import Data.Monoid+import Data.Monoid (mempty) -instance Field BSL.ByteString where-	type FieldArgument BSL.ByteString = Int-	fromBinary n str = getBytes n str+--------------------------------------------------------------------------------++instance Field ByteString where+	type FieldArgument ByteString = Int+	fromBinary = getBytes 	toBinary _ = makeBinary  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 . (: [])+	fromBinary n = first (BS.concat . toChunks) . getBytes n+	toBinary _ = makeBinary . 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 . (: [])+	fromBinary _ = first (head . unpack) . getBytes 1+	toBinary _ = makeBinary . 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+	fromBits (a, Just b) = b `times` fromBits a+	fromBits (a, Nothing) = mempty `whole` fromBits a+	consToBits (a, _) = flip $ foldr $ consToBits a  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')+times n f = runState $ replicateM n (StateT $ Identity . f) -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')+whole :: Eq s => s -> (s -> (ret, s)) -> s -> ([ret], s)+whole e f = runState $ do+	emp <- gets (== e)+	if emp then return [] else+		(:) <$> (StateT $ Identity . f) <*> (StateT $ Identity . whole e f)  --------------------------------------------------------------------------------  instance Binary String where-	getBytes n = BSLC.pack . take n &&& drop n-	makeBinary = BSLC.unpack--{--	appendBinary = (++)-	emptyBinary = null--}+	getBytes n = first pack . splitAt n+	makeBinary = unpack -instance Binary BSL.ByteString where-	getBytes n = BSL.take (fromIntegral n) &&& BSL.drop (fromIntegral n)+instance Binary ByteString where+	getBytes n = take (fromIntegral n) &&& 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--}+	getBytes n = fromChunks . (: []) . BS.take n &&& BS.drop n+	makeBinary = BS.concat . toChunks
src/File/Binary/Instances/BigEndian.hs view
@@ -1,38 +1,64 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module File.Binary.Instances.BigEndian (-	intToWords-) where+module File.Binary.Instances.BigEndian (BitsInt) where -import File.Binary.Classes-import qualified Data.ByteString.Lazy as BSL-import Data.Word+import File.Binary.Classes (Field(..), Binary(..), pop, push)+import Data.ByteString.Lazy (pack, unpack)+import Data.Word (Word8)+import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR)+import Control.Arrow (first) +--------------------------------------------------------------------------------++instance Field Integer where+	type FieldArgument Integer = Int+	fromBinary n = first (wordsToInt . unpack) . getBytes n+	toBinary n = makeBinary . pack . intToWords n+ 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+	fromBinary n = first (wordsToInt . unpack) . getBytes n+	toBinary n = makeBinary . pack . intToWords n -wordsToInt :: Integral i => [Word8] -> i-wordsToInt = foldl (\i w -> i * 256 + fromIntegral w) 0+wordsToInt :: Bits i => [Word8] -> i+wordsToInt = foldl (\i w -> i `shiftL` 8 .|. fromIntegral w) 0 -intToWords :: Integral i => Int -> i -> [Word8]+intToWords :: (Bits i, 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)+	itw r 0 _ = r+	itw r n i = itw (fromIntegral (i .&. 0xff) : r) (n - 1) (i `shiftR` 8) -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+instance Field Bool where+	type FieldArgument Bool = ()+	fromBits () ([], bin) = fromBits () $ pop bin+	fromBits () (bs, bin) = (last bs, (init bs, bin))+	consToBits () b (bs, bin)+		| length bs == 7 = ([], push (bs ++ [b], bin))+		| otherwise = (bs ++ [b], bin)++data BitsInt = BitsInt { bitsInt :: Int } deriving Show++instance Field BitsInt where+	type FieldArgument BitsInt = Int+	fromBits n = first BitsInt . fb n 0+	consToBits n = ctb n . bitsInt++fromEnum' :: (Enum e, Num i) => e -> i+fromEnum' = fromIntegral . fromEnum++toEnum' :: (Enum e, Integral i) => i -> e+toEnum' = toEnum . fromIntegral++fb :: (Bits f, Binary b) => Int -> f -> ([Bool], b) -> (f, ([Bool], b))+fb 0 r bb = (r, bb)+fb n r ([], b) = fb n r $ pop b+fb n r (bs, b) = fb (n - 1) (r `shiftL` 1 .|. (fromEnum' $ last bs)) (init bs, b)++ctb :: (Bits f, Integral f, Binary b) => Int -> f -> ([Bool], b) -> ([Bool], b)+ctb 0 _ r = r+ctb n f (bs, b)+	| length bs == 7 = ctb (n - 1) (f `shiftR` 1) ([], push (bs ++ [bit], b))+	| otherwise = ctb (n - 1) (f `shiftR` 1) (bs ++ [bit], b)+	where bit = toEnum' $ f .&. 1
src/File/Binary/Instances/LittleEndian.hs view
@@ -1,26 +1,50 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module File.Binary.Instances.LittleEndian where+module File.Binary.Instances.LittleEndian (BitsInt) where -import File.Binary.Classes-import qualified Data.ByteString.Lazy as BSL-import Data.Word-import Control.Arrow+import File.Binary.Classes (Field(..), Binary(..), pop, push)+import Data.ByteString.Lazy (pack, unpack)+import Data.Word (Word8)+import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR)+import Control.Arrow (first)  instance Field Int where 	type FieldArgument Int = Int-	fromBinary n = first (wordsToInt . BSL.unpack) . getBytes n-	toBinary n = makeBinary . BSL.pack . intToWords n+	fromBinary n = first (wordsToInt . unpack) . getBytes n+	toBinary n = makeBinary . 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+	fromBinary n = first (wordsToInt . unpack) . getBytes n+	toBinary n = makeBinary . pack . intToWords n -wordsToInt :: Integral i => [Word8] -> i-wordsToInt = foldr (\w i -> fromIntegral w + 256 * i) 0+wordsToInt :: Bits i => [Word8] -> i+wordsToInt = foldr (\w i -> fromIntegral w .|. i `shiftL` 8) 0 -intToWords :: Integral i => Int -> i -> [Word8]+intToWords :: (Bits i, Integral i) => Int -> i -> [Word8] intToWords 0 _ = []-intToWords n i = fromIntegral (i `mod` 256) : intToWords (n - 1) (i `div` 256)+intToWords n i = fromIntegral (i .&. 0xff) : intToWords (n - 1) (i `shiftR` 8)++instance Field Bool where+	type FieldArgument Bool = ()+	fromBits () ([], bin) = fromBits () $ pop bin+	fromBits () (b : bs, bin) = (b, (bs, bin))+	consToBits () b (bs, bin)+		| length bs == 7 = ([], push ((b : bs), bin))+		| otherwise = (b : bs, bin)++data BitsInt = BitsInt { bitsInt :: Int } deriving Show++instance Field BitsInt where+	type FieldArgument BitsInt = Int+	fromBits 0 bb = (BitsInt 0, bb)+	fromBits n ([], bin) = fromBits n $ pop bin+	fromBits n (b : bs, bin) = flip first (fromBits (n - 1) (bs, bin)) $+		BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt+	consToBits 0 _ bb = bb+	consToBits n (BitsInt f) bb = let+		(bs, bin) = consToBits (n - 1) (BitsInt $ f `shiftR` 1) bb in+		if length bs == 7+			then ([], push (toEnum (f .&. 1) : bs, bin))+			else (toEnum (f .&. 1) : bs, bin)
src/File/Binary/Parse.hs view
@@ -7,55 +7,57 @@ 	-fno-warn-unused-do-bind #-}  module File.Binary.Parse (-	parse, BinaryStructure, bsName, bsDerive, bsArgName, bsArgType, bsItem,-	BSItem, argOf, valueOf, Value(..), variables, Expression, expression,+	parse, Structure, sName, sDerive, sArgName, sArgType, sItems,+	SItem, argOf, valueOf, constant, Value, expression ) where -import Control.Applicative ((<$>), (<*>))-import "monads-tf" Control.Monad.Reader (Reader, runReader, ask)-import Data.Maybe (catMaybes)-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)+	ExpQ, integerL, litE, varE, conE, tupE, appE, uInfixE, parensE,+	TypeQ, conT, listT, tupleT, appT, Name, mkName)+import "monads-tf" Control.Monad.Reader (Reader, runReader, ask)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow(second)+import Data.Maybe (fromMaybe)+import Numeric (readHex)  -------------------------------------------------------------------------------- -parse :: String -> BinaryStructure+parse :: String -> Structure parse = either (error . show) id . parseString top "" -data BinaryStructure = BinaryStructure {-	bsName :: Name,-	bsDerive :: [Name],-	bsArgName :: String,-	bsArgType :: TypeQ,-	bsItem :: [BSItem] }+data Structure = Structure {+	sName :: Name,+	sDerive :: [Name],+	sArgName :: String,+	sArgType :: TypeQ,+	sItems :: [SItem] } -data BSItem = BSItem { argOf :: Expression, typeOf :: TypeQ, valueOf :: Value }+data SItem = SItem { argOf :: Expression, valueOf :: Value } type Expression	= Reader (ExpQ, ExpQ, String) ExpQ  expression :: ExpQ -> ExpQ -> String -> Expression -> ExpQ expression ret arg argn e = runReader e (ret, arg, argn) -data Value = Constant (Either Integer String) | Variable Name+type Value = Either Constant (Name, TypeQ) -variables :: [BSItem] -> [(Name, TypeQ)]-variables = catMaybes . map (\bsi -> case valueOf bsi of-		Variable var -> Just (var, typeOf bsi); _ -> Nothing)+data Constant = Integer Integer | String String | Bool Bool deriving Show -varToExp :: String -> (ExpQ, ExpQ, String) -> ExpQ-varToExp var (ret, arg, argn)+constant :: (Integer -> a) -> (String -> a) -> (Bool -> a) -> Constant -> a+constant f _ _ (Integer i) = f i+constant _ f _ (String s) = f s+constant _ _ f (Bool b) = f b++identify :: String -> (ExpQ, ExpQ, String) -> ExpQ+identify var (ret, arg, argn) 	| var == argn = arg 	| '.' `elem` var = varE $ mkName var 	| otherwise = appE (varE $ mkName var) ret  [peggy| -top :: BinaryStructure-	= emp lname der arg dat*-				{ BinaryStructure $2 $3 (fst $4) (snd $4) $5 }+top :: Structure+	= emp lname der arg dat*	{ Structure $2 $3 (fst $4) (snd $4) $5 }  der :: [Name] 	= emp 'deriving' sp ln (sp ',' sp ln)*@@ -66,17 +68,18 @@ 	= emp var sp '::' sp typ	{ ($2, $5) } 	/ ''				{ ("_", conT $ mkName "()") } -dat :: BSItem-	= emp ex sp typS sp ':' sp val	{ BSItem $2 $4 $7 }+dat :: SItem = emp ex? sp typS sp ':' sp val+	{ SItem (fromMaybe (return $ conE $ mkName "()") $2) $+		either Left (Right . second (const $4)) $7 } -typS :: TypeQ-	= '{' typ '}'			{ $1 }-	/ ''				{ conT $ mkName "Int" }+typS :: TypeQ = '{' typ '}' / ''	{ conT $ mkName "Int" }  val :: Value-	= var				{ Variable $ mkName $1 }-	/ num				{ Constant $ Left $1 }-	/ string			{ Constant $ Right $1 }+	= var				{ Right $ (mkName $1, conT $ mkName "()") }+	/ num				{ Left $ Integer $1 }+	/ string			{ Left $ String $1 }+	/ 'True'			{ Left $ Bool True }+	/ 'False'			{ Left $ Bool False }  ex :: Expression 	= ex sp op sp exOp1		{ uInfixE <$> $1 <*> $3 <*> $5 }@@ -87,37 +90,33 @@ 	/ ex1  ex1 :: Expression-	= '(' tupExp ')'+	= '(' ex (sp ',' sp ex)+ ')'	{ (.) tupE . (:) <$> $1 <*>+						mapM (\(_, _, e) -> e) $2 } 	/ '(' ex ')'			{ parensE <$> $1 } 	/ '()'				{ return $ conE $ mkName "()" } 	/ num				{ return $ litE $ integerL $1 } 	/ lname				{ return $ conE $1 }-	/ var				{ flip fmap ask $ varToExp $1 }+	/ var				{ identify $1 <$> ask }  op :: Expression 	= [!\\#$%&*+./<=>?@^|~-:]+	{ return $ varE $ mkName $1 } 	/ '`' var '`'			{ return $ varE $ mkName $1 }-tupExp :: Expression = ex (sp ',' sp ex)+-	{ (.) tupE . (:) <$> $1 <*> mapM (\(_, _, e) -> e) $2 }  typ :: TypeQ 	= typ typ1			{ appT $1 $2 } 	/ typ1  typ1 :: TypeQ-	= '(' tupType ')'		{ foldl appT (tupleT $ length $1) $1 }+	= '(' typ sp (',' sp typ)+ ')'	{ foldl appT (tupleT $ length $3 + 1) $+						$1 : map snd $3 } 	/ '(' 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 }+lname :: Name = (ln '.')* ln		{ mkName $ concatMap (++ ".") $1 ++ $2 } -var :: String-	= (ln '.')* sn			{ concatMap (++ ".") $1 ++ $2 }+var :: String = (ln '.')* sn		{ concatMap (++ ".") $1 ++ $2 }  num :: Integer 	= '0x' [0-9a-fA-F]+		{ fst $ head $ readHex $1 }
src/File/Binary/Quote.hs view
@@ -2,62 +2,58 @@  module File.Binary.Quote (Field(..), Binary(..), binary) where +import File.Binary.Parse (+	parse, Structure, sName, sDerive, sArgName, sArgType, sItems,+	SItem, argOf, valueOf, constant, Value, expression)+import File.Binary.Classes (Field(..), Binary(..)) import Language.Haskell.TH (-	Q, DecsQ, ClauseQ, ExpQ, Dec, Exp(..), Name, FieldExp,+	Q, DecsQ, ClauseQ, BodyQ, ExpQ, Dec, Exp(..), Name, FieldExp, 	dataD, recC, varStrictType, strictType, notStrict, 	instanceD, funD, clause, normalB, valD, tySynInstD, cxt, 	conT, appT, sigE, varP, tupP, letE, condE, recConE, tupE, listE,-	appE, appsE, infixApp, varE, litE, newName, integerL, stringL)+	appE, appsE, infixApp, varE, conE, litE, newName, integerL, stringL) import Language.Haskell.TH.Quote (QuasiQuoter(..))-import Data.Monoid (mconcat)+import Data.ByteString.Lazy.Char8 (pack) import Control.Monad (zipWithM) import "monads-tf" Control.Monad.State (StateT, runStateT, get, put, lift) import "monads-tf" Control.Monad.Writer (WriterT, runWriterT, tell) import Control.Applicative ((<$>), (<*>))-import qualified Data.ByteString.Lazy.Char8 as BSLC (ByteString, pack)--import File.Binary.Parse (-	parse, BinaryStructure, bsName, bsDerive, bsArgName, bsArgType, bsItem,-	BSItem, argOf, valueOf, Value(..), variables, expression)-import File.Binary.Classes (Field(..), Binary(..))+import Data.Either (rights)  --------------------------------------------------------------------------------  binary :: QuasiQuoter binary = QuasiQuoter { 	quoteExp = undefined, quotePat = undefined, quoteType = undefined,-	quoteDec = top . parse- }+	quoteDec = top . parse } -top :: BinaryStructure -> DecsQ-top bs = let c = bsName bs in (\d i -> [d, i])+top :: Structure -> DecsQ+top bs = let c = sName bs in (\d i -> [d, i]) 	<$> dataD (cxt []) c [] [recC c $ 		map (varStrictType <$> fst <*> strictType notStrict . snd) $-			variables $ bsItem bs] (bsDerive bs)+			rights $ map valueOf $ sItems bs] (sDerive bs) 	<*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [-		tySynInstD ''FieldArgument [conT c] $ bsArgType bs,-		funD 'fromBinary $ (: []) $ reading c (bsArgName bs) (bsItem bs),-		funD 'toBinary $ (: []) $ writing (bsArgName bs) (bsItem bs)-	 ]+		tySynInstD ''FieldArgument [conT c] $ sArgType bs,+		funD 'fromBits $ (: []) $ reading c (sArgName bs) (sItems bs),+		funD 'consToBits $ (: []) $ writing (sArgName bs) (sItems bs)] -reading :: Name -> String -> [BSItem] -> ClauseQ-reading con argn items = do+reading :: Name -> String -> [SItem] -> ClauseQ+reading c argn is = do 	arg <- newName "_arg"-	bin <- newName "bin"-	flip (clause [varP arg, varP bin]) [] $-		normalB $ letRec $ binToDat con items (varE bin) $ \ret ->-			expression ret (varE arg) argn . argOf+	b <- newName "bin"+	flip (clause [varP arg, varP b]) [] $ letRec $ readfs c is (varE b) $+		\ret -> expression ret (varE arg) argn . argOf -letRec :: (ExpQ -> ExpQ) -> ExpQ-letRec e = do+letRec :: (ExpQ -> ExpQ) -> BodyQ+letRec e = normalB $ do 	(ret, rest) <- (,) <$> newName "ret" <*> newName "rest" 	letE [valD (tupP [varP ret, varP rest]) (normalB $ e $ varE ret) []] $ 		tupE [varE ret, varE rest] -binToDat :: Name -> [BSItem] -> ExpQ -> (ExpQ -> BSItem -> ExpQ) -> ExpQ -> ExpQ-binToDat con items bin size ret = do+readfs :: Name -> [SItem] -> ExpQ -> (ExpQ -> SItem -> ExpQ) -> ExpQ -> ExpQ+readfs con items bin size ret = do 	((binds, rest), rts) <- runWriterT $ (`runStateT` bin) $-		(zipWithM binToField <$> map (size ret) <*> map valueOf) items+		(zipWithM readf <$> map (size ret) <*> map valueOf) items 	letE (return <$> binds) $ tupE $ (: [rest]) $ recConE con $ return <$> rts  type FieldMonad = StateT ExpQ (WriterT [FieldExp] Q)@@ -68,41 +64,43 @@ liftW :: WriterT [FieldExp] Q a -> FieldMonad a liftW = lift -binToField :: ExpQ -> Value -> FieldMonad Dec-binToField size (Constant val) = do+readf :: ExpQ -> Value -> FieldMonad Dec+readf size (Left val) = do 	bin <- get 	[rv, rest, bin'] <- liftQ $ mapM newName ["rv", "rst", "bin'"] 	put $ varE bin'-	let lit = either+	let lit = constant 		((`sigE` conT ''Integer) . litE . integerL)-		((`sigE` conT ''BSLC.ByteString) .-			appE (varE 'BSLC.pack) . litE . stringL) val+		(appE (varE 'pack) . litE . stringL)+		(\b -> if b then conE 'True else conE 'False)+		val 	liftQ $ flip (valD $ varP bin') [] $ normalB $ 		letE [flip (valD $ tupP [varP rv, varP rest]) [] $ normalB $-			appsE [varE 'fromBinary, size, bin]] $+			appsE [varE 'fromBits, size, bin]] $ 		condE (infixApp (varE rv) (varE '(==)) lit) (varE rest) 			[e| error "bad value" |]-binToField size (Variable var) = do+readf size (Right (var, _)) = do 	bin <- get 	[bin', tmp] <- liftQ $ mapM newName ["bin'", "tmp"] 	put $ varE bin' 	liftW $ tell [(var, VarE tmp)] 	liftQ $ valD (tupP [varP tmp, varP bin'])-		(normalB $ appsE [varE 'fromBinary, size, bin]) []+		(normalB $ appsE [varE 'fromBits, size, bin]) [] -writing :: String -> [BSItem] -> ClauseQ+writing :: String -> [SItem] -> ClauseQ writing argn items = do-	arg <- newName "_arg"-	dat <- newName "_dat"-	flip (clause [varP arg, varP dat]) [] $ normalB $-		appE (varE 'mconcat) $ listE $ (<$> items) $ fieldToBin dat-			<$> expression (varE dat) (varE arg) argn . argOf-			<*> valueOf+	[arg, dat, bin0] <- mapM newName ["_arg", "_dat", "bin0"]+	flip (clause [varP arg, varP dat, varP bin0]) [] $ normalB $+		appE (appsE [varE 'foldr, varE '($), varE bin0]) $ listE $+			(<$> items) $ writef dat+				<$> expression (varE dat) (varE arg) argn . argOf+				<*> valueOf -fieldToBin :: Name -> ExpQ -> Value -> ExpQ-fieldToBin _ size (Constant val) =  varE 'toBinary `appE` size `appE` either+writef :: Name -> ExpQ -> Value -> ExpQ+writef _ size (Left val) = varE 'consToBits `appE` size `appE` constant 	((`sigE` conT ''Integer) . litE . integerL)-	((`sigE` conT ''BSLC.ByteString) . appE (varE 'BSLC.pack) . litE . stringL)+	(appE (varE 'pack) . litE . stringL)+	(\b -> if b then conE 'True else conE 'False) 	val-fieldToBin dat size (Variable val) =-	varE 'toBinary `appE` size `appE` (varE val `appE` varE dat)+writef dat size (Right (rec, _)) =+	varE 'consToBits `appE` size `appE` (varE rec `appE` varE dat)