diff --git a/binary-file.cabal b/binary-file.cabal --- a/binary-file.cabal +++ b/binary-file.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: binary-file -version: 0.15.22 +version: 0.15.24 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -69,8 +69,8 @@ > 4: resolutionV > 4: color_num > 4: important_color_num - > ((), Just color_num)[OPENBRACKET](Int, Int, Int)[CLOSEBRACKET]: colors - > ((), image_size)[OPENBRACKET]String[CLOSEBRACKET]: image + > replicate color_num ()[OPENBRACKET][(Int, Int, Int)][CLOSEBRACKET]: colors + > replicate image_size ()[OPENBRACKET]String[CLOSEBRACKET]: image > > |] . @@ -92,7 +92,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/binary-file.git - tag: 0.15.22 + tag: 0.15.24 library hs-source-dirs: src diff --git a/examples/readBitmap.hs b/examples/readBitmap.hs --- a/examples/readBitmap.hs +++ b/examples/readBitmap.hs @@ -64,7 +64,9 @@ 4: resolutionV 4: color_num 4: important_colors_num -((), Just color_num){[(Int, Int, Int)]}: colors -((), Just image_size){String}: image +-- ((), Just color_num){[(Int, Int, Int)]}: colors +-- ((), Just image_size){String}: image +replicate color_num (){[(Int, Int, Int)]}: colors +replicate image_size (){String}: image |] diff --git a/examples/readPNG.hs b/examples/readPNG.hs --- a/examples/readPNG.hs +++ b/examples/readPNG.hs @@ -5,6 +5,7 @@ import File.Binary (binary, Field(..)) import File.Binary.Instances () import File.Binary.Instances.BigEndian () +import File.Binary.Instances.MSB0 () import CRC (crc) import Codec.Compression.Zlib ( decompress, compressWith, defaultCompressParams, CompressParams(..), @@ -81,7 +82,8 @@ 2: "\r\n" 1: "\SUB" 1: "\n" -((), Nothing){[Chunk]}: chunks +-- ((), Nothing){[Chunk]}: chunks +repeat (){[Chunk]}: chunks |] @@ -90,7 +92,8 @@ Chunk deriving Show 4: chunkSize -((), Just 4){String}: chunkName +-- ((), Just 4){String}: chunkName +replicate 4 (){String}: chunkName (chunkSize, chunkName){ChunkBody}: chunkData 4{Word32}:chunkCRC @@ -120,7 +123,7 @@ toBinary (n, _) (ChunkIDAT c) = toBinary n c toBinary (n, _) (ChunkTEXT c) = toBinary n c toBinary _ (ChunkIEND c) = toBinary () c - toBinary (n, _) (Others str) = toBinary ((), Just n) str + toBinary (n, _) (Others str) = toBinary (replicate n ()) str -- toBinary ((), Just n) str fromBinary (_, "IHDR") = fmap (first ChunkIHDR) . fromBinary () fromBinary (_, "gAMA") = fmap (first ChunkGAMA) . fromBinary () fromBinary (_, "sRGB") = fmap (first ChunkSRGB) . fromBinary () @@ -130,7 +133,7 @@ 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) + fromBinary (n, _) = fmap (first Others) . fromBinary (replicate n ()) -- ((), Just n) [binary| @@ -177,7 +180,8 @@ arg :: Int -(4, Just (arg `div` 4)){[Int]}: chrms +-- (4, Just (arg `div` 4)){[Int]}: chrms +replicate (arg `div` 4) 4{[Int]}: chrms |] @@ -187,7 +191,8 @@ arg :: Int -((), Just (arg `div` 3)){[(Int, Int, Int)]}: colors +-- ((), Just (arg `div` 3)){[(Int, Int, Int)]}: colors +replicate (arg `div` 3) (){[(Int, Int, Int)]}: colors |] @@ -228,7 +233,8 @@ arg :: Int -((), Just arg){String}: text +-- ((), Just arg){String}: text +replicate arg (){String}: text |] diff --git a/src/File/Binary/Instances.hs b/src/File/Binary/Instances.hs --- a/src/File/Binary/Instances.hs +++ b/src/File/Binary/Instances.hs @@ -16,9 +16,9 @@ import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, unpack) import qualified Data.ByteString as BS (ByteString, take, drop, concat, uncons, span) import qualified Data.ByteString.Char8 () -import Control.Monad (replicateM, foldM) -import "monads-tf" Control.Monad.State (StateT(..), gets) -import Control.Applicative ((<$>), (<*>)) +import Control.Monad (foldM) +import "monads-tf" Control.Monad.State (StateT(..)) +import Control.Applicative ((<$>)) import Control.Arrow (first, (&&&)) import Data.Monoid (mempty) import Data.Char @@ -47,21 +47,24 @@ toBinary _ = return . makeBinary . pack . (: []) instance Field r => Field [r] where - type FieldArgument [r] = (FieldArgument r, Maybe Int) - fromBits (a, Just b) = b `times` fromBits a - fromBits (a, Nothing) = mempty `whole` fromBits a - consToBits (a, _) fs ret = foldM (flip $ consToBits a) ret $ reverse fs + type FieldArgument [r] = [FieldArgument r] + fromBits as = smap mempty as fromBits + consToBits as fs ret = foldM (flip $ uncurry consToBits) ret $ reverse $ zip as fs -times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s) -times n f - | n >= 0 = runStateT $ replicateM n (StateT f) - | otherwise = error "times: negative times?" +myMapM :: (Monad m, Functor m) => (a -> m (Maybe b)) -> [a] -> m [b] +myMapM _ [] = return [] +myMapM f (x : xs) = do + ret <- f x + case ret of + Just y -> (y :) <$> myMapM f xs + Nothing -> return [] -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 f <*> (StateT $ whole e f) +smap :: (Monad m, Functor m, Eq s) => + s -> [a] -> (a -> s -> m (ret, s)) -> s -> m ([ret], s) +smap e xs f = runStateT $ myMapM (StateT . f') xs + where + f' x s | s == e = return (Nothing, s) + | otherwise = first Just <$> f x s -------------------------------------------------------------------------------- diff --git a/src/File/Binary/Parse.hs b/src/File/Binary/Parse.hs --- a/src/File/Binary/Parse.hs +++ b/src/File/Binary/Parse.hs @@ -18,7 +18,7 @@ import Text.Peggy (peggy, parseString, space, defaultDelimiter) import Language.Haskell.TH ( - ExpQ, integerL, litE, varE, conE, tupE, appE, uInfixE, parensE, + ExpQ, integerL, litE, varE, conE, listE, tupE, appE, uInfixE, parensE, TypeQ, conT, listT, tupleT, appT, Name, mkName, FieldExp) import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Control.Applicative ((<$>), (<*>)) @@ -115,6 +115,11 @@ / num { return $ litE $ integerL $1 } / lname { return $ conE $1 } / var { identify $1 <$> ask } + / '[' list ']' { listE <$> $1 } + +list :: Reader ([FieldExp], ExpQ, String) [ExpQ] + = ex sp "," sp list { (:) <$> $1 <*> $4 } + / ex { (: []) <$> $1 } op :: Expression = [!\\#$%&*+./<=>?@^|~\-]+ { return $ varE $ mkName $1 }