packages feed

binary-file 0.15.16 → 0.15.18

raw patch · 9 files changed

+126/−77 lines, 9 files

Files

binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.15.16+version:	0.15.18 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -35,14 +35,16 @@     >     > 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), snd $ getBytes 1 1 rest'')-    >    toBinary _ (b, g, r) = concatBinary [-    >        fromType 1 b, fromType 1 g, fromType 1 r,-    >        makeBinary $ BSL.singleton 0]+    >    fromBinary _ s = do+    >        (b, rest) <- fromBinary 1 s+    >        (g, rest') <- fromBinary 1 rest+    >        (r, rest'') <- fromBinary 1 rest' in+    >        return ((b, g, r), snd $ getBytes 1 1 rest'')+    >    toBinary _ (b, g, r) = do+    >        b' <- toBinary 1 b+    >        g' <- toBinary 1 g+    >        r' <- toBinary 1 r+    >        return $ concatBinary [b', g', r', makeBinary $ BSL.singleton 0]     >     > [binary|     >@@ -90,7 +92,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git-    tag:	0.15.16+    tag:	0.15.18  library     hs-source-dirs:	src
examples/readBitmap.hs view
@@ -24,7 +24,9 @@ 	return bmp  writeBitmap :: FilePath -> Bitmap -> IO ()-writeBitmap fp = writeBinaryFile fp . toBinary ()+writeBitmap fp bmp = do+	let Right bin = toBinary () bmp+	writeBinaryFile fp bin  instance Field (Int, Int, Int) where 	type FieldArgument (Int, Int, Int) = ()@@ -33,12 +35,11 @@ 		(g, rest') <- fromBinary 1 rest 		(r, rest'') <- fromBinary 1 rest' 		return ((b, g, r), snd $ getBytes 1 rest'')-	toBinary _ (b, g, r) = mconcat [-		toBinary 1 b,-		toBinary 1 g,-		toBinary 1 r,-		makeBinary $ singleton 0-	 ]+	toBinary _ (b, g, r) = do+		b' <- toBinary 1 b+		g' <- toBinary 1 g+		r' <- toBinary 1 r+		return $ mconcat [b', g', r', makeBinary $ singleton 0]  [binary|
examples/readPNG.hs view
@@ -47,7 +47,9 @@ 	return png  writePNG :: FilePath -> PNG -> IO ()-writePNG fout = BS.writeFile fout . toBinary ()+writePNG fout png = do+	let Right cnt = toBinary () png+	BS.writeFile fout cnt  header :: PNG -> [Chunk] header PNG{ chunks = cs } =@@ -191,7 +193,11 @@  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) = do+		b' <- toBinary 1 b+		g' <- toBinary 1 g+		r' <- toBinary 1 r+		return $ mconcat [b', g', r'] 	fromBinary _ s = do 		(r, rest) <- fromBinary 1 s 		(g, rest') <- fromBinary 1 rest
src/File/Binary/Classes.hs view
@@ -9,29 +9,36 @@ import Data.Word import Control.Arrow (first, second) import Control.Applicative+import Control.Monad  type AddBits b = ([Bool], b)  class Field f where 	type FieldArgument f-	fromBinary :: Binary b => FieldArgument f -> b -> Either String (f, b)-	toBinary :: Binary b => FieldArgument f -> f -> b-	fromBits :: Binary b => FieldArgument f -> AddBits b -> Either String (f, AddBits b)-	consToBits :: Binary b => FieldArgument f -> f -> AddBits b -> AddBits b+	fromBinary :: (Binary b, Functor m, Monad m) => FieldArgument f -> b -> m (f, b)+	toBinary :: (Binary b, Functor m, Monad m) => FieldArgument f -> f -> m b+	fromBits :: (Binary b, Functor m, Monad m) =>+		FieldArgument f -> AddBits b -> m (f, AddBits b)+	consToBits :: (Binary b, Functor m, Monad m) =>+		FieldArgument f -> f -> AddBits b -> m (AddBits b) -	fromBits a ([], b) = second ([] ,) <$> fromBinary a b+	fromBits a ([], b) = second ([] ,) `liftM` 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)"+	consToBits a f ([], b) = do+		ret <- (`mappend` b) <$> toBinary a f+		return ([], ret)+	consToBits _ _ _ = fail "consToBits: not bytes (1 byte = 8 bits)"  	fromBinary a b = do 		ret <- fromBits a ([], b) 		case ret of 			(f, ([], rest)) -> return (f, rest)-			_ -> Left "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)"+			_ -> fail "fromBinary: not bytes (1 byte = 8 bits)"+	toBinary a f = do+		ret <- consToBits a f ([], mempty)+		case ret of+			([], bin) -> return bin+			_ -> fail "toBinary: not bytes (1 byte = 8 bits)"  pop :: Binary b => b -> AddBits b pop = first (wtbs (8 :: Int) . head . unpack) . getBytes 1
src/File/Binary/Instances.hs view
@@ -16,7 +16,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, unpack) import qualified Data.ByteString as BS (ByteString, take, drop, concat, uncons, span) import qualified Data.ByteString.Char8 ()-import Control.Monad (replicateM)+import Control.Monad (replicateM, foldM) import "monads-tf" Control.Monad.State (StateT(..), gets) import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, (&&&))@@ -29,28 +29,28 @@ instance Field ByteString where 	type FieldArgument ByteString = Int 	fromBinary a = return . getBytes a-	toBinary _ = makeBinary+	toBinary _ = return . makeBinary  instance Field BS.ByteString where 	type FieldArgument BS.ByteString = Int 	fromBinary n = return . first (BS.concat . toChunks) . getBytes n-	toBinary _ = makeBinary . fromChunks . (: [])+	toBinary _ = return . makeBinary . fromChunks . (: [])  instance Field Char where 	type FieldArgument Char = () 	fromBinary _ = return . first (head . BSLC.unpack) . getBytes 1-	toBinary _ = makeBinary . BSLC.pack . (: [])+	toBinary _ = return . makeBinary . BSLC.pack . (: [])  instance Field Word8 where 	type FieldArgument Word8 = () 	fromBinary _ = return . first (head . unpack) . getBytes 1-	toBinary _ = makeBinary . pack . (: [])+	toBinary _ = return . makeBinary . pack . (: [])  instance Field r => Field [r] where 	type FieldArgument [r] = (FieldArgument r, Maybe Int) 	fromBits (a, Just b) = b `times` fromBits a 	fromBits (a, Nothing) = mempty `whole` fromBits a-	consToBits (a, _) = flip $ foldr $ consToBits a+	consToBits (a, _) fs ret = foldM (flip $ consToBits a) ret $ reverse fs  times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s) times n f = runStateT $ replicateM n (StateT f)
src/File/Binary/Instances/BigEndian.hs view
@@ -14,17 +14,17 @@ instance Field Integer where 	type FieldArgument Integer = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  instance Field Int where 	type FieldArgument Int = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  instance Field Word32 where 	type FieldArgument Word32 = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  wordsToInt :: (Num i, Bits i) => [Word8] -> i wordsToInt = foldl (\i w -> i `shiftL` 8 .|. fromIntegral w) 0@@ -40,11 +40,21 @@ 	fromBits () ([], bin) = fromBits () $ pop bin 	fromBits () (bs, bin) = return (last bs, (init bs, bin)) 	consToBits () b (bs, bin)-		| length bs == 7 = ([], push (bs ++ [b], bin))-		| otherwise = (bs ++ [b], bin)+		| length bs == 7 = return ([], push (bs ++ [b], bin))+		| otherwise = return (bs ++ [b], bin)  data BitsInt = BitsInt { bitsInt :: Int } deriving Show +instance Eq BitsInt where+	BitsInt i1 == BitsInt i2 = i1 == i2++instance Num BitsInt where+	BitsInt i1 + BitsInt i2 = BitsInt $ i1 + i2+	BitsInt i1 * BitsInt i2 = BitsInt $ i1 * i2+	abs (BitsInt i) = BitsInt $ abs i+	signum (BitsInt i) = BitsInt $ signum i+	fromInteger i = BitsInt $ fromInteger i+ instance Field BitsInt where 	type FieldArgument BitsInt = Int 	fromBits n = return . first BitsInt . fb n 0@@ -56,13 +66,14 @@ toEnum' :: (Enum e, Integral i) => i -> e toEnum' = toEnum . fromIntegral -fb :: (Bits f, Binary b) => Int -> f -> ([Bool], b) -> (f, ([Bool], b))+fb :: (Bits f, Num 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 :: (Bits f, Integral f, Binary b, Functor m, Monad m) =>+	Int -> f -> ([Bool], b) -> m ([Bool], b)+ctb 0 _ r = return 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)
src/File/Binary/Instances/LittleEndian.hs view
@@ -8,22 +8,22 @@ import Data.Word (Word8, Word32) import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR) import Control.Arrow (first)-import Control.Applicative+import Control.Monad  instance Field Int where 	type FieldArgument Int = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  instance Field Word32 where 	type FieldArgument Word32 = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  instance Field Integer where 	type FieldArgument Integer = Int 	fromBinary n = return . first (wordsToInt . unpack) . getBytes n-	toBinary n = makeBinary . pack . intToWords n+	toBinary n = return . makeBinary . pack . intToWords n  wordsToInt :: (Num i, Bits i) => [Word8] -> i wordsToInt = foldr (\w i -> fromIntegral w .|. i `shiftL` 8) 0@@ -37,21 +37,31 @@ 	fromBits () ([], bin) = fromBits () $ pop bin 	fromBits () (b : bs, bin) = return (b, (bs, bin)) 	consToBits () b (bs, bin)-		| length bs == 7 = ([], push (b : bs, bin))-		| otherwise = (b : bs, bin)+		| length bs == 7 = return ([], push (b : bs, bin))+		| otherwise = return (b : bs, bin) -data BitsInt = BitsInt { bitsInt :: Int } deriving Show+newtype BitsInt = BitsInt { bitsInt :: Int } deriving Show +instance Eq BitsInt where+	BitsInt i1 == BitsInt i2 = i1 == i2++instance Num BitsInt where+	BitsInt i1 + BitsInt i2 = BitsInt $ i1 + i2+	BitsInt i1 * BitsInt i2 = BitsInt $ i1 * i2+	abs (BitsInt i) = BitsInt $ abs i+	signum (BitsInt i) = BitsInt $ signum i+	fromInteger i = BitsInt $ fromInteger i+ instance Field BitsInt where 	type FieldArgument BitsInt = Int 	fromBits 0 bb = return (BitsInt 0, bb) 	fromBits n ([], bin) = fromBits n $ pop bin 	fromBits n (b : bs, bin) = first-		(BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) <$>+		(BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) `liftM` 		fromBits (n - 1) (bs, bin)-	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+	consToBits 0 _ bb = return bb+	consToBits n (BitsInt f) bb = do+		(bs, bin) <- consToBits (n - 1) (BitsInt $ f `shiftR` 1) bb+		return $ if length bs == 7 			then ([], push (toEnum (f .&. 1) : bs, bin)) 			else (toEnum (f .&. 1) : bs, bin)
src/File/Binary/Parse.hs view
@@ -13,7 +13,7 @@  module File.Binary.Parse ( 	parse, Structure, sName, sDerive, sArgName, sArgType, sItems,-	SItem, argOf, valueOf, constant, Value, expression+	SItem, argOf, valueOf, constant, Value, expression, rights' ) where  import Text.Peggy (peggy, parseString, space, defaultDelimiter)@@ -22,7 +22,7 @@ 	TypeQ, conT, listT, tupleT, appT, Name, mkName, FieldExp) import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Control.Applicative ((<$>), (<*>))-import Control.Arrow(second)+import Control.Arrow(first) import Data.Maybe (fromMaybe) import Numeric (readHex) @@ -41,10 +41,21 @@ data SItem = SItem { argOf :: Expression, valueOf :: Value } type Expression	= Reader ([FieldExp], ExpQ, String) ExpQ +rights' :: [Value] -> [(Name, TypeQ)]+rights' = map (first fromRight) . filter (isRight . fst)++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "not Right"++isRight :: Either a b -> Bool+isRight (Right x) = True+isRight _ = False+ expression :: [FieldExp] -> ExpQ -> String -> Expression -> ExpQ expression ret arg argn e = runReader e (ret, arg, argn) -type Value = Either Constant (Name, TypeQ)+type Value = (Either Constant Name, TypeQ)  data Constant = Integer Integer | String String | Bool Bool deriving Show @@ -54,6 +65,7 @@ constant _ _ f (Bool b) = f b  identify :: String -> ([FieldExp], ExpQ, String) -> ExpQ+-- identify "_" _ = wildP identify var (ret, arg, argn) 	| var == argn = arg 	| Just var' <- lookup (mkName var) ret = return var'@@ -74,13 +86,14 @@ 	/ ''				{ ("_", conT $ mkName "()") }  dat :: SItem = emp ex? sp typS sp ':' sp val-	{ SItem (fromMaybe (return $ conE $ mkName "()") $2) $-		either Left (Right . second (const $4)) $7 }+	{ SItem (fromMaybe (return $ conE $ mkName "()") $2) ($7, $4) }+--	{ SItem (fromMaybe (return $ conE $ mkName "()") $2) $+--		either Left (Right . second (const $4)) $7 }  typS :: TypeQ = '{' typ '}' / ''	{ conT $ mkName "Int" } -val :: Value-	= var				{ Right $ (mkName $1, conT $ mkName "()") }+val :: Either Constant Name+	= var				{ Right $ mkName $1 } 	/ num				{ Left $ Integer $1 } 	/ string			{ Left $ String $1 } 	/ 'True'			{ Left $ Bool True }@@ -137,7 +150,7 @@ 	/ 'SUB'						{ '\SUB' }  ln :: String = [A-Z][_a-zA-Z0-9]*			{ $1 : $2 }-sn :: String = [a-z][_a-zA-Z0-9]*			{ $1 : $2 }+sn :: String = [_a-z][_a-zA-Z0-9]*			{ $1 : $2 }  sp :: () = (comm / [ \t])*				{ () } emp :: () = (comm / lcomm / [ \n])*			{ () }
src/File/Binary/Quote.hs view
@@ -4,7 +4,7 @@  import File.Binary.Parse ( 	parse, Structure, sName, sDerive, sArgName, sArgType, sItems,-	SItem, argOf, valueOf, constant, Value, expression)+	SItem, argOf, valueOf, constant, Value, expression, rights') import File.Binary.Classes (Field(..), Binary(..)) import Language.Haskell.TH ( 	Q, DecsQ, ClauseQ, Clause, ExpQ, Exp(..), Name, FieldExp, StmtQ,@@ -15,11 +15,10 @@ 	doE, bindS, noBindS, letS, tildeP) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Data.ByteString.Lazy.Char8 (pack)-import Control.Monad (zipWithM)+import Control.Monad (zipWithM, foldM) import "monads-tf" Control.Monad.State (StateT, runStateT, get, put, lift) import "monads-tf" Control.Monad.Writer (WriterT, runWriterT, tell) import Control.Applicative ((<$>), (<*>))-import Data.Either (rights)  -------------------------------------------------------------------------------- @@ -34,7 +33,7 @@ 	(\d i -> [d, i]) 	    <$> dataD (cxt []) c [] [recC c $ 		map (varStrictType <$> fst <*> strictType notStrict . snd) $-			rights $ map valueOf $ sItems bs] (sDerive bs)+			rights' $ map valueOf $ sItems bs] (sDerive bs) 	    <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [ 		tySynInstD ''FieldArgument [conT c] $ sArgType bs, 		funD 'fromBits $ (: []) $ return r,@@ -69,23 +68,23 @@ liftW = lift  readf' :: ([FieldExp] -> ExpQ) -> Value -> FieldMonad [StmtQ]-readf' size (Left val) = do+readf' size (Left val, typ) = do 	(bin, rts2) <- get 	[rv, rest, bin'] <- liftQ $ mapM newName ["_rv", "_rst", "_bin'"] 	put (varE bin', rts2) 	let lit = constant-		((`sigE` conT ''Integer) . litE . integerL)+		((`sigE` typ) . litE . integerL) 		(appE (varE 'pack) . litE . stringL) 		(\b -> conE (if b then 'True else 'False)) 		val 	return [bindS (tupP [varP rv, varP rest]) 				(appsE [varE 'fromBits, size rts2, bin]), 		noBindS $ condE (infixApp (varE rv) (varE '(==)) lit) [e| return () |]-			[e| Left "bad value" |],+			[e| fail "bad value" |], 		letS [flip (valD $ varP bin') [] $ normalB $ 		condE (infixApp (varE rv) (varE '(==)) lit) (varE rest) 			[e| error "bad value" |]]]-readf' size (Right (var, _)) = do+readf' size (Right var, _) = do 	(bin, rts2) <- get 	[bin', tmp] <- liftQ $ mapM newName ["_bin'", "_tmp"] 	put (varE bin', (var, VarE tmp) : rts2)@@ -98,16 +97,16 @@ 	[arg, dat, bin0] <- mapM newName ["_arg", "_dat", "bin0"] 	let fe' = map ((\n -> (n, VarE n `AppE` VarE dat)) . fst) fe 	flip (clause [varP arg, varP dat, varP bin0]) [] $ normalB $-		appE (appsE [varE 'foldr, varE '($), varE bin0]) $ listE $-			(<$> items) $ writef dat+		appE (appsE [varE 'foldM, varE 'flip `appE` varE '($), varE bin0]) $+			(varE 'reverse `appE`) $ listE $ (<$> items) $ writef dat 				<$> expression fe' (varE arg) argn . argOf 				<*> valueOf  writef :: Name -> ExpQ -> Value -> ExpQ-writef _ size (Left val) = varE 'consToBits `appE` size `appE` constant-	((`sigE` conT ''Integer) . litE . integerL)+writef _ size (Left val, typ) = varE 'consToBits `appE` size `appE` constant+	((`sigE` typ) . litE . integerL) 	(appE (varE 'pack) . litE . stringL) 	(\b -> conE (if b then 'True else 'False)) 	val-writef dat size (Right (rec, _)) =+writef dat size (Right rec, _) = 	varE 'consToBits `appE` size `appE` (varE rec `appE` varE dat)