binary-file 0.3 → 0.4
raw patch · 3 files changed
+95/−26 lines, 3 filesdep +bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring
API changes (from Hackage documentation)
Files
- binary-file.cabal +9/−5
- src/ParseBinaryStructure.hs +7/−3
- src/QuoteBinaryStructure.hs +79/−18
binary-file.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: binary-file-version: 0.3+version: 0.4 stability: experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -20,11 +20,13 @@ . > import Binary > import System.Environment+ > import Data.ByteString as BS > > main = do > [inf, outf] <- getArgs >- > cnt <- readBinaryFile inf+ > -- cnt <- readBinaryFile inf+ > cnt <- BS.readFile inf > let bmp = readBitmap cnt > print $ readBitmap cnt >@@ -32,7 +34,8 @@ > authorFirst = "Yoshikuni ", > authorSecond = "Jujo " > }- > writeBinaryFile outf out+ > -- writeBinaryFile outf out+ > BS.writeFile outf out > > [binary| >@@ -55,7 +58,8 @@ > 4: numberOfColors > 4: importantColors > 4[numberOfColors]: colors- > bitsPerPixel/8[imageSize*8/bitsPerPixel]: image+ > -- bitsPerPixel/8[imageSize*8/bitsPerPixel]: image+ > imageSize<ByteString>: image > 10<String>: authorFirst > 10<String>: authorSecond > @@ -66,5 +70,5 @@ hs-source-dirs: src exposed-modules: Binary other-modules: QuoteBinaryStructure, ParseBinaryStructure, Here- build-depends: base > 3 && < 5, template-haskell, peggy+ build-depends: base > 3 && < 5, template-haskell, peggy, bytestring ghc-options: -Wall
src/ParseBinaryStructure.hs view
@@ -44,8 +44,9 @@ 4: neededIndexNumber 4[colorIndexNumber]: colors-1[3]: image+-- 1[3]: image 10<String>: author+10<ByteString>: hoge |] @@ -64,7 +65,7 @@ constantInt (ConstantInt v) = v constantInt (ConstantString v) = readInt v -data Type = String | Int deriving Show+data Type = String | Int | ByteString deriving Show data VariableValue = VariableValue { variableValue :: String }@@ -127,11 +128,13 @@ { BinaryStructure $2 $4 } emptyLines :: ()- = [ \n]* { () }+ = "--" [^\n]* [\n] { () }+ / [ \n]* { () } spaces :: () = [ ]* { () } + name :: String = [A-Z][a-zA-Z0-9]* { $1 : $2 } @@ -140,6 +143,7 @@ { binaryStructureItem $1 $2 $3 $5 } type :: Type = "<String>" { String }+ / "<ByteString>" { ByteString } / "<Int>"? { Int } expr :: Expression
src/QuoteBinaryStructure.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, TupleSections, PatternGuards #-}+{-# LANGUAGE+ TemplateHaskell,+ TupleSections,+ PatternGuards,+ TypeSynonymInstances,+ FlexibleInstances #-} module QuoteBinaryStructure ( binary@@ -18,6 +23,8 @@ import ParseBinaryStructure +import qualified Data.ByteString as BS+ main = do runQ (mkHaskellTree $ parseBinaryStructure "BinaryFileHeader") >>= print @@ -34,6 +41,7 @@ binaryStructureName = bsn, binaryStructureBody = body } = do d <- mkData bsn body+-- dbg <- debugReadType r <- mkReader bsn body w <- mkWriter bsn body return [d, r, w]@@ -41,20 +49,22 @@ mkWriter :: String -> [BinaryStructureItem] -> DecQ mkWriter bsn body = do bs <- newName "bs"- let run = appE (varE 'concat) $ listE $ map+ let run = appE (varE 'cc) $ 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 :: 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]+ appsE [varE 'fi, 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+ 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 intToBin :: Int -> Int -> String intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x)@@ -64,6 +74,11 @@ intToBinGen n x = chr (fromIntegral $ x `mod` 256) : intToBinGen (n - 1) (x `div` 256) +-- readerType :: String -> DecQ+-- readerType = sigD (mkName $ "read" ++ bsn) [t| Str a => a ->++-- debugReadType :: DecQ = [d| readBitmap :: Str a => a -> Bitmap |]+ mkReader :: String -> [BinaryStructureItem] -> DecQ mkReader bsn body = do cs <- newName "cs"@@ -88,16 +103,22 @@ | 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 p = val `equal` appE (varE 'ti) (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') []+ (normalB $ appE (varE 'ti) $ takeE' n $ varE cs') [] next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') [] return ([def, next], cs'')+ | Right var <- valueOf item, Nothing <- sizeOf item, ByteString <- typeOf 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, Nothing <- sizeOf item = do cs'' <- newName "cs" def <- valD (varP $ fromJust $ lookup var np)@@ -108,12 +129,13 @@ cs'' <- newName "cs" def <- valD (varP $ fromJust $ lookup var np) (normalB $- appsE [varE 'map, varE 'readInt,+ appsE [varE 'map, varE 'ti, 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'')+ | otherwise = error $ show $ typeOf item where n = expression ret $ bytesOf item @@ -138,17 +160,20 @@ 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 :: Int -> ExpQ -> ExpQ+-- takeE n xs = appsE [varE 'tk, litE $ integerL $ fromIntegral n, xs] takeE' :: ExpQ -> ExpQ -> ExpQ-takeE' n xs = appsE [varE 'take, n, xs]+takeE' n xs = appE (varE 'ts) $ appsE [varE 'tk, n, xs] -dropE :: Int -> ExpQ -> ExpQ-dropE n xs = appsE [varE 'drop, litE $ integerL $ fromIntegral n, xs]+takeE'' :: ExpQ -> ExpQ -> ExpQ+takeE'' n xs = appE (varE 'tbs) $ appsE [varE 'tk, n, xs] +-- dropE :: Int -> ExpQ -> ExpQ+-- dropE n xs = appsE [varE 'dp, litE $ integerL $ fromIntegral n, xs]+ dropE' :: ExpQ -> ExpQ -> ExpQ-dropE' n xs = appsE [varE 'drop, n, xs]+dropE' n xs = appsE [varE 'dp, n, xs] gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m [b] gather s [] f = return []@@ -173,9 +198,12 @@ (mkName $ fromRight $ valueOf item) $ strictType notStrict $ appT listT $ conT ''Int- (Nothing, _) -> varStrictType+ (Nothing, String) -> varStrictType (mkName $ fromRight $ valueOf item) $ strictType notStrict $ conT ''String+ (Nothing, ByteString) -> varStrictType+ (mkName $ fromRight $ valueOf item) $+ strictType notStrict $ conT ''BS.ByteString isRight item | Right _ <- valueOf item = True@@ -186,3 +214,36 @@ devideN :: Int -> [a] -> [[a]] devideN _ [] = [] devideN n xs = take n xs : devideN n (drop n xs)++class Str a where+ tk :: Int -> a -> a+ dp :: Int -> a -> a+ ts :: a -> String+ fs :: String -> a+ fbs :: BS.ByteString -> a+ tbs :: a -> BS.ByteString+ ti :: a -> Int+ fi :: Int -> Int -> a+ cc :: [a] -> a++instance Str String where+ tk = take+ dp = drop+ ts = id+ fs = id+ fbs = ts+ tbs = fs+ ti = readInt+ fi = intToBin+ cc = concat++instance Str BS.ByteString where+ tk = BS.take+ dp = BS.drop+ ts = map (chr . fromIntegral) . BS.unpack+ fs = BS.pack . map (fromIntegral . ord)+ fbs = id+ tbs = id+ ti = readInt . map (chr . fromIntegral) . BS.unpack+ fi n = BS.pack . map (fromIntegral . ord) . intToBin n+ cc = BS.concat