binary-file 0.4 → 0.6

raw patch · 5 files changed

+151/−47 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• binary-file.cabal +4/−4
• src/Binary.hs +0/−17
• src/File/Binary.hs +17/−0
• src/ParseBinaryStructure.hs +19/−7
• src/QuoteBinaryStructure.hs +111/−19

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		binary-file-version:	0.4+version:	0.6 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -18,7 +18,7 @@     .     exam.hs:     .-    > import Binary+    > import File.Binary     > import System.Environment     > import Data.ByteString as BS     >@@ -57,7 +57,7 @@     > 4: verticalResolution     > 4: numberOfColors     > 4: importantColors-    > 4[numberOfColors]: colors+    > 4<(Int, Int, Int)>[numberOfColors]: colors     > -- bitsPerPixel/8[imageSize*8/bitsPerPixel]: image     > imageSize<ByteString>: image     > 10<String>: authorFirst@@ -68,7 +68,7 @@  library     hs-source-dirs:	src-    exposed-modules:	Binary+    exposed-modules:	File.Binary     other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Here     build-depends:	base > 3 && < 5, template-haskell, peggy, bytestring     ghc-options:	-Wall

@@ -1,17 +0,0 @@-module Binary (-	readBinaryFile,-	writeBinaryFile,-	binary- ) where--import QuoteBinaryStructure-import System.IO--readBinaryFile :: FilePath -> IO String-readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents--writeBinaryFile :: FilePath -> String -> IO ()-writeBinaryFile path str = do-	h <- openBinaryFile path WriteMode-	hPutStr h str-	hClose h

@@ -0,0 +1,17 @@+module File.Binary (+	readBinaryFile,+	writeBinaryFile,+	binary+ ) where++import QuoteBinaryStructure+import System.IO++readBinaryFile :: FilePath -> IO String+readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents++writeBinaryFile :: FilePath -> String -> IO ()+writeBinaryFile path str = do+	h <- openBinaryFile path WriteMode+	hPutStr h str+	hClose h

@@ -43,8 +43,9 @@ 4: colorIndexNumber 4: neededIndexNumber -4[colorIndexNumber]: colors+4<(Int,Int,Int)>[colorIndexNumber]: colors -- 1[3]: image+imageSize<ByteString>: image 10<String>: author 10<ByteString>: hoge @@ -65,7 +66,7 @@ constantInt (ConstantInt v) = v constantInt (ConstantString v) = readInt v -data Type = String | Int | ByteString deriving Show+data Type = String | Int | ByteString | Tuple [Type] deriving (Show, Eq)  data VariableValue 	= VariableValue { variableValue :: String }@@ -139,12 +140,23 @@ 	= [A-Z][a-zA-Z0-9]*	{ $1 : $2 }  dat :: BinaryStructureItem-	= expr type size? ':' spaces val emptyLines+	= expr typ size? ':' spaces val emptyLines 				{ binaryStructureItem $1 $2 $3 $5 }-type :: Type-	= "<String>"		{ String }-	/ "<ByteString>"	{ ByteString }-	/ "<Int>"?		{ Int }+typ :: Type+	= [<] typeGen [>]	{ $2 }+	/ ""			{ Int }++typeGen :: Type+	= [(] tupleGen [)]	{ Tuple $2 }+	/ "String"		{ String }+	/ "ByteString"		{ ByteString }+	/ "Int"			{ Int }++tupleGen :: [Type]+	= typeGen spaces "," spaces tupleGen+				{ $1 : $4 }+	/ typeGen spaces "," spaces typeGen+				{ [$1, $4] }  expr :: Expression 	= expr '*' expr		{ Multiple $1 $2 }

