diff --git a/binary-file.cabal b/binary-file.cabal --- a/binary-file.cabal +++ b/binary-file.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: binary-file -version: 0.12.8 +version: 0.13.1 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -14,65 +14,56 @@ synopsis: read/write binary file description: - > runghc -XQuasiQuotes exam.hs some.bmp out.bmp + > runghc -XQuasiQuotes -XTypeFamilies -XFlexibleInstances exam.hs some.bmp . exam.hs: . > import File.Binary > import File.Binary.Data.LittleEndian > import System.Environment - > import Data.ByteString as BS + > import Data.ByteString.Lazy as BSL > > main = do - > [inf, outf] <- getArgs - > + > [inf] <- getArgs > cnt <- BS.readFile inf - > let bmp = readBitmap $ cnt `BS.append` replicate 20 ' ' + > let (bmp, rest) = fromBinary () cnt :: (Bitmap, String) > print bmp > - > let out = writeBitmap bmp { - > authorFirst = "Yoshikuni ", - > authorSecond = "Jujo " - > } - > 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 + > instance Field (Int, Int, Int) where + > type FieldArgument (Int, Int, Int) = () + > fromBinary _ s = let + > (b, rest) = toType 1 s > (g, rest') = toType 1 rest > (r, rest'') = toType 1 rest' in - > ((b, g, r), dp 1 rest'') + > ((b, g, r), snd $ getBytes 1 1 rest'') + > toBinary _ (b, g, r) = concatBinary [ + > fromType 1 b, fromType 1 g, fromType 1 r, + > makeBinary $ BSL.singleton 0] > > [binary| > > Bitmap > > 2: "BM" - > 4: fileSize + > 4: file_size > 2: 0 > 2: 0 > 4: offset > > 4: 40 - > 4: bitmapWidth - > 4: bitmapHeight + > 4: width + > 4: height > 2: 1 - > 2: bitsPerPixel - > 4: compressionMethod - > 4: imageSize - > 4: horizontalResolution - > 4: verticalResolution - > 4: numberOfColors - > 4: importantColors - > ((), Just numberOfColors)<[(Int, Int, Int)]>: colors - > imageSize: image + > 2: bits_per_pixel + > 4: compression + > 4: image_size + > 4: resolutionH + > 4: resolutionV + > 4: color_num + > 4: important_color_num + > ((), Just color_num)<[(Int, Int, Int)]>: colors + > ((), image_size): image > - > ((), Just 10): authorFirst - > ((), Just 10): authorSecond - > > |] . @@ -85,7 +76,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/binary-file.git - tag: 0.12.7 + tag: 0.13.1 library hs-source-dirs: src diff --git a/examples/readPNG.hs b/examples/readPNG.hs --- a/examples/readPNG.hs +++ b/examples/readPNG.hs @@ -5,35 +5,104 @@ import System.Environment import Data.Word import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Codec.Compression.Zlib +import CRC (crc) +import Control.Applicative main = do [fin, fout] <- getArgs - cnt <- readBinaryFile fin - let (png, rest) = readPNG () cnt - print $ png - writeBinaryFile fout $ writePNG () png +-- cnt <- readBinaryFile fin + cnt <- BS.readFile fin + let (png, rest) = fromBinary () cnt -test = readPNG () `fmap` readBinaryFile "tmp/out.png" + putStrLn $ take 1000 (show 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) +-- writeBinaryFile fout $ toBinary () png +-- BS.writeFile fout $ writePNG () png -instance RetType Chank where - type Argument Chank = () - fromType = writeChank - toType = readChank + let ChankIDAT idt = chankData $ chanks png !! 6 + dat = idat idt +{- --- + dec = decompress dat + recomp = compressWith defaultCompressParams { + compressLevel = bestCompression, +-- compressLevel = bestSpeed, + compressWindowBits = WindowBits 15 + } dec +{- + print $ length dat + print $ length recomp +-} -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'') + let chank6 = chanks png !! 6 + newDat = chank6 { + chankSize = fromIntegral $ BSL.length recomp, + chankData = ChankIDAT $ IDAT recomp, + chankCRC = crc $ "IDAT" ++ BSL.unpack recomp + } + new = png { + chanks = take 6 (chanks png) ++ [newDat] ++ + drop 7 (chanks png) + } +{- + print new +-} + print $ dat == recomp +--- -} + +-- BS.writeFile fout $ toBinary () new + + let dat = makeData png + decomp = decompress dat + recomp = compressWith defaultCompressParams { + compressLevel = bestCompression, +-- compressLevel = bestSpeed, + compressWindowBits = WindowBits 10 + } decomp + newData = makeDataChank recomp + newnew = png { + chanks = headerChanks png ++ newData ++ + footerChanks png + } +{- + newnew = png { + chanks = head (chanks png) : newData ++ + [last $ chanks png] + } +-} + BS.writeFile fout $ toBinary () newnew + print $ dat == recomp + +headerChanks :: PNG -> [Chank] +headerChanks PNG{ chanks = cs } = + filter ((`notElem` ["IEND", "IDAT"]) . chankName) cs + +footerChanks :: PNG -> [Chank] +footerChanks PNG{ chanks = cs } = filter ((== "IEND") . chankName) cs + +makeData :: PNG -> BSL.ByteString +makeData PNG{ chanks = cs } = + BSL.concat $ map (idat . cidat . chankData) $ + filter ((== "IDAT") . chankName) cs + +makeDataChank :: BSL.ByteString -> [Chank] +makeDataChank = map makeOneDataChank . BSL.toChunks + +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 + } + +test :: IO PNG +test = fst . fromBinary () <$> readBinaryFile "tmp/sample.png" + [binary| PNG @@ -47,6 +116,38 @@ |] +[binary| + +Chank + +4: chankSize +((), Just 4): chankName +(chankSize, chankName): chankData +4:chankCRC + +|] + +instance Field Word32 where + type FieldArgument Word32 = Int + toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral + fromBinary n s = (fromIntegral $ toIntgr $ BSL.reverse t, d) + where + (t, d) = getBytes n s + +instance Field BSL.ByteString where + type FieldArgument BSL.ByteString = Int + toBinary _ = makeBinary -- . BS.concat . BSL.toChunks + fromBinary n s = (t, d) -- (BSL.fromChunks [t], d) + where + (t, d) = getBytes n s + +toIntgr :: BSL.ByteString -> Integer +toIntgr = mkNum . map fromIntegral . BSL.unpack + +mkNum :: [Integer] -> Integer +mkNum [] = 0 +mkNum (x : xs) = x + 2 ^ 8 * mkNum xs + data ChankBody = ChankIHDR IHDR | ChankGAMA GAMA @@ -54,59 +155,47 @@ | ChankCHRM CHRM | ChankPLTE PLTE | ChankBKGD BKGD - | ChankIDAT IDAT + | ChankIDAT { cidat :: 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 +instance Field ChankBody where + type FieldArgument ChankBody = (Int, String) + toBinary _ (ChankIHDR ihdr) = toBinary () ihdr + toBinary _ (ChankGAMA gama) = toBinary () gama + toBinary _ (ChankSRGB srgb) = toBinary () srgb + toBinary (n, _) (ChankCHRM chrm) = toBinary n chrm + toBinary (n, _) (ChankPLTE plte) = toBinary n plte + toBinary _ (ChankBKGD bkgd) = toBinary () bkgd + toBinary (n, _) (ChankIDAT idat) = toBinary n idat + toBinary (n, _) (ChankTEXT text) = toBinary n text + toBinary _ (ChankIEND iend) = toBinary () iend + toBinary (n, _) (Others str) = toBinary ((), Just n) str + fromBinary (_, "IHDR") str = let (ihdr, rest) = fromBinary () str in (ChankIHDR ihdr, rest) - toType (_, "gAMA") str = let (gama, rest) = readGAMA () str in + fromBinary (_, "gAMA") str = let (gama, rest) = fromBinary () str in (ChankGAMA gama, rest) - toType (_, "sRGB") str = let (srgb, rest) = readSRGB () str in + fromBinary (_, "sRGB") str = let (srgb, rest) = fromBinary () str in (ChankSRGB srgb, rest) - toType (_, "cHRM") str = let (chrm, rest) = readCHRM () str in + fromBinary (n, "cHRM") str = let (chrm, rest) = fromBinary n str in (ChankCHRM chrm, rest) - toType (n, "PLTE") str = let (plte, rest) = readPLTE n str in + fromBinary (n, "PLTE") str = let (plte, rest) = fromBinary n str in (ChankPLTE plte, rest) - toType (_, "bKGD") str = let (bkgd, rest) = readBKGD () str in + fromBinary (_, "bKGD") str = let (bkgd, rest) = fromBinary () str in (ChankBKGD bkgd, rest) - toType (n, "IDAT") str = let (idat, rest) = readIDAT n str in + fromBinary (n, "IDAT") str = let (idat, rest) = fromBinary n str in (ChankIDAT idat, rest) - toType (n, "tEXt") str = let (text, rest) = readTEXT n str in + fromBinary (n, "tEXt") str = let (text, rest) = fromBinary n str in (ChankTEXT text, rest) - toType (_, "IEND") str = let (iend, rest) = readIEND () str in + fromBinary (_, "IEND") str = let (iend, rest) = fromBinary () str in (ChankIEND iend, rest) - toType (n, _) str = let (others, rest) = toType ((), Just n) str in + fromBinary (n, _) str = let (others, rest) = fromBinary ((), Just n) str in (Others others, rest) [binary| -Chank - -4: chankSize -((), Just 4): chankName -(chankSize, chankName): chankData --- ((), Just chankSize): chankData -4:chankCRC - -|] - -[binary| - IHDR 4: width @@ -139,15 +228,10 @@ CHRM -4: chrm1 -4: chrm2 -4: chrm3 -4: chrm4 -4: chrm5 -4: chrm6 -4: chrm7 -4: chrm8 + +(4, Just (arg `div` 4))<[Int]>: chrms + |] [binary| @@ -160,6 +244,15 @@ |] +instance Field (Int, Int, Int) where + type FieldArgument (Int, Int, Int) = () + toBinary _ (b, g, r) = concatBinary [toBinary 1 b, toBinary 1 g, toBinary 1 r] + fromBinary _ s = let + (b, rest) = fromBinary 1 s + (g, rest') = fromBinary 1 rest + (r, rest'') = fromBinary 1 rest' in + ((b, g, r), rest'') + [binary| BKGD @@ -174,7 +267,8 @@ -arg: idat +arg: idat +--((), Just arg): idat |] @@ -188,8 +282,4 @@ |] -[binary| - -IEND - -|] +[binary|IEND|] diff --git a/src/Classes.hs b/src/Classes.hs --- a/src/Classes.hs +++ b/src/Classes.hs @@ -1,20 +1,23 @@ {-# LANGUAGE - TemplateHaskell, TypeSynonymInstances, FlexibleInstances, TypeFamilies, OverloadedStrings #-} module Classes ( - RetType(..), - Str(..), - fii, fiiBE, - tii, tiiBE, - readInt + Field(..), + Binary(..), + fii, tii, + readInt, + dp, fs, ti, cc, + lintToBin ) where import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Char +import Control.Arrow data Endian = BigEndian | LittleEndian deriving Show @@ -23,85 +26,82 @@ 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 - toType :: Str s => Argument r -> s -> (r, s) +class Field r where + type FieldArgument r + fromBinary :: Binary s => FieldArgument r -> s -> (r, s) + toBinary :: Binary s => FieldArgument r -> 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 +instance Field r => Field [r] where + type FieldArgument [r] = (FieldArgument r, Maybe Int) + fromBinary (a, Just b) s = (b `times` fromBinary a) s + fromBinary (a, Nothing) s = whole (fromBinary a) s + toBinary (a, _) rs = cc $ map (toBinary a) rs -instance RetType Char where - type Argument Char = () - fromType _ = fs . (: []) - toType _ str = (head $ ts str, dp 1 str) +instance Field Char where + type FieldArgument Char = () + fromBinary _ str = (head $ BSLC.unpack t, d) + where + (t, d) = getBytes 1 str + toBinary _ = fs . (: []) -instance RetType BS.ByteString where - type Argument BS.ByteString = Int - fromType _ = fbs - toType n str = (tbs $ tk n str, dp n str) +instance Field BS.ByteString where + type FieldArgument BS.ByteString = Int + fromBinary n str = + first (BS.concat . BSL.toChunks) $ getBytes n str + toBinary _ = makeBinary . BSL.fromChunks . (: []) -class 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 +class Binary a where + getBytes :: Int -> a -> (BSL.ByteString, a) + makeBinary :: BSL.ByteString -> a + concatBinary :: [a] -> a + emptyBinary :: a -> Bool -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 +empty :: Binary a => a -> Bool +empty = emptyBinary -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) +cc :: Binary a => [a] -> a +cc = concatBinary -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 +ti :: Binary a => a -> Integer +ti = readInt LittleEndian . BSLC.unpack . fst . getBytes 100 +fs :: Binary a => String -> a +fs = makeBinary . BSLC.pack + +dp :: Binary a => Int -> a -> a +dp n = snd . getBytes n + +instance Binary String where + getBytes n = BSLC.pack . take n &&& drop n + makeBinary = BSLC.unpack + + concatBinary = concat + emptyBinary = null + +fii :: Binary a => Int -> Int -> a +fii n = makeBinary . BSLC.pack . intToBin LittleEndian n . fromIntegral +tii :: Binary a => Int -> a -> (Int, a) +tii _ str = let + (t, d) = getBytes 4 str in + (fromIntegral $ ti t, d) + +instance Binary BSL.ByteString where + getBytes n = BSL.take (fromIntegral n) &&& BSL.drop (fromIntegral n) + makeBinary = id + + concatBinary = BSL.concat + emptyBinary = (== 0) . BSL.length + +instance Binary BS.ByteString where + getBytes n = BSL.fromChunks . (: []) . BS.take n &&& BS.drop n + makeBinary = BS.concat . BSL.toChunks + + concatBinary = BS.concat + emptyBinary = (== 0) . BS.length + +lintToBin :: Int -> Integer -> String +lintToBin = intToBin LittleEndian + intToBin :: Endian -> Int -> Integer -> String intToBin LittleEndian 0 _ = "" intToBin LittleEndian n x = chr (fromIntegral $ x `mod` 256) : @@ -115,7 +115,7 @@ (rets, rest') = times (n - 1) f rest in (ret : rets, rest') -whole :: Str s => (s -> (ret, s)) -> s -> ([ret], s) +whole :: Binary s => (s -> (ret, s)) -> s -> ([ret], s) whole f s | empty s = ([], s) | otherwise = let diff --git a/src/File/Binary.hs b/src/File/Binary.hs --- a/src/File/Binary.hs +++ b/src/File/Binary.hs @@ -2,10 +2,10 @@ readBinaryFile, writeBinaryFile, binary, - RetType(..), - Str(..), - tii, tiiBE, - fii, fiiBE + Field(..), + Binary(..), + tii, -- tiiBE, + fii, -- fiiBE -- times ) where diff --git a/src/File/Binary/Data/BigEndian.hs b/src/File/Binary/Data/BigEndian.hs --- a/src/File/Binary/Data/BigEndian.hs +++ b/src/File/Binary/Data/BigEndian.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -module File.Binary.Data.BigEndian where +module File.Binary.Data.BigEndian ( + lintToBin +) where import Classes +import qualified Data.ByteString.Lazy.Char8 as BSLC -- 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) +instance Field Int where + type FieldArgument Int = Int + fromBinary n s = (fromIntegral $ ti $ BSLC.reverse $ fst $ getBytes n s, dp n s) + toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral diff --git a/src/File/Binary/Data/LittleEndian.hs b/src/File/Binary/Data/LittleEndian.hs --- a/src/File/Binary/Data/LittleEndian.hs +++ b/src/File/Binary/Data/LittleEndian.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module File.Binary.Data.LittleEndian where import Classes +import qualified Data.ByteString.Lazy.Char8 as BSLC -- 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) +instance Field Int where + type FieldArgument Int = Int + fromBinary n s = (fromIntegral $ ti t, d) + where + (t, d) = getBytes n s + toBinary n = makeBinary . BSLC.pack . reverse . lintToBin n . fromIntegral diff --git a/src/ParseBinaryStructure.hs b/src/ParseBinaryStructure.hs --- a/src/ParseBinaryStructure.hs +++ b/src/ParseBinaryStructure.hs @@ -20,10 +20,11 @@ valueOf, Expression, - Str(..), - RetType(..), - fii, fiiBE, - tii, tiiBE + Binary(..), + Field(..), + fii, -- fiiBE, + tii, -- tiiBE, + dp, fs, cc ) where import Text.Peggy diff --git a/src/QuoteBinaryStructure.hs b/src/QuoteBinaryStructure.hs --- a/src/QuoteBinaryStructure.hs +++ b/src/QuoteBinaryStructure.hs @@ -7,10 +7,10 @@ module QuoteBinaryStructure ( binary, - RetType(..), - Str(..), - fii, fiiBE, - tii, tiiBE, + Field(..), + Binary(..), + fii, -- fiiBE, + tii, -- tiiBE, times ) where @@ -21,6 +21,7 @@ import Data.Traversable hiding (mapM) import Data.Either import Data.Maybe +import qualified Data.ByteString.Lazy.Char8 as BSLC import ParseBinaryStructure @@ -35,20 +36,28 @@ mkHaskellTree :: BinaryStructure -> DecsQ mkHaskellTree bs = do d <- mkData bsn body - r <- mkReader bsn body - w <- mkWriter bsn body - return $ d ++ [r, w] + i <- mkInst bsn typ body + return $ d ++ [i] where bsn = binaryStructureName bs + typ = binaryStructureArgType bs body = binaryStructureBody bs -mkWriter :: String -> [BinaryStructureItem] -> DecQ -mkWriter bsn body = do +mkInst :: String -> TypeQ -> [BinaryStructureItem] -> DecQ +mkInst bsn typ body = + instanceD (cxt []) (appT (conT ''Field) (conT $ mkName bsn)) [ + tySynInstD ''FieldArgument [conT $ mkName bsn] typ, + reading "fromBinary" bsn body, + writing "toBinary" body + ] + +writing :: String -> [BinaryStructureItem] -> DecQ +writing name body = do arg <- newName "arg" bs <- newName "bs" let run = appE (varE 'cc) $ listE $ map (\bsi -> writeField bs arg (bytesOf bsi) (valueOf bsi)) body - funD (mkName $ "write" ++ bsn) + funD (mkName name) [clause [varP arg, varP bs] (normalB run) []] writeField :: Name -> Name -> Expression -> Either (Either Int String) String -> ExpQ @@ -56,7 +65,7 @@ appsE [fiend', expression bs arg size, sigE (litE $ integerL $ fromIntegral n) (conT ''Int)] where - fiend' = varE 'fromType + fiend' = varE 'toBinary writeField _ _ _ (Left (Right s)) = appsE [varE 'fs, litE $ stringL s] writeField bs arg bytes (Right v) = @@ -64,19 +73,18 @@ fieldValueToStr :: Name -> Name -> Expression -> Bool -> ExpQ -> ExpQ fieldValueToStr bs arg size False = - appE $ appE (varE 'fromType) (expression bs arg size) + appE $ appE (varE 'toBinary) (expression bs arg size) fieldValueToStr bs arg size True = \val -> appE (varE 'cc) $ appsE [ - varE 'map, appE (varE 'fromType) (expression bs arg size), val] + varE 'map, appE (varE 'toBinary) (expression bs arg size), val] -mkReader :: String -> [BinaryStructureItem] -> DecQ -mkReader bsn body = do +reading :: String -> String -> [BinaryStructureItem] -> DecQ +reading name bsn body = do arg <- newName "arg" cs <- newName "cs" ret <- newName "ret" - funD (mkName $ "read" ++ bsn) - [clause [varP arg, varP cs] (normalB $ mkLetRec ret $ - mkBody bsn arg body cs) []] + funD (mkName name) [clause [varP arg, varP cs] + (normalB $ mkLetRec ret $ mkBody bsn arg body cs) []] mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ mkLetRec n f = do @@ -97,10 +105,11 @@ mkDef np item cs' | Left (Left val) <- valueOf item = do cs'' <- newName "cs" - let t = dropE' n $ varE cs' - let p = val `equal` appE (varE 'fst) - (appE (appE (varE 'toType) arg') $ takeE' n $ varE cs') - let e = [e| error "bad value" |] + let t = dropE' n $ varE cs' + p = val `equal` appE (varE 'fst) + (appE (appE (varE 'fromBinary) arg') $ + takeE' n $ varE cs') + e = [e| error "bad value" |] d <- valD (varP cs'') (normalB $ condE p t e) [] return ([d], cs'') | Left (Right val) <- valueOf item = do @@ -113,7 +122,7 @@ | 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 'fromBinary) arg') $ varE cs') [] return ([def], cs'') | otherwise = error "bad" where @@ -134,7 +143,8 @@ 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' n xs = -- appE (varE 'ts) $ appsE [varE 'tk, n, xs] + appE (varE 'BSLC.unpack) $ appE (varE 'fst) $ appsE [varE 'getBytes, n, xs] dropE' :: ExpQ -> ExpQ -> ExpQ dropE' n xs = appsE [varE 'dp, n, xs] @@ -148,10 +158,10 @@ mkInstance :: String -> DecQ mkInstance name = - instanceD (cxt []) (appT (conT ''RetType) (conT $ mkName name)) [ - valD (varP $ 'fromType) + instanceD (cxt []) (appT (conT ''Field) (conT $ mkName name)) [ + valD (varP $ 'toBinary) (normalB $ varE $ mkName $ "write" ++ name) [], - valD (varP $ 'toType) + valD (varP $ 'fromBinary) (normalB $ varE $ mkName $ "read" ++ name) [] ]