packages feed

binary-file (empty) → 0.2

raw patch · 7 files changed

+510/−0 lines, 7 filesdep +basedep +peggydep +template-haskellsetup-changed

Dependencies added: base, peggy, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ binary-file.cabal view
@@ -0,0 +1,70 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		binary-file+version:	0.2+stability:	experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>++license:	BSD3+license-file:	LICENSE++category:	File+synopsis:	read/write binary file+description:++    > runghc -XQuasiQuotes exam.hs some.bmp out.bmp+    .+    exam.hs:+    .+    > import Binary+    > import System.Environment+    >+    > main = do+    >	[inf, outf] <- getArgs+    >+    >	cnt <- readBinaryFile inf+    >	let bmp = readBitmap cnt+    >	print $ readBitmap cnt+    >+    >	let out = writeBitmap bmp {+    >		authorFirst = "Yoshikuni ",+    >		authorSecond = "Jujo      "+    >	 }+    >	writeBinaryFile outf out+    >+    > [binary|+    >+    > Bitmap+    >+    > 2: "BM"+    > 4: fileSize+    > 2: 0+    > 2: 0+    > 4: offset+    > 4: 40+    > 4: bitmapWidth+    > 4: bitmapHeight+    > 2: 1+    > 2: bitsPerPixel+    > 4: compressionMethod+    > 4: imageSize+    > 4: horizontalResolution+    > 4: verticalResolution+    > 4: numberOfColors+    > 4: importantColors+    > 4[numberOfColors]: colors+    > bitsPerPixel/8[imageSize*8/bitsPerPixel]: image+    > 10<String>: authorFirst+    > 10<String>: authorSecond+    > +    > |]+    .++library+    hs-source-dirs:	src+    exposed-modules:	Binary+    other-modules:	QuoteBinaryStructure, ParseBinaryStructure, Here+    build-depends:	base > 3 && < 5, template-haskell, peggy+    ghc-options:	-Wall
+ src/Binary.hs view
@@ -0,0 +1,17 @@+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
+ src/Here.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++module Here (printf, here) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++printf :: QuasiQuoter+printf = QuasiQuoter {+	quoteExp = buildFun . parsePrintf,+	quotePat = undefined,+	quoteType = undefined,+	quoteDec = undefined+ }++data Printf+	= Lit Char+	| String+	| Dec+	| Float+	| Show+	| Char+	deriving (Show, Eq)++parsePrintf :: String -> [Printf]+parsePrintf (c : _) = [Lit c]++buildFun :: [Printf] -> ExpQ+buildFun [Lit c] = [| putChar c |]++here :: QuasiQuoter+here = QuasiQuoter {+	quoteExp = litE . stringL . tail,+	quotePat = undefined,+	quoteType = undefined,+	quoteDec = undefined+ }
+ src/ParseBinaryStructure.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-}++module ParseBinaryStructure (+	BinaryStructure(..),+	BinaryStructureItem,+	Expression(..),+	Type(..),+	bytesOf,+	typeOf,+	sizeOf,+	valueOf,+	parseBinaryStructure,+	readInt+) where++import Text.Peggy+import Here+import Control.Arrow+import Data.Char++main :: IO ()+main = do+	putStrLn "ParseBinaryStructure"+	print $ parseBinaryStructure [here|++BitmapFileHeader++2: 19778+4: fileSize+2: 0+2: 0+4: offset++4: 40+4: bitmapWidth+4: bitmapHeight+2: 1+2: bitPerPic+4: compress+4: imageDataSize+4: horizontalDensity+4: verticalDensity+4: colorIndexNumber+4: neededIndexNumber++4[colorIndexNumber]: colors+1[3]: image+10<String>: author++|]++data Expression+	= Multiple Expression Expression+	| Division Expression Expression+	| Variable String+	| Number Int+	deriving Show++data ConstantValue+	= ConstantInt Int+	| ConstantString String+	deriving Show++constantInt (ConstantInt v) = v+constantInt (ConstantString v) = readInt v++data Type = String | Int deriving Show++data VariableValue+	= VariableValue { variableValue :: String }+	deriving Show++data BinaryStructureItem = BinaryStructureItem {+	binaryStructureItemBytes :: Expression,+	binaryStructureItemType :: Type,+	binaryStructureItemListSize :: Maybe Expression, -- (Either Int String),+	binaryStructureItemValue :: Either ConstantValue VariableValue -- Int String+ } deriving Show++bytesOf :: BinaryStructureItem -> Expression+bytesOf = binaryStructureItemBytes++typeOf :: BinaryStructureItem -> Type+typeOf = binaryStructureItemType++sizeOf :: BinaryStructureItem -> Maybe Expression+sizeOf = binaryStructureItemListSize++valueOf :: BinaryStructureItem -> Either Int String+valueOf = (constantInt +++ variableValue) . binaryStructureItemValue++binaryStructureItem :: Expression -> Type -> Maybe Expression ->+	Either ConstantValue VariableValue -> BinaryStructureItem+binaryStructureItem = BinaryStructureItem++{-+type BinaryStructureItem = (Int, Either Int String)++bytesOf :: (Int, Either Int String) -> Int+bytesOf = fst++valueOf :: (Int, Either Int String) -> Either Int String+valueOf = snd++binaryStructureItem :: Int -> Either Int String -> BinaryStructureItem+binaryStructureItem = (,)+-}++data BinaryStructure = BinaryStructure {+	binaryStructureName :: String,+	binaryStructureBody :: [BinaryStructureItem]+ } deriving Show++parseBinaryStructure :: String -> BinaryStructure+parseBinaryStructure src = case parseString top "<code>" src of+	Right bs -> bs+	Left ps -> error $ show ps++readInt :: String -> Int+readInt "" = 0+readInt (c : cs) = ord c + 2 ^ 8 * readInt cs++[peggy|++top :: BinaryStructure+	= emptyLines name emptyLines dat*+				{ BinaryStructure $2 $4 }++emptyLines :: ()+	= [ \n]*		{ () }++spaces :: ()+	= [ ]*			{ () }++name :: String+	= [A-Z][a-zA-Z0-9]*	{ $1 : $2 }++dat :: BinaryStructureItem+	= expr type size? ':' spaces val emptyLines+				{ binaryStructureItem $1 $2 $3 $5 }+type :: Type+	= "<String>"		{ String }+	/ "<Int>"?		{ Int }++expr :: Expression+	= expr '*' expr		{ Multiple $1 $2 }+	/ expr '/' expr		{ Division $1 $2 }+	/ num			{ Number $1 }+	/ var			{ Variable $1 }++size :: Expression+	= '[' expr ']'++val :: Either ConstantValue VariableValue+	= num			{ Left $ ConstantInt $1 }+	/ var			{ Right $ VariableValue $1 }+	/ stringL		{ Left $ ConstantString $1 }++stringL :: String+	= '\"' [^\"]* '\"'++var :: String+	= [a-z][a-zA-Z0-9]*	{ $1 : $2 }++num :: Int+	= [0-9]+		{ read $1 }++|]
+ src/QuoteBinaryStructure.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TemplateHaskell, TupleSections, PatternGuards #-}++module QuoteBinaryStructure (+	binary+) where++import Prelude hiding (sequence)++import Language.Haskell.TH hiding (Type)+import Language.Haskell.TH.Quote+import Data.Traversable hiding (mapM)+import Data.Either+import Control.Applicative+import Control.Arrow+import Data.Maybe+import Data.Char+import Data.Bits++import ParseBinaryStructure++main = do+	runQ (mkHaskellTree $ parseBinaryStructure "BinaryFileHeader") >>= print++binary :: QuasiQuoter+binary = QuasiQuoter {+	quoteExp = undefined,+	quotePat = undefined,+	quoteType = undefined,+	quoteDec = mkHaskellTree . parseBinaryStructure+ }++mkHaskellTree :: BinaryStructure -> DecsQ+mkHaskellTree BinaryStructure{+	binaryStructureName = bsn,+	binaryStructureBody = body } = do+		d <- mkData bsn body+		r <- mkReader bsn body+		w <- mkWriter bsn body+		return [d, r, w]++mkWriter :: String -> [BinaryStructureItem] -> DecQ+mkWriter bsn body = do+	bs <- newName "bs"+	let run = appE (varE 'concat) $ listE $ map+		(\bsi -> writeField bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi) (valueOf bsi))+		body+	funD (mkName $ "write" ++ bsn)+		[clause [varP bs] (normalB run) []]++writeField :: Name -> Expression -> Type -> Maybe Expression -> Either Int String -> ExpQ+writeField bs size Int Nothing (Left n) =+	appsE [varE 'intToBin, expression bs size, litE $ integerL $ fromIntegral n]+writeField bs size Int Nothing (Right v) =+	appsE [varE 'intToBin, expression bs size, getField bs v]+writeField bs size Int (Just n) (Right v) = appsE [varE 'concatMap,+	appE (varE 'intToBin) (expression bs size), getField bs v]+writeField bs size String Nothing (Right v) = getField bs v++intToBin :: Int -> Int -> String+intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x)++intToBinGen :: Integer -> Integer -> String+intToBinGen 0 _ = ""+intToBinGen n x = chr (fromIntegral $ x `mod` 256) :+	intToBinGen (n - 1) (x `div` 256)++mkReader :: String -> [BinaryStructureItem] -> DecQ+mkReader bsn body = do+	cs <- newName "cs"+	ret <- newName "ret"+	funD (mkName $ "read" ++ bsn)+		[clause [varP cs] (normalB $ mkLetRec ret $ mkBody bsn body cs) []]++mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ+mkLetRec n f = letE [valD (varP n) (normalB $ f n) []] $ varE n++mkBody :: String -> [BinaryStructureItem] -> Name -> Name -> ExpQ+mkBody bsn body cs ret = do+	namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp"+	defs <- gather cs body $ mkDef namePairs+	letE (map return defs) $ recConE (mkName bsn) (map toPair2 namePairs)+	where+	names = rights $ map valueOf body+	toPair2 (n, nn) = return $ (mkName n, VarE nn)+	mkValD v = valD (varP v) (normalB $ litE $ integerL 45) []+	mkDef :: [(String, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name)+	mkDef np item cs'+	    | Left val <- valueOf item = do+		cs'' <- newName "cs"+		let t = dropE' n $ varE cs'+		let p = val `equal` appE (varE 'readInt) (takeE' n $ varE cs')+		let e = [e| error "bad value" |]+		d <- valD (varP cs'') (normalB $ condE p t e) []+		return ([d], cs'')+	    | Right var <- valueOf item, Nothing <- sizeOf item, Int <- typeOf item = do+		cs'' <- newName "cs"+		def <- valD (varP $ fromJust $ lookup var np)+			(normalB $ appE (varE 'readInt) $ takeE' n $ varE cs') []+		next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') []+		return ([def, next], cs'')+	    | Right var <- valueOf item, Nothing <- sizeOf item = do+		cs'' <- newName "cs"+		def <- valD (varP $ fromJust $ lookup var np)+			(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 = do+		cs'' <- newName "cs"+		def <- valD (varP $ fromJust $ lookup var np)+			(normalB $+				appsE [varE 'map, varE 'readInt,+				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'')+	    where+	    n = expression ret $ bytesOf item++expression :: Name -> Expression -> ExpQ+expression ret (Variable v) = appE (varE $ mkName v) (varE ret)+expression _ (Number n) = litE $ integerL $ fromIntegral n+expression ret (Division x y) = divE (expression ret x) (expression ret y)+expression ret (Multiple x y) = multiE' (expression ret x) (expression ret y)++getField :: Name -> String -> ExpQ+getField bs v = appE (varE $ mkName v) (varE bs)++multiE :: Int -> ExpQ -> ExpQ+multiE x y = infixE (Just $ litE $ integerL $ fromIntegral x) (varE '(*)) (Just y)++multiE' :: ExpQ -> ExpQ -> ExpQ+multiE' x y = infixE (Just x) (varE '(*)) (Just y)++divE :: ExpQ -> ExpQ -> ExpQ+divE x y = infixE (Just x) (varE 'div) (Just y)++equal :: Int -> ExpQ -> ExpQ+equal x y = infixE (Just $ litE $ integerL $ fromIntegral x) (varE '(==)) (Just y)++takeE :: Int -> ExpQ -> ExpQ+takeE n xs = appsE [varE 'take, litE $ integerL $ fromIntegral n, xs]++takeE' :: ExpQ -> ExpQ -> ExpQ+takeE' n xs = appsE [varE 'take, n, xs]++dropE :: Int -> ExpQ -> ExpQ+dropE n xs = appsE [varE 'drop, litE $ integerL $ fromIntegral n, xs]++dropE' :: ExpQ -> ExpQ -> ExpQ+dropE' n xs = appsE [varE 'drop, n, xs]++gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m [b]+gather s [] f = return []+gather s (x : xs) f = do+	(ys, s') <- f x s+	zs <- gather s' xs f+	return $ ys ++ zs++mkData :: String -> [BinaryStructureItem] -> DecQ+mkData bsn body =+	dataD (cxt []) name [] [con] [''Show]+	where+	name = mkName bsn+	con = recC (mkName bsn) vsts++	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, _) -> varStrictType+				(mkName $ fromRight $ valueOf item) $+					strictType notStrict $ conT ''String++	isRight item+		| Right _ <- valueOf item = True+		| otherwise = False++fromRight = either (error "not Right") id++devideN :: Int -> [a] -> [[a]]+devideN _ [] = []+devideN n xs = take n xs : devideN n (drop n xs)