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.16 +version: 0.15.18 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -35,14 +35,16 @@ > > instance Field (Int, Int, Int) where > type FieldArgument (Int, Int, Int) = () - > fromBinary _ s = let - > (b, rest) = toType 1 s - > (g, rest') = toType 1 rest - > (r, rest'') = toType 1 rest' in - > ((b, g, r), snd $ getBytes 1 1 rest'') - > toBinary _ (b, g, r) = concatBinary [ - > fromType 1 b, fromType 1 g, fromType 1 r, - > makeBinary $ BSL.singleton 0] + > fromBinary _ s = do + > (b, rest) <- fromBinary 1 s + > (g, rest') <- fromBinary 1 rest + > (r, rest'') <- fromBinary 1 rest' in + > return ((b, g, r), snd $ getBytes 1 1 rest'') + > toBinary _ (b, g, r) = do + > b' <- toBinary 1 b + > g' <- toBinary 1 g + > r' <- toBinary 1 r + > return $ concatBinary [b', g', r', makeBinary $ BSL.singleton 0] > > [binary| > @@ -90,7 +92,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/binary-file.git - tag: 0.15.16 + tag: 0.15.18 library hs-source-dirs: src diff --git a/examples/readBitmap.hs b/examples/readBitmap.hs --- a/examples/readBitmap.hs +++ b/examples/readBitmap.hs @@ -24,7 +24,9 @@ return bmp writeBitmap :: FilePath -> Bitmap -> IO () -writeBitmap fp = writeBinaryFile fp . toBinary () +writeBitmap fp bmp = do + let Right bin = toBinary () bmp + writeBinaryFile fp bin instance Field (Int, Int, Int) where type FieldArgument (Int, Int, Int) = () @@ -33,12 +35,11 @@ (g, rest') <- fromBinary 1 rest (r, rest'') <- fromBinary 1 rest' return ((b, g, r), snd $ getBytes 1 rest'') - toBinary _ (b, g, r) = mconcat [ - toBinary 1 b, - toBinary 1 g, - toBinary 1 r, - makeBinary $ singleton 0 - ] + toBinary _ (b, g, r) = do + b' <- toBinary 1 b + g' <- toBinary 1 g + r' <- toBinary 1 r + return $ mconcat [b', g', r', makeBinary $ singleton 0] [binary| diff --git a/examples/readPNG.hs b/examples/readPNG.hs --- a/examples/readPNG.hs +++ b/examples/readPNG.hs @@ -47,7 +47,9 @@ return png writePNG :: FilePath -> PNG -> IO () -writePNG fout = BS.writeFile fout . toBinary () +writePNG fout png = do + let Right cnt = toBinary () png + BS.writeFile fout cnt header :: PNG -> [Chunk] header PNG{ chunks = cs } = @@ -191,7 +193,11 @@ instance Field (Int, Int, Int) where type FieldArgument (Int, Int, Int) = () - toBinary _ (b, g, r) = mconcat [toBinary 1 b, toBinary 1 g, toBinary 1 r] + toBinary _ (b, g, r) = do + b' <- toBinary 1 b + g' <- toBinary 1 g + r' <- toBinary 1 r + return $ mconcat [b', g', r'] fromBinary _ s = do (r, rest) <- fromBinary 1 s (g, rest') <- fromBinary 1 rest diff --git a/src/File/Binary/Classes.hs b/src/File/Binary/Classes.hs --- a/src/File/Binary/Classes.hs +++ b/src/File/Binary/Classes.hs @@ -9,29 +9,36 @@ import Data.Word import Control.Arrow (first, second) import Control.Applicative +import Control.Monad type AddBits b = ([Bool], b) class Field f where type FieldArgument f - fromBinary :: Binary b => FieldArgument f -> b -> Either String (f, b) - toBinary :: Binary b => FieldArgument f -> f -> b - fromBits :: Binary b => FieldArgument f -> AddBits b -> Either String (f, AddBits b) - consToBits :: Binary b => FieldArgument f -> f -> AddBits b -> AddBits b + fromBinary :: (Binary b, Functor m, Monad m) => FieldArgument f -> b -> m (f, b) + toBinary :: (Binary b, Functor m, Monad m) => FieldArgument f -> f -> m b + fromBits :: (Binary b, Functor m, Monad m) => + FieldArgument f -> AddBits b -> m (f, AddBits b) + consToBits :: (Binary b, Functor m, Monad m) => + FieldArgument f -> f -> AddBits b -> m (AddBits b) - fromBits a ([], b) = second ([] ,) <$> fromBinary a b + fromBits a ([], b) = second ([] ,) `liftM` fromBinary a b fromBits _ _ = error "fromBits: not bytes (1 byte = 8 bits)" - consToBits a f ([], b) = ([], toBinary a f `mappend` b) - consToBits _ _ _ = error "consToBits: not bytes (1 byte = 8 bits)" + consToBits a f ([], b) = do + ret <- (`mappend` b) <$> toBinary a f + return ([], ret) + consToBits _ _ _ = fail "consToBits: not bytes (1 byte = 8 bits)" fromBinary a b = do ret <- fromBits a ([], b) case ret of (f, ([], rest)) -> return (f, rest) - _ -> Left "fromBinary: not bytes (1 byte = 8 bits)" - toBinary a f = case consToBits a f ([], mempty) of - ([], bin) -> bin - _ -> error "toBinary: not bytes (1 byte = 8 bits)" + _ -> fail "fromBinary: not bytes (1 byte = 8 bits)" + toBinary a f = do + ret <- consToBits a f ([], mempty) + case ret of + ([], bin) -> return bin + _ -> fail "toBinary: not bytes (1 byte = 8 bits)" pop :: Binary b => b -> AddBits b pop = first (wtbs (8 :: Int) . head . unpack) . getBytes 1 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,7 +16,7 @@ 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) +import Control.Monad (replicateM, foldM) import "monads-tf" Control.Monad.State (StateT(..), gets) import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, (&&&)) @@ -29,28 +29,28 @@ instance Field ByteString where type FieldArgument ByteString = Int fromBinary a = return . getBytes a - toBinary _ = makeBinary + toBinary _ = return . makeBinary instance Field BS.ByteString where type FieldArgument BS.ByteString = Int fromBinary n = return . first (BS.concat . toChunks) . getBytes n - toBinary _ = makeBinary . fromChunks . (: []) + toBinary _ = return . makeBinary . fromChunks . (: []) instance Field Char where type FieldArgument Char = () fromBinary _ = return . first (head . BSLC.unpack) . getBytes 1 - toBinary _ = makeBinary . BSLC.pack . (: []) + toBinary _ = return . makeBinary . BSLC.pack . (: []) instance Field Word8 where type FieldArgument Word8 = () fromBinary _ = return . first (head . unpack) . getBytes 1 - toBinary _ = makeBinary . pack . (: []) + 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, _) = flip $ foldr $ consToBits a + consToBits (a, _) fs ret = foldM (flip $ consToBits a) ret $ reverse fs times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s) times n f = runStateT $ replicateM n (StateT f) diff --git a/src/File/Binary/Instances/BigEndian.hs b/src/File/Binary/Instances/BigEndian.hs --- a/src/File/Binary/Instances/BigEndian.hs +++ b/src/File/Binary/Instances/BigEndian.hs @@ -14,17 +14,17 @@ instance Field Integer where type FieldArgument Integer = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n instance Field Int where type FieldArgument Int = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n instance Field Word32 where type FieldArgument Word32 = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n wordsToInt :: (Num i, Bits i) => [Word8] -> i wordsToInt = foldl (\i w -> i `shiftL` 8 .|. fromIntegral w) 0 @@ -40,11 +40,21 @@ fromBits () ([], bin) = fromBits () $ pop bin fromBits () (bs, bin) = return (last bs, (init bs, bin)) consToBits () b (bs, bin) - | length bs == 7 = ([], push (bs ++ [b], bin)) - | otherwise = (bs ++ [b], bin) + | length bs == 7 = return ([], push (bs ++ [b], bin)) + | otherwise = return (bs ++ [b], bin) data BitsInt = BitsInt { bitsInt :: Int } deriving Show +instance Eq BitsInt where + BitsInt i1 == BitsInt i2 = i1 == i2 + +instance Num BitsInt where + BitsInt i1 + BitsInt i2 = BitsInt $ i1 + i2 + BitsInt i1 * BitsInt i2 = BitsInt $ i1 * i2 + abs (BitsInt i) = BitsInt $ abs i + signum (BitsInt i) = BitsInt $ signum i + fromInteger i = BitsInt $ fromInteger i + instance Field BitsInt where type FieldArgument BitsInt = Int fromBits n = return . first BitsInt . fb n 0 @@ -56,13 +66,14 @@ toEnum' :: (Enum e, Integral i) => i -> e toEnum' = toEnum . fromIntegral -fb :: (Bits f, Binary b) => Int -> f -> ([Bool], b) -> (f, ([Bool], b)) +fb :: (Bits f, Num f, Binary b) => Int -> f -> ([Bool], b) -> (f, ([Bool], b)) fb 0 r bb = (r, bb) fb n r ([], b) = fb n r $ pop b fb n r (bs, b) = fb (n - 1) (r `shiftL` 1 .|. fromEnum' (last bs)) (init bs, b) -ctb :: (Bits f, Integral f, Binary b) => Int -> f -> ([Bool], b) -> ([Bool], b) -ctb 0 _ r = r +ctb :: (Bits f, Integral f, Binary b, Functor m, Monad m) => + Int -> f -> ([Bool], b) -> m ([Bool], b) +ctb 0 _ r = return r ctb n f (bs, b) | length bs == 7 = ctb (n - 1) (f `shiftR` 1) ([], push (bs ++ [bit], b)) | otherwise = ctb (n - 1) (f `shiftR` 1) (bs ++ [bit], b) diff --git a/src/File/Binary/Instances/LittleEndian.hs b/src/File/Binary/Instances/LittleEndian.hs --- a/src/File/Binary/Instances/LittleEndian.hs +++ b/src/File/Binary/Instances/LittleEndian.hs @@ -8,22 +8,22 @@ import Data.Word (Word8, Word32) import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR) import Control.Arrow (first) -import Control.Applicative +import Control.Monad instance Field Int where type FieldArgument Int = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n instance Field Word32 where type FieldArgument Word32 = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n instance Field Integer where type FieldArgument Integer = Int fromBinary n = return . first (wordsToInt . unpack) . getBytes n - toBinary n = makeBinary . pack . intToWords n + toBinary n = return . makeBinary . pack . intToWords n wordsToInt :: (Num i, Bits i) => [Word8] -> i wordsToInt = foldr (\w i -> fromIntegral w .|. i `shiftL` 8) 0 @@ -37,21 +37,31 @@ fromBits () ([], bin) = fromBits () $ pop bin fromBits () (b : bs, bin) = return (b, (bs, bin)) consToBits () b (bs, bin) - | length bs == 7 = ([], push (b : bs, bin)) - | otherwise = (b : bs, bin) + | length bs == 7 = return ([], push (b : bs, bin)) + | otherwise = return (b : bs, bin) -data BitsInt = BitsInt { bitsInt :: Int } deriving Show +newtype BitsInt = BitsInt { bitsInt :: Int } deriving Show +instance Eq BitsInt where + BitsInt i1 == BitsInt i2 = i1 == i2 + +instance Num BitsInt where + BitsInt i1 + BitsInt i2 = BitsInt $ i1 + i2 + BitsInt i1 * BitsInt i2 = BitsInt $ i1 * i2 + abs (BitsInt i) = BitsInt $ abs i + signum (BitsInt i) = BitsInt $ signum i + fromInteger i = BitsInt $ fromInteger i + instance Field BitsInt where type FieldArgument BitsInt = Int fromBits 0 bb = return (BitsInt 0, bb) fromBits n ([], bin) = fromBits n $ pop bin fromBits n (b : bs, bin) = first - (BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) <$> + (BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) `liftM` fromBits (n - 1) (bs, bin) - consToBits 0 _ bb = bb - consToBits n (BitsInt f) bb = let - (bs, bin) = consToBits (n - 1) (BitsInt $ f `shiftR` 1) bb in - if length bs == 7 + consToBits 0 _ bb = return bb + consToBits n (BitsInt f) bb = do + (bs, bin) <- consToBits (n - 1) (BitsInt $ f `shiftR` 1) bb + return $ if length bs == 7 then ([], push (toEnum (f .&. 1) : bs, bin)) else (toEnum (f .&. 1) : bs, bin) 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 @@ -13,7 +13,7 @@ module File.Binary.Parse ( parse, Structure, sName, sDerive, sArgName, sArgType, sItems, - SItem, argOf, valueOf, constant, Value, expression + SItem, argOf, valueOf, constant, Value, expression, rights' ) where import Text.Peggy (peggy, parseString, space, defaultDelimiter) @@ -22,7 +22,7 @@ TypeQ, conT, listT, tupleT, appT, Name, mkName, FieldExp) import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Control.Applicative ((<$>), (<*>)) -import Control.Arrow(second) +import Control.Arrow(first) import Data.Maybe (fromMaybe) import Numeric (readHex) @@ -41,10 +41,21 @@ data SItem = SItem { argOf :: Expression, valueOf :: Value } type Expression = Reader ([FieldExp], ExpQ, String) ExpQ +rights' :: [Value] -> [(Name, TypeQ)] +rights' = map (first fromRight) . filter (isRight . fst) + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "not Right" + +isRight :: Either a b -> Bool +isRight (Right x) = True +isRight _ = False + expression :: [FieldExp] -> ExpQ -> String -> Expression -> ExpQ expression ret arg argn e = runReader e (ret, arg, argn) -type Value = Either Constant (Name, TypeQ) +type Value = (Either Constant Name, TypeQ) data Constant = Integer Integer | String String | Bool Bool deriving Show @@ -54,6 +65,7 @@ constant _ _ f (Bool b) = f b identify :: String -> ([FieldExp], ExpQ, String) -> ExpQ +-- identify "_" _ = wildP identify var (ret, arg, argn) | var == argn = arg | Just var' <- lookup (mkName var) ret = return var' @@ -74,13 +86,14 @@ / '' { ("_", conT $ mkName "()") } dat :: SItem = emp ex? sp typS sp ':' sp val - { SItem (fromMaybe (return $ conE $ mkName "()") $2) $ - either Left (Right . second (const $4)) $7 } + { SItem (fromMaybe (return $ conE $ mkName "()") $2) ($7, $4) } +-- { SItem (fromMaybe (return $ conE $ mkName "()") $2) $ +-- either Left (Right . second (const $4)) $7 } typS :: TypeQ = '{' typ '}' / '' { conT $ mkName "Int" } -val :: Value - = var { Right $ (mkName $1, conT $ mkName "()") } +val :: Either Constant Name + = var { Right $ mkName $1 } / num { Left $ Integer $1 } / string { Left $ String $1 } / 'True' { Left $ Bool True } @@ -137,7 +150,7 @@ / 'SUB' { '\SUB' } ln :: String = [A-Z][_a-zA-Z0-9]* { $1 : $2 } -sn :: String = [a-z][_a-zA-Z0-9]* { $1 : $2 } +sn :: String = [_a-z][_a-zA-Z0-9]* { $1 : $2 } sp :: () = (comm / [ \t])* { () } emp :: () = (comm / lcomm / [ \n])* { () } diff --git a/src/File/Binary/Quote.hs b/src/File/Binary/Quote.hs --- a/src/File/Binary/Quote.hs +++ b/src/File/Binary/Quote.hs @@ -4,7 +4,7 @@ import File.Binary.Parse ( parse, Structure, sName, sDerive, sArgName, sArgType, sItems, - SItem, argOf, valueOf, constant, Value, expression) + SItem, argOf, valueOf, constant, Value, expression, rights') import File.Binary.Classes (Field(..), Binary(..)) import Language.Haskell.TH ( Q, DecsQ, ClauseQ, Clause, ExpQ, Exp(..), Name, FieldExp, StmtQ, @@ -15,11 +15,10 @@ doE, bindS, noBindS, letS, tildeP) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Data.ByteString.Lazy.Char8 (pack) -import Control.Monad (zipWithM) +import Control.Monad (zipWithM, foldM) import "monads-tf" Control.Monad.State (StateT, runStateT, get, put, lift) import "monads-tf" Control.Monad.Writer (WriterT, runWriterT, tell) import Control.Applicative ((<$>), (<*>)) -import Data.Either (rights) -------------------------------------------------------------------------------- @@ -34,7 +33,7 @@ (\d i -> [d, i]) <$> dataD (cxt []) c [] [recC c $ map (varStrictType <$> fst <*> strictType notStrict . snd) $ - rights $ map valueOf $ sItems bs] (sDerive bs) + rights' $ map valueOf $ sItems bs] (sDerive bs) <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [ tySynInstD ''FieldArgument [conT c] $ sArgType bs, funD 'fromBits $ (: []) $ return r, @@ -69,23 +68,23 @@ liftW = lift readf' :: ([FieldExp] -> ExpQ) -> Value -> FieldMonad [StmtQ] -readf' size (Left val) = do +readf' size (Left val, typ) = do (bin, rts2) <- get [rv, rest, bin'] <- liftQ $ mapM newName ["_rv", "_rst", "_bin'"] put (varE bin', rts2) let lit = constant - ((`sigE` conT ''Integer) . litE . integerL) + ((`sigE` typ) . litE . integerL) (appE (varE 'pack) . litE . stringL) (\b -> conE (if b then 'True else 'False)) val return [bindS (tupP [varP rv, varP rest]) (appsE [varE 'fromBits, size rts2, bin]), noBindS $ condE (infixApp (varE rv) (varE '(==)) lit) [e| return () |] - [e| Left "bad value" |], + [e| fail "bad value" |], letS [flip (valD $ varP bin') [] $ normalB $ condE (infixApp (varE rv) (varE '(==)) lit) (varE rest) [e| error "bad value" |]]] -readf' size (Right (var, _)) = do +readf' size (Right var, _) = do (bin, rts2) <- get [bin', tmp] <- liftQ $ mapM newName ["_bin'", "_tmp"] put (varE bin', (var, VarE tmp) : rts2) @@ -98,16 +97,16 @@ [arg, dat, bin0] <- mapM newName ["_arg", "_dat", "bin0"] let fe' = map ((\n -> (n, VarE n `AppE` VarE dat)) . fst) fe flip (clause [varP arg, varP dat, varP bin0]) [] $ normalB $ - appE (appsE [varE 'foldr, varE '($), varE bin0]) $ listE $ - (<$> items) $ writef dat + appE (appsE [varE 'foldM, varE 'flip `appE` varE '($), varE bin0]) $ + (varE 'reverse `appE`) $ listE $ (<$> items) $ writef dat <$> expression fe' (varE arg) argn . argOf <*> valueOf writef :: Name -> ExpQ -> Value -> ExpQ -writef _ size (Left val) = varE 'consToBits `appE` size `appE` constant - ((`sigE` conT ''Integer) . litE . integerL) +writef _ size (Left val, typ) = varE 'consToBits `appE` size `appE` constant + ((`sigE` typ) . litE . integerL) (appE (varE 'pack) . litE . stringL) (\b -> conE (if b then 'True else 'False)) val -writef dat size (Right (rec, _)) = +writef dat size (Right rec, _) = varE 'consToBits `appE` size `appE` (varE rec `appE` varE dat)