@@ -59,13 +59,75 @@ 	Either Int String -> ExpQ writeField bs size Int Nothing (Left n) = 	appsE [varE 'fi, expression bs size, litE $ integerL $ fromIntegral n]-writeField bs size Int Nothing (Right v) =-	appsE [varE 'fi, expression bs size, getField bs v]-writeField bs size Int (Just n) (Right v) = appE (varE 'cc) $ appsE [varE 'map,-	appE (varE 'fi) (expression bs size), getField bs v]-writeField bs size String Nothing (Right v) = appE (varE 'fs) $ getField bs v-writeField bs size ByteString Nothing (Right v) = appE (varE 'fbs) $ getField bs v+writeField bs bytes typ size (Right v) =+	fieldValueToStr bs bytes (isJust size) typ $ getField bs v +fieldValueToStr :: Name -> Expression -> Bool -> Type -> ExpQ -> ExpQ+fieldValueToStr bs size False Int = appE $ appE (varE 'fi) (expression bs size)+fieldValueToStr bs size True Int = appE (varE 'cc) . appE (appsE [varE 'map,+	appE (varE 'fi) (expression bs size)])+fieldValueToStr bs size False String = appE $ varE 'fs+fieldValueToStr bs size False ByteString = appE $ varE 'fbs+fieldValueToStr bs size False (Tuple ts) = \val -> do+	nl <- newNameList $ length ts+	let	def = valD (tupP $ map varP nl) (normalB val) []+		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl+	 in	letE [def] $ appE (varE 'cc) $ listE bdy+fieldValueToStr bs size True (Tuple ts) = \val -> do+	runIO $ do+		putStrLn "here"+		print ts+	nl <- newNameList $ length ts+	let	ps = tupP $ map varP nl+		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl+	 in	appE (varE 'cc) $ appsE [+			varE 'map,+			lamE [ps] $ appE (varE 'cc) $ addZero $ listE bdy,+			val]+	where+	addZero = -- appE $ addZeros 1+		appE $ correctSize' $ expression bs size+{-+	let	ps = tupP $ map varP nl+		bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl+	 in	appE (varE 'cc) $ appE (correctSize' $ expression bs size) $ appsE [+			varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val]+-}+{-+	 in	appE (varE 'cc) $ correctSize (expression bs size) $ appsE [+			varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val]+-}++addZeros :: Int -> ExpQ+addZeros ln = do+	lst <- newName "lst"+	let bdy = infixApp (varE lst) (varE '(++)) $+		appsE [varE 'replicate, litE $ integerL $ fromIntegral ln, varE 'zero]+	lam1E (varP lst) bdy++correctSize' :: ExpQ -> ExpQ+correctSize' size = do+--	let size = litE $ IntegerL 100+	lst <- newName "lst"+	let bdy = infixApp (varE lst) (varE '(++)) $+		appsE [varE 'replicate,+			infixApp size (varE '(-)) $ appE (varE 'length) $ varE lst,+			varE 'zero]+	lam1E (varP lst) bdy++correctSize :: ExpQ -> ExpQ -> ExpQ+correctSize size list = infixApp list (varE '(++)) $+	appsE [varE 'replicate,+		infixApp size (varE '(-)) $ appE (varE 'length) list,+		varE 'zero]++newNameList :: Int -> Q [Name]+newNameList 0 = return []+newNameList n = liftA2 (:) (newName "x") $ newNameList (n - 1)++mapTuple :: (Type -> ExpQ) -> [Type] -> ExpQ+mapTuple f ts = varE 'show+ intToBin :: Int -> Int -> String intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x) @@ -125,6 +187,18 @@ 			(normalB $ takeE' n $ varE cs') [] 		next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') [] 		return ([def, next], cs'')+	    | Right var <- valueOf item, Just expr <- sizeOf item, Tuple ts <- typeOf item =+		if all (== Int) ts then do+			cs'' <- newName "cs"+			def <- valD (varP $ fromJust $ lookup var np)+				(normalB $+					appsE [varE 'map, strToTupple $ length ts,+					appsE [varE 'devideN, n,+				takeE' (multiE' n $ expression ret expr) $ varE cs']]) []+			next <- valD (varP cs'') (normalB $+				dropE' (multiE' n $ expression ret expr) $ varE cs') []+			return ([def, next], cs'')+		    else error "hogeru" 	    | Right var <- valueOf item, Just expr <- sizeOf item = do 		cs'' <- newName "cs" 		def <- valD (varP $ fromJust $ lookup var np)@@ -139,6 +213,18 @@ 	    where 	    n = expression ret $ bytesOf item +strToTupple :: Int -> ExpQ+strToTupple n = (toTupple n) `dot` appE (varE 'map) (varE 'ord) `dot`+	appE (varE 'take) (litE $ integerL $ fromIntegral n)++dot :: ExpQ -> ExpQ -> ExpQ+dot f1 f2 = infixApp f1 (varE '(.)) f2++toTupple :: Int -> ExpQ+toTupple n = do+	nl <- newNameList n+	lam1E (listP $ map varP nl) (tupE $ map varE nl)+ expression :: Name -> Expression -> ExpQ expression ret (Variable v) = appE (varE $ mkName v) (varE ret) expression _ (Number n) = litE $ integerL $ fromIntegral n@@ -191,24 +277,27 @@  	vsts = flip map (filter isRight body) $ \item -> 		case (sizeOf item, typeOf item) of-			(Nothing, Int) -> varStrictType-				(mkName $ fromRight $ valueOf item) $-					strictType notStrict $ conT ''Int-			(_, Int) -> varStrictType-				(mkName $ fromRight $ valueOf item) $-					strictType notStrict $-						appT listT $ conT ''Int-			(Nothing, String) -> varStrictType-				(mkName $ fromRight $ valueOf item) $-					strictType notStrict $ conT ''String-			(Nothing, ByteString) -> varStrictType+			(sz, tp) -> varStrictType 				(mkName $ fromRight $ valueOf item) $-					strictType notStrict $ conT ''BS.ByteString-+					strictType notStrict $ mkType (isJust sz) tp -- conT ''Int 	isRight item 		| Right _ <- valueOf item = True 		| otherwise = False +mkType :: Bool -> Type -> TypeQ+mkType True t = appT listT $ mkType False t+mkType False Int = conT ''Int+mkType False String = conT ''String+mkType False ByteString = conT ''BS.ByteString+mkType False (Tuple ts) = appsT $ tupleT (length ts) : map (mkType False) ts++appsT :: [TypeQ] -> TypeQ+appsT [t] = t+appsT (t1 : t2 : ts) = appsT (appT t1 t2 : ts)++mkTupleReader :: [Type] -> ExpQ+mkTupleReader _ = varE 'show+ fromRight = either (error "not Right") id  devideN :: Int -> [a] -> [[a]]@@ -225,6 +314,7 @@ 	ti :: a -> Int 	fi :: Int -> Int -> a 	cc :: [a] -> a+	zero :: a  instance Str String where 	tk = take@@ -236,6 +326,7 @@ 	ti = readInt 	fi = intToBin 	cc = concat+	zero = "\0"  instance Str BS.ByteString where 	tk = BS.take@@ -247,3 +338,4 @@ 	ti = readInt . map (chr . fromIntegral) . BS.unpack 	fi n = BS.pack . map (fromIntegral . ord) . intToBin n 	cc = BS.concat+	zero = BS.singleton 0