packages feed

binary-file 0.13.1 → 0.13.2

raw patch · 4 files changed

+70/−55 lines, 4 filesdep +monads-tfPVP ok

version bump matches the API change (PVP)

Dependencies added: monads-tf

API changes (from Hackage documentation)

Files

binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.13.1+version:	0.13.2 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -14,6 +14,8 @@ synopsis:	read/write binary file description: +    See example directory's sample code.+    .     > runghc -XQuasiQuotes -XTypeFamilies -XFlexibleInstances exam.hs some.bmp     .     exam.hs:@@ -76,7 +78,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/binary-file.git-    tag:	0.13.1+    tag:	0.13.2  library     hs-source-dirs:	src@@ -84,5 +86,6 @@         File.Binary.Data.LittleEndian,         File.Binary.Data.BigEndian     other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Classes-    build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring+    build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring,+        monads-tf     ghc-options:	-Wall
examples/readPNG.hs view
@@ -228,7 +228,7 @@  CHRM -<Int>+arg :: Int  (4, Just (arg `div` 4))<[Int]>: chrms @@ -238,7 +238,7 @@  PLTE -<Int>+arg :: Int  ((), Just (arg `div` 3))<[(Int, Int, Int)]>: colors @@ -265,7 +265,7 @@  IDAT -<Int>+arg :: Int  arg<BSL.ByteString>: idat --((), Just arg)<String>: idat@@ -276,7 +276,7 @@  TEXT -<Int>+arg :: Int  ((), Just arg)<String>: text
src/ParseBinaryStructure.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE+	TemplateHaskell,+	QuasiQuotes,+	FlexibleContexts,+	FlexibleInstances,+	PackageImports #-}  {-# OPTIONS_GHC 	-fno-warn-unused-do-bind@@ -11,6 +16,7 @@  	BinaryStructure, 	binaryStructureName,+	binaryStructureArgName, 	binaryStructureArgType, 	binaryStructureBody, @@ -20,10 +26,10 @@ 	valueOf,  	Expression,+	expression, 	Binary(..), 	Field(..),-	fii, -- fiiBE,-	tii, -- tiiBE,+	fii, tii, 	dp, fs, cc ) where @@ -33,6 +39,9 @@  import Classes +import "monads-tf" Control.Monad.Reader+import Control.Applicative+ parseBinaryStructure :: String -> BinaryStructure parseBinaryStructure src = case parseString top "<code>" src of 	Right bs -> bs@@ -40,6 +49,7 @@  data BinaryStructure = BinaryStructure { 	binaryStructureName :: String,+	binaryStructureArgName :: String, 	binaryStructureArgType :: TypeQ, 	binaryStructureBody :: [BinaryStructureItem]  }@@ -50,20 +60,24 @@ 	valueOf :: Either (Either Int String) String  } -type Expression	= Name -> Name -> ExpQ+type Expression	= Reader (Name, Name, String) ExpQ +expression :: Name -> Name -> String -> Expression -> ExpQ+expression ret arg argn e = runReader e (ret, arg, argn)+ applyOp :: Name -> Expression -> Expression -> Expression-applyOp op e1 e2 ret arg = infixApp (e1 ret arg) (varE op) (e2 ret arg)+applyOp op re1 re2 = flip infixApp (varE op) <$> re1 <*> re2  [peggy|  top :: BinaryStructure 	= emptyLines name emptyLines argType dat*-				{ BinaryStructure $2 $4 $5 }+				{ BinaryStructure $2 (fst $4) (snd $4) $5 } -argType :: TypeQ-	= typ [\n]+		{ $1 }-	/ ""			{ conT $ mkName "()" }+argType :: (String, TypeQ)+	= spaces var spaces '::' spaces typeGen [\n]++				{ ($2, $5) }+	/ ""			{ ("_", conT $ mkName "()") }  emptyLines :: () 	= "--" [^\n]* [\n]	{ () }@@ -102,20 +116,20 @@ 	= expr spaces '*' spaces expr		{ applyOp (mkName "*") $1 $4 } 	/ expr spaces '`div`' spaces expr	{ applyOp (mkName "div") $1 $4 } 	/ expr spaces '+' spaces expr		{ applyOp (mkName "+") $1 $4 }-	/ num			{ const $ const $ litE $ integerL $ fromIntegral $1 }-	/ var			{ if $1 == "arg"-					then const varE-					else const . appE (varE $ mkName $1) . varE }+	/ num			{ return $ litE $ integerL $ fromIntegral $1 }+	/ var			{ ask >>= \(ret, arg, argn) -> return $+					if $1 == argn+						then varE arg+						else appE (varE $ mkName $1) $+							varE ret } 	/ [(] tupleExpr [)]	{ $2 }-	/ 'Just' spaces expr	{ \ret arg -> appE (conE $ mkName "Just") $-					$2 ret arg }-	/ 'Nothing'		{ const $ const $ conE $ mkName "Nothing" }+	/ 'Just' spaces expr	{ appE (conE $ mkName "Just") <$> $2 }+	/ 'Nothing'		{ return $ conE $ mkName "Nothing" }  tupleExpr :: Expression-	= expr ', ' expr	{ \ret arg -> tupE-					[$1 ret arg, $2 ret arg] }+	= expr ', ' expr	{ (\e1 e2 -> tupE [e1, e2]) <$> $1 <*> $2 } 	/ expr-	/ ""			{ const $ const $ conE $ mkName "()" }+	/ ""			{ return $ conE $ mkName "()" }  size :: Expression 	= '[' expr ']'
src/QuoteBinaryStructure.hs view
@@ -36,55 +36,56 @@ mkHaskellTree :: BinaryStructure -> DecsQ mkHaskellTree bs = do 		d <- mkData bsn body-		i <- mkInst bsn typ body+		i <- mkInst bsn argn typ body 		return $ d ++ [i] 	where 	bsn = binaryStructureName bs+	argn = binaryStructureArgName bs 	typ = binaryStructureArgType bs 	body = binaryStructureBody bs -mkInst :: String -> TypeQ -> [BinaryStructureItem] -> DecQ-mkInst bsn typ body =+mkInst :: String -> String -> TypeQ -> [BinaryStructureItem] -> DecQ+mkInst bsn argn typ body = 	instanceD (cxt []) (appT (conT ''Field) (conT $ mkName bsn)) [ 		tySynInstD ''FieldArgument [conT $ mkName bsn] typ,-		reading "fromBinary" bsn body,-		writing "toBinary" body+		reading "fromBinary" bsn argn body,+		writing "toBinary" argn body 	 ] -writing :: String -> [BinaryStructureItem] -> DecQ-writing name body = do+writing :: String -> String -> [BinaryStructureItem] -> DecQ+writing name argn body = do 	arg <- newName "arg" 	bs <- newName "bs" 	let run = appE (varE 'cc) $ listE $ map-		(\bsi -> writeField bs arg (bytesOf bsi) (valueOf bsi)) body+		(\bsi -> writeField bs arg argn (bytesOf bsi) (valueOf bsi)) body 	funD (mkName name) 		[clause [varP arg, varP bs] (normalB run) []] -writeField :: Name -> Name -> Expression -> Either (Either Int String) String -> ExpQ-writeField bs arg size (Left (Left n)) =-	appsE [fiend', expression bs arg size, sigE (litE $ integerL $ fromIntegral n)+writeField :: Name -> Name -> String -> Expression -> Either (Either Int String) String -> ExpQ+writeField bs arg argn size (Left (Left n)) =+	appsE [fiend', expression bs arg argn size, sigE (litE $ integerL $ fromIntegral n) 		(conT ''Int)] 	where 	fiend' = varE 'toBinary-writeField _ _ _ (Left (Right s)) =+writeField _ _ _ _ (Left (Right s)) = 	appsE [varE 'fs, litE $ stringL s]-writeField bs arg bytes (Right v) =-	fieldValueToStr bs arg bytes False $ getField bs v+writeField bs arg argn bytes (Right v) =+	fieldValueToStr bs arg argn bytes False $ getField bs v -fieldValueToStr :: Name -> Name -> Expression -> Bool -> ExpQ -> ExpQ-fieldValueToStr bs arg size False =-	appE $ appE (varE 'toBinary) (expression bs arg size)-fieldValueToStr bs arg size True = \val ->+fieldValueToStr :: Name -> Name -> String -> Expression -> Bool -> ExpQ -> ExpQ+fieldValueToStr bs arg argn size False =+	appE $ appE (varE 'toBinary) (expression bs arg argn size)+fieldValueToStr bs arg argn size True = \val -> 	appE (varE 'cc) $ appsE [-		varE 'map, appE (varE 'toBinary) (expression bs arg size), val]+		varE 'map, appE (varE 'toBinary) (expression bs arg argn size), val] -reading :: String -> String -> [BinaryStructureItem] -> DecQ-reading name bsn body = do+reading :: String -> String -> String -> [BinaryStructureItem] -> DecQ+reading name bsn argn body = do 	arg <- newName "arg" 	cs <- newName "cs" 	ret <- newName "ret" 	funD (mkName name) [clause [varP arg, varP cs]-		(normalB $ mkLetRec ret $ mkBody bsn arg body cs) []]+		(normalB $ mkLetRec ret $ mkBody bsn arg argn body cs) []]  mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ mkLetRec n f = do@@ -92,8 +93,8 @@ 	letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $ 		tupE [varE n, varE rest] -mkBody :: String -> Name -> [BinaryStructureItem] -> Name -> Name -> ExpQ-mkBody bsn arg body cs ret = do+mkBody :: String -> Name -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ+mkBody bsn arg argn body cs ret = do 	namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp" 	(defs, rest) <- gather cs body $ mkDef namePairs 	letE (map return defs) $ tupE@@ -126,11 +127,8 @@ 		return ([def], cs'') 	    | otherwise = error "bad" 	    where-	    n = expression ret arg $ bytesOf item-	    arg' = expression ret arg $ bytesOf item--expression :: Name -> Name -> Expression -> ExpQ-expression ret arg e = e ret arg+	    n = expression ret arg argn $ bytesOf item+	    arg' = expression ret arg argn $ bytesOf item  getField :: Name -> String -> ExpQ getField bs v = appE (varE $ mkName v) (varE bs)