packages feed

binary-file 0.15.0 → 0.15.9

raw patch · 9 files changed

+118/−101 lines, 9 files

Files

binary-file.cabal view
@@ -2,10 +2,11 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.15.0+version:	0.15.9 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://skami.iocikun.jp/haskell/packages/binary-file  license:	BSD3 license-file:	LICENSE@@ -29,7 +30,7 @@     > main = do     >	[inf] <- getArgs     >   cnt <- BS.readFile inf-    >	let (bmp, rest) = fromBinary () cnt :: (Bitmap, String)+    >	let Right (bmp, rest) = fromBinary () cnt :: (Bitmap, String)     >	print bmp     >     > instance Field (Int, Int, Int) where@@ -89,7 +90,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git-    tag:	0.15.0+    tag:	0.15.9  library     hs-source-dirs:	src
examples/readBitmap.hs view
@@ -20,7 +20,7 @@  readBitmap :: FilePath -> IO Bitmap readBitmap fp = do-	(bmp, "") <- fromBinary () <$> readBinaryFile fp+	Right (bmp, "") <- fromBinary () <$> readBinaryFile fp 	return bmp  writeBitmap :: FilePath -> Bitmap -> IO ()@@ -28,11 +28,11 @@  instance Field (Int, Int, Int) where 	type FieldArgument (Int, Int, Int) = ()-	fromBinary _ s = let-		(b, rest) = fromBinary 1 s-		(g, rest') = fromBinary 1 rest-		(r, rest'') = fromBinary 1 rest' in-		((b, g, r), snd $ getBytes 1 rest'')+	fromBinary _ s = do+		(b, rest) <- fromBinary 1 s+		(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,
examples/readPNG.hs view
@@ -44,7 +44,7 @@  readPNG :: FilePath -> IO PNG readPNG fp = do-	(png, "") <- fromBinary () <$> BS.readFile fp+	Right (png, "") <- fromBinary () <$> BS.readFile fp 	return png  writePNG :: FilePath -> PNG -> IO ()@@ -98,7 +98,7 @@ instance Field Word32 where 	type FieldArgument Word32 = Int 	toBinary n = makeBinary . pack . intToWords n-	fromBinary n = first (wordsToInt . unpack) . getBytes n+	fromBinary n = return . first (wordsToInt . unpack) . getBytes n  intToWords :: (Bits i, Integral i) => Int -> i -> [Word8] intToWords = itw []@@ -134,16 +134,16 @@ 	toBinary (n, _) (ChunkTEXT c) = toBinary n c 	toBinary _ (ChunkIEND c) = toBinary () c 	toBinary (n, _) (Others str) = toBinary ((), Just n) str-	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)+	fromBinary (_, "IHDR") = fmap (first ChunkIHDR) . fromBinary ()+	fromBinary (_, "gAMA") = fmap (first ChunkGAMA) . fromBinary ()+	fromBinary (_, "sRGB") = fmap (first ChunkSRGB) . fromBinary ()+	fromBinary (n, "cHRM") = fmap (first ChunkCHRM) . fromBinary n+	fromBinary (n, "PLTE") = fmap (first ChunkPLTE) . fromBinary n+	fromBinary (_, "bKGD") = fmap (first ChunkBKGD) . fromBinary ()+	fromBinary (n, "IDAT") = fmap (first ChunkIDAT) . fromBinary n+	fromBinary (n, "tEXt") = fmap (first ChunkTEXT) . fromBinary n+	fromBinary (_, "IEND") = fmap (first ChunkIEND) . fromBinary ()+	fromBinary (n, _) = fmap (first Others) . fromBinary ((), Just n)  [binary| @@ -207,11 +207,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]-	fromBinary _ s = let-		(r, rest) = fromBinary 1 s-		(g, rest') = fromBinary 1 rest-		(b, rest'') = fromBinary 1 rest' in-		((r, g, b), rest'')+	fromBinary _ s = do+		(r, rest) <- fromBinary 1 s+		(g, rest') <- fromBinary 1 rest+		(b, rest'') <- fromBinary 1 rest'+		return ((r, g, b), rest'')  [binary|
src/File/Binary/Classes.hs view
@@ -6,24 +6,27 @@ import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Monoid (Monoid, mappend, mempty) import Control.Arrow (first, second)+import Control.Applicative  type AddBits b = ([Bool], b)  class Field f where 	type FieldArgument f-	fromBinary :: Binary b => FieldArgument f -> b -> (f, b)+	fromBinary :: Binary b => FieldArgument f -> b -> Either String (f, b) 	toBinary :: Binary b => FieldArgument f -> f -> b-	fromBits :: Binary b => FieldArgument f -> AddBits b -> (f, AddBits b)+	fromBits :: Binary b => FieldArgument f -> AddBits b -> Either String (f, AddBits b) 	consToBits :: Binary b => FieldArgument f -> f -> AddBits b -> AddBits b -	fromBits a ([], b) = second ([] ,) $ fromBinary a 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)"+	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)"
src/File/Binary/Instances.hs view
@@ -9,8 +9,7 @@ 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 "monads-tf" Control.Monad.State (StateT(..), gets) import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, (&&&)) import Data.Monoid (mempty)@@ -19,17 +18,17 @@  instance Field ByteString where 	type FieldArgument ByteString = Int-	fromBinary = getBytes+	fromBinary a = return . getBytes a 	toBinary _ = makeBinary  instance Field BS.ByteString where 	type FieldArgument BS.ByteString = Int-	fromBinary n = first (BS.concat . toChunks) . getBytes n+	fromBinary n = return . first (BS.concat . toChunks) . getBytes n 	toBinary _ = makeBinary . fromChunks . (: [])  instance Field Char where 	type FieldArgument Char = ()-	fromBinary _ = first (head . unpack) . getBytes 1+	fromBinary _ = return . first (head . unpack) . getBytes 1 	toBinary _ = makeBinary . pack . (: [])  instance Field r => Field [r] where@@ -38,14 +37,14 @@ 	fromBits (a, Nothing) = mempty `whole` fromBits a 	consToBits (a, _) = flip $ foldr $ consToBits a -times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)-times n f = runState $ replicateM n (StateT $ Identity . f)+times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s)+times n f = runStateT $ replicateM n (StateT f) -whole :: Eq s => s -> (s -> (ret, s)) -> s -> ([ret], s)-whole e f = runState $ do+whole :: (Functor m, Monad m, Eq s) => s -> (s -> m (ret, s)) -> s -> m ([ret], s)+whole e f = runStateT $ do 	emp <- gets (== e) 	if emp then return [] else-		(:) <$> (StateT $ Identity . f) <*> (StateT $ Identity . whole e f)+		(:) <$> (StateT f) <*> (StateT $ whole e f)  --------------------------------------------------------------------------------
src/File/Binary/Instances/BigEndian.hs view
@@ -13,12 +13,12 @@  instance Field Integer where 	type FieldArgument Integer = Int-	fromBinary n = first (wordsToInt . unpack) . getBytes n+	fromBinary n = return . first (wordsToInt . unpack) . getBytes n 	toBinary n = makeBinary . pack . intToWords n  instance Field Int where 	type FieldArgument Int = Int-	fromBinary n = first (wordsToInt . unpack) . getBytes n+	fromBinary n = return . first (wordsToInt . unpack) . getBytes n 	toBinary n = makeBinary . pack . intToWords n  wordsToInt :: Bits i => [Word8] -> i@@ -33,7 +33,7 @@ instance Field Bool where 	type FieldArgument Bool = () 	fromBits () ([], bin) = fromBits () $ pop bin-	fromBits () (bs, bin) = (last bs, (init bs, 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)@@ -42,7 +42,7 @@  instance Field BitsInt where 	type FieldArgument BitsInt = Int-	fromBits n = first BitsInt . fb n 0+	fromBits n = return . first BitsInt . fb n 0 	consToBits n = ctb n . bitsInt  fromEnum' :: (Enum e, Num i) => e -> i
src/File/Binary/Instances/LittleEndian.hs view
@@ -8,15 +8,16 @@ import Data.Word (Word8) import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR) import Control.Arrow (first)+import Control.Applicative  instance Field Int where 	type FieldArgument Int = Int-	fromBinary n = first (wordsToInt . unpack) . getBytes n+	fromBinary n = return . first (wordsToInt . unpack) . getBytes n 	toBinary n = makeBinary . pack . intToWords n  instance Field Integer where 	type FieldArgument Integer = Int-	fromBinary n = first (wordsToInt . unpack) . getBytes n+	fromBinary n = return . first (wordsToInt . unpack) . getBytes n 	toBinary n = makeBinary . pack . intToWords n  wordsToInt :: Bits i => [Word8] -> i@@ -29,7 +30,7 @@ instance Field Bool where 	type FieldArgument Bool = () 	fromBits () ([], bin) = fromBits () $ pop bin-	fromBits () (b : bs, bin) = (b, (bs, bin))+	fromBits () (b : bs, bin) = return (b, (bs, bin)) 	consToBits () b (bs, bin) 		| length bs == 7 = ([], push ((b : bs), bin)) 		| otherwise = (b : bs, bin)@@ -38,10 +39,11 @@  instance Field BitsInt where 	type FieldArgument BitsInt = Int-	fromBits 0 bb = (BitsInt 0, bb)+	fromBits 0 bb = return (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+	fromBits n (b : bs, bin) = first+		(BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) <$>+		(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
src/File/Binary/Parse.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts, PackageImports #-}+{-# LANGUAGE+	TemplateHaskell,+	QuasiQuotes,+	FlexibleContexts,+	PackageImports,+	PatternGuards #-}  {-# OPTIONS_GHC 	-fno-warn-name-shadowing@@ -14,7 +19,7 @@ import Text.Peggy (peggy, parseString, space, defaultDelimiter) import Language.Haskell.TH ( 	ExpQ, integerL, litE, varE, conE, tupE, appE, uInfixE, parensE,-	TypeQ, conT, listT, tupleT, appT, Name, mkName)+	TypeQ, conT, listT, tupleT, appT, Name, mkName, FieldExp) import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Control.Applicative ((<$>), (<*>)) import Control.Arrow(second)@@ -34,9 +39,9 @@ 	sItems :: [SItem] }  data SItem = SItem { argOf :: Expression, valueOf :: Value }-type Expression	= Reader (ExpQ, ExpQ, String) ExpQ+type Expression	= Reader ([FieldExp], ExpQ, String) ExpQ -expression :: ExpQ -> ExpQ -> String -> Expression -> ExpQ+expression :: [FieldExp] -> ExpQ -> String -> Expression -> ExpQ expression ret arg argn e = runReader e (ret, arg, argn)  type Value = Either Constant (Name, TypeQ)@@ -48,11 +53,11 @@ constant _ f _ (String s) = f s constant _ _ f (Bool b) = f b -identify :: String -> (ExpQ, ExpQ, String) -> ExpQ+identify :: String -> ([FieldExp], ExpQ, String) -> ExpQ identify var (ret, arg, argn) 	| var == argn = arg-	| '.' `elem` var = varE $ mkName var-	| otherwise = appE (varE $ mkName var) ret+	| Just var' <- lookup (mkName var) ret = return var'+	| otherwise = varE $ mkName var  [peggy|
src/File/Binary/Quote.hs view
@@ -7,11 +7,12 @@ 	SItem, argOf, valueOf, constant, Value, expression) import File.Binary.Classes (Field(..), Binary(..)) import Language.Haskell.TH (-	Q, DecsQ, ClauseQ, BodyQ, ExpQ, Dec, Exp(..), Name, FieldExp,+	Q, DecsQ, ClauseQ, Clause, ExpQ, Exp(..), Name, FieldExp, StmtQ, 	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, conE, litE, newName, integerL, stringL)+	conT, appT, sigE, varP, tupP, condE, recConE, tupE, listE,+	appE, appsE, infixApp, varE, conE, litE, newName, integerL, stringL,+	doE, bindS, noBindS, letS, tildeP) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Data.ByteString.Lazy.Char8 (pack) import Control.Monad (zipWithM)@@ -28,35 +29,38 @@ 	quoteDec = top . parse }  top :: Structure -> DecsQ-top bs = let c = sName bs in (\d i -> [d, i])-	<$> dataD (cxt []) c [] [recC c $+top bs = let c = sName bs in do+	(r, fe) <- reading c (sArgName bs) (sItems bs)+	(\d i -> [d, i])+	    <$> dataD (cxt []) c [] [recC c $ 		map (varStrictType <$> fst <*> strictType notStrict . snd) $ 			rights $ map valueOf $ sItems bs] (sDerive bs)-	<*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [+	    <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [ 		tySynInstD ''FieldArgument [conT c] $ sArgType bs,-		funD 'fromBits $ (: []) $ reading c (sArgName bs) (sItems bs),-		funD 'consToBits $ (: []) $ writing (sArgName bs) (sItems bs)]+		funD 'fromBits $ (: []) $ return r,+		funD 'consToBits $ (: []) $ writing fe (sArgName bs) (sItems bs)] -reading :: Name -> String -> [SItem] -> ClauseQ-reading c argn is = do+reading :: Name -> String -> [SItem] -> Q (Clause, [FieldExp])+reading con argn is = do 	arg <- newName "_arg" 	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) -> 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]+	(r, fe) <- readfs' con is (varE b)+		(\ret -> expression ret (varE arg) argn . argOf) undefined+	c <- flip (clause [varP arg, varP b]) [] $ normalB $ return r+	return (c, fe) -readfs :: Name -> [SItem] -> ExpQ -> (ExpQ -> SItem -> ExpQ) -> ExpQ -> ExpQ-readfs con items bin size ret = do-	((binds, rest), rts) <- runWriterT $ (`runStateT` bin) $-		(zipWithM readf <$> map (size ret) <*> map valueOf) items-	letE (return <$> binds) $ tupE $ (: [rest]) $ recConE con $ return <$> rts+readfs' :: Name -> [SItem] -> ExpQ -> ([FieldExp] -> SItem -> ExpQ) -> ExpQ ->+	Q (Exp, [FieldExp])+readfs' con items bin size _ = do+	((binds, (rest, rts2)), rts) <- runWriterT $ (`runStateT` (bin, [])) $+		(zipWithM readf' <$> map (flip size) <*> map valueOf) items+--	let binds' = map (uncurry bindS) binds+	l <- doE $ concat binds ++ [noBindS $+		appE (varE 'return) $ tupE $ (: [rest]) $ recConE con $+			return <$> rts ]+	return (l, rts2) -type FieldMonad = StateT ExpQ (WriterT [FieldExp] Q)+type FieldMonad = StateT (ExpQ, [FieldExp]) (WriterT [FieldExp] Q)  liftQ :: Q a -> FieldMonad a liftQ = lift . lift@@ -64,36 +68,39 @@ liftW :: WriterT [FieldExp] Q a -> FieldMonad a liftW = lift -readf :: ExpQ -> Value -> FieldMonad Dec-readf size (Left val) = do-	bin <- get-	[rv, rest, bin'] <- liftQ $ mapM newName ["rv", "rst", "bin'"]-	put $ varE bin'+readf' :: ([FieldExp] -> ExpQ) -> Value -> FieldMonad [StmtQ]+readf' size (Left val) = 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) 		(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 'fromBits, size, bin]] $+	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" |],+		letS [flip (valD $ varP bin') [] $ normalB $ 		condE (infixApp (varE rv) (varE '(==)) lit) (varE rest)-			[e| error "bad value" |]-readf size (Right (var, _)) = do-	bin <- get-	[bin', tmp] <- liftQ $ mapM newName ["bin'", "tmp"]-	put $ varE bin'+			[e| error "bad value" |]]]+readf' size (Right (var, _)) = do+	(bin, rts2) <- get+	[bin', tmp] <- liftQ $ mapM newName ["_bin'", "_tmp"]+	put $ (varE bin', (var, VarE tmp) : rts2) 	liftW $ tell [(var, VarE tmp)]-	liftQ $ valD (tupP [varP tmp, varP bin'])-		(normalB $ appsE [varE 'fromBits, size, bin]) []+	return [bindS (tildeP $ tupP [varP tmp, varP bin']) $+		appsE [varE 'fromBits, size rts2, bin]] -writing :: String -> [SItem] -> ClauseQ-writing argn items = do+writing :: [FieldExp] -> String -> [SItem] -> ClauseQ+writing fe argn items = do 	[arg, dat, bin0] <- mapM newName ["_arg", "_dat", "bin0"]+	let fe' = map (\n -> (n, VarE n `AppE` VarE dat)) $ map fst fe 	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+				<$> expression fe' (varE arg) argn . argOf 				<*> valueOf  writef :: Name -> ExpQ -> Value -> ExpQ