diff --git a/binary-file.cabal b/binary-file.cabal --- a/binary-file.cabal +++ b/binary-file.cabal @@ -2,10 +2,11 @@ cabal-version: >= 1.8 name: binary-file -version: 0.15.0 +version: 0.15.9 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo +homepage: https://skami.iocikun.jp/haskell/packages/binary-file license: BSD3 license-file: LICENSE @@ -29,7 +30,7 @@ > main = do > [inf] <- getArgs > cnt <- BS.readFile inf - > let (bmp, rest) = fromBinary () cnt :: (Bitmap, String) + > let Right (bmp, rest) = fromBinary () cnt :: (Bitmap, String) > print bmp > > instance Field (Int, Int, Int) where @@ -89,7 +90,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/binary-file.git - tag: 0.15.0 + tag: 0.15.9 library hs-source-dirs: src diff --git a/examples/readBitmap.hs b/examples/readBitmap.hs --- a/examples/readBitmap.hs +++ b/examples/readBitmap.hs @@ -20,7 +20,7 @@ readBitmap :: FilePath -> IO Bitmap readBitmap fp = do - (bmp, "") <- fromBinary () <$> readBinaryFile fp + Right (bmp, "") <- fromBinary () <$> readBinaryFile fp return bmp writeBitmap :: FilePath -> Bitmap -> IO () @@ -28,11 +28,11 @@ instance Field (Int, Int, Int) where type FieldArgument (Int, Int, Int) = () - fromBinary _ s = let - (b, rest) = fromBinary 1 s - (g, rest') = fromBinary 1 rest - (r, rest'') = fromBinary 1 rest' in - ((b, g, r), snd $ getBytes 1 rest'') + fromBinary _ s = do + (b, rest) <- fromBinary 1 s + (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, diff --git a/examples/readPNG.hs b/examples/readPNG.hs --- a/examples/readPNG.hs +++ b/examples/readPNG.hs @@ -44,7 +44,7 @@ readPNG :: FilePath -> IO PNG readPNG fp = do - (png, "") <- fromBinary () <$> BS.readFile fp + Right (png, "") <- fromBinary () <$> BS.readFile fp return png writePNG :: FilePath -> PNG -> IO () @@ -98,7 +98,7 @@ instance Field Word32 where type FieldArgument Word32 = Int toBinary n = makeBinary . pack . intToWords n - fromBinary n = first (wordsToInt . unpack) . getBytes n + fromBinary n = return . first (wordsToInt . unpack) . getBytes n intToWords :: (Bits i, Integral i) => Int -> i -> [Word8] intToWords = itw [] @@ -134,16 +134,16 @@ toBinary (n, _) (ChunkTEXT c) = toBinary n c toBinary _ (ChunkIEND c) = toBinary () c toBinary (n, _) (Others str) = toBinary ((), Just n) str - fromBinary (_, "IHDR") = first ChunkIHDR . fromBinary () - fromBinary (_, "gAMA") = first ChunkGAMA . fromBinary () - fromBinary (_, "sRGB") = first ChunkSRGB . fromBinary () - fromBinary (n, "cHRM") = first ChunkCHRM . fromBinary n - fromBinary (n, "PLTE") = first ChunkPLTE . fromBinary n - fromBinary (_, "bKGD") = first ChunkBKGD . fromBinary () - fromBinary (n, "IDAT") = first ChunkIDAT . fromBinary n - fromBinary (n, "tEXt") = first ChunkTEXT . fromBinary n - fromBinary (_, "IEND") = first ChunkIEND . fromBinary () - fromBinary (n, _) = first Others . fromBinary ((), Just n) + fromBinary (_, "IHDR") = fmap (first ChunkIHDR) . fromBinary () + fromBinary (_, "gAMA") = fmap (first ChunkGAMA) . fromBinary () + fromBinary (_, "sRGB") = fmap (first ChunkSRGB) . fromBinary () + fromBinary (n, "cHRM") = fmap (first ChunkCHRM) . fromBinary n + fromBinary (n, "PLTE") = fmap (first ChunkPLTE) . fromBinary n + fromBinary (_, "bKGD") = fmap (first ChunkBKGD) . fromBinary () + 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) [binary| @@ -207,11 +207,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] - fromBinary _ s = let - (r, rest) = fromBinary 1 s - (g, rest') = fromBinary 1 rest - (b, rest'') = fromBinary 1 rest' in - ((r, g, b), rest'') + fromBinary _ s = do + (r, rest) <- fromBinary 1 s + (g, rest') <- fromBinary 1 rest + (b, rest'') <- fromBinary 1 rest' + return ((r, g, b), rest'') [binary| 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 @@ -6,24 +6,27 @@ import Data.Bits ((.&.), (.|.), shiftL, shiftR) import Data.Monoid (Monoid, mappend, mempty) import Control.Arrow (first, second) +import Control.Applicative type AddBits b = ([Bool], b) class Field f where type FieldArgument f - fromBinary :: Binary b => FieldArgument f -> b -> (f, b) + fromBinary :: Binary b => FieldArgument f -> b -> Either String (f, b) toBinary :: Binary b => FieldArgument f -> f -> b - fromBits :: Binary b => FieldArgument f -> AddBits b -> (f, AddBits b) + fromBits :: Binary b => FieldArgument f -> AddBits b -> Either String (f, AddBits b) consToBits :: Binary b => FieldArgument f -> f -> AddBits b -> AddBits b - fromBits a ([], b) = second ([] ,) $ fromBinary a b + fromBits a ([], b) = second ([] ,) <$> 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)" - fromBinary a b = case fromBits a ([], b) of - (f, ([], rest)) -> (f, rest) - _ -> error "fromBinary: 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)" 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 @@ -9,8 +9,7 @@ import Data.ByteString.Lazy.Char8 (pack, unpack) import qualified Data.ByteString as BS (ByteString, take, drop, concat) import Control.Monad (replicateM) -import "monads-tf" Control.Monad.State (StateT(..), runState, gets) -import "monads-tf" Control.Monad.Identity (Identity(..)) +import "monads-tf" Control.Monad.State (StateT(..), gets) import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, (&&&)) import Data.Monoid (mempty) @@ -19,17 +18,17 @@ instance Field ByteString where type FieldArgument ByteString = Int - fromBinary = getBytes + fromBinary a = return . getBytes a toBinary _ = makeBinary instance Field BS.ByteString where type FieldArgument BS.ByteString = Int - fromBinary n = first (BS.concat . toChunks) . getBytes n + fromBinary n = return . first (BS.concat . toChunks) . getBytes n toBinary _ = makeBinary . fromChunks . (: []) instance Field Char where type FieldArgument Char = () - fromBinary _ = first (head . unpack) . getBytes 1 + fromBinary _ = return . first (head . unpack) . getBytes 1 toBinary _ = makeBinary . pack . (: []) instance Field r => Field [r] where @@ -38,14 +37,14 @@ fromBits (a, Nothing) = mempty `whole` fromBits a consToBits (a, _) = flip $ foldr $ consToBits a -times :: Int -> (s -> (ret, s)) -> s -> ([ret], s) -times n f = runState $ replicateM n (StateT $ Identity . f) +times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s) +times n f = runStateT $ replicateM n (StateT f) -whole :: Eq s => s -> (s -> (ret, s)) -> s -> ([ret], s) -whole e f = runState $ do +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 $ Identity . f) <*> (StateT $ Identity . whole e f) + (:) <$> (StateT f) <*> (StateT $ whole e 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 @@ -13,12 +13,12 @@ instance Field Integer where type FieldArgument Integer = Int - fromBinary n = first (wordsToInt . unpack) . getBytes n + fromBinary n = return . first (wordsToInt . unpack) . getBytes n toBinary n = makeBinary . pack . intToWords n instance Field Int where type FieldArgument Int = Int - fromBinary n = first (wordsToInt . unpack) . getBytes n + fromBinary n = return . first (wordsToInt . unpack) . getBytes n toBinary n = makeBinary . pack . intToWords n wordsToInt :: Bits i => [Word8] -> i @@ -33,7 +33,7 @@ instance Field Bool where type FieldArgument Bool = () fromBits () ([], bin) = fromBits () $ pop bin - fromBits () (bs, bin) = (last bs, (init bs, 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) @@ -42,7 +42,7 @@ instance Field BitsInt where type FieldArgument BitsInt = Int - fromBits n = first BitsInt . fb n 0 + fromBits n = return . first BitsInt . fb n 0 consToBits n = ctb n . bitsInt fromEnum' :: (Enum e, Num i) => e -> i 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,15 +8,16 @@ import Data.Word (Word8) import Data.Bits (Bits, (.&.), (.|.), shiftL, shiftR) import Control.Arrow (first) +import Control.Applicative instance Field Int where type FieldArgument Int = Int - fromBinary n = first (wordsToInt . unpack) . getBytes n + fromBinary n = return . first (wordsToInt . unpack) . getBytes n toBinary n = makeBinary . pack . intToWords n instance Field Integer where type FieldArgument Integer = Int - fromBinary n = first (wordsToInt . unpack) . getBytes n + fromBinary n = return . first (wordsToInt . unpack) . getBytes n toBinary n = makeBinary . pack . intToWords n wordsToInt :: Bits i => [Word8] -> i @@ -29,7 +30,7 @@ instance Field Bool where type FieldArgument Bool = () fromBits () ([], bin) = fromBits () $ pop bin - fromBits () (b : bs, bin) = (b, (bs, bin)) + fromBits () (b : bs, bin) = return (b, (bs, bin)) consToBits () b (bs, bin) | length bs == 7 = ([], push ((b : bs), bin)) | otherwise = (b : bs, bin) @@ -38,10 +39,11 @@ instance Field BitsInt where type FieldArgument BitsInt = Int - fromBits 0 bb = (BitsInt 0, bb) + fromBits 0 bb = return (BitsInt 0, bb) fromBits n ([], bin) = fromBits n $ pop bin - fromBits n (b : bs, bin) = flip first (fromBits (n - 1) (bs, bin)) $ - BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt + fromBits n (b : bs, bin) = first + (BitsInt . (fromEnum b .|.) . (`shiftL` 1) . bitsInt) <$> + (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 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 @@ -1,4 +1,9 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts, PackageImports #-} +{-# LANGUAGE + TemplateHaskell, + QuasiQuotes, + FlexibleContexts, + PackageImports, + PatternGuards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing @@ -14,7 +19,7 @@ import Text.Peggy (peggy, parseString, space, defaultDelimiter) import Language.Haskell.TH ( ExpQ, integerL, litE, varE, conE, tupE, appE, uInfixE, parensE, - TypeQ, conT, listT, tupleT, appT, Name, mkName) + TypeQ, conT, listT, tupleT, appT, Name, mkName, FieldExp) import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Control.Applicative ((<$>), (<*>)) import Control.Arrow(second) @@ -34,9 +39,9 @@ sItems :: [SItem] } data SItem = SItem { argOf :: Expression, valueOf :: Value } -type Expression = Reader (ExpQ, ExpQ, String) ExpQ +type Expression = Reader ([FieldExp], ExpQ, String) ExpQ -expression :: ExpQ -> ExpQ -> String -> Expression -> ExpQ +expression :: [FieldExp] -> ExpQ -> String -> Expression -> ExpQ expression ret arg argn e = runReader e (ret, arg, argn) type Value = Either Constant (Name, TypeQ) @@ -48,11 +53,11 @@ constant _ f _ (String s) = f s constant _ _ f (Bool b) = f b -identify :: String -> (ExpQ, ExpQ, String) -> ExpQ +identify :: String -> ([FieldExp], ExpQ, String) -> ExpQ identify var (ret, arg, argn) | var == argn = arg - | '.' `elem` var = varE $ mkName var - | otherwise = appE (varE $ mkName var) ret + | Just var' <- lookup (mkName var) ret = return var' + | otherwise = varE $ mkName var [peggy| 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 @@ -7,11 +7,12 @@ SItem, argOf, valueOf, constant, Value, expression) import File.Binary.Classes (Field(..), Binary(..)) import Language.Haskell.TH ( - Q, DecsQ, ClauseQ, BodyQ, ExpQ, Dec, Exp(..), Name, FieldExp, + Q, DecsQ, ClauseQ, Clause, ExpQ, Exp(..), Name, FieldExp, StmtQ, dataD, recC, varStrictType, strictType, notStrict, instanceD, funD, clause, normalB, valD, tySynInstD, cxt, - conT, appT, sigE, varP, tupP, letE, condE, recConE, tupE, listE, - appE, appsE, infixApp, varE, conE, litE, newName, integerL, stringL) + conT, appT, sigE, varP, tupP, condE, recConE, tupE, listE, + appE, appsE, infixApp, varE, conE, litE, newName, integerL, stringL, + doE, bindS, noBindS, letS, tildeP) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Data.ByteString.Lazy.Char8 (pack) import Control.Monad (zipWithM) @@ -28,35 +29,38 @@ quoteDec = top . parse } top :: Structure -> DecsQ -top bs = let c = sName bs in (\d i -> [d, i]) - <$> dataD (cxt []) c [] [recC c $ +top bs = let c = sName bs in do + (r, fe) <- reading c (sArgName bs) (sItems bs) + (\d i -> [d, i]) + <$> dataD (cxt []) c [] [recC c $ map (varStrictType <$> fst <*> strictType notStrict . snd) $ rights $ map valueOf $ sItems bs] (sDerive bs) - <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [ + <*> instanceD (cxt []) (appT (conT ''Field) (conT c)) [ tySynInstD ''FieldArgument [conT c] $ sArgType bs, - funD 'fromBits $ (: []) $ reading c (sArgName bs) (sItems bs), - funD 'consToBits $ (: []) $ writing (sArgName bs) (sItems bs)] + funD 'fromBits $ (: []) $ return r, + funD 'consToBits $ (: []) $ writing fe (sArgName bs) (sItems bs)] -reading :: Name -> String -> [SItem] -> ClauseQ -reading c argn is = do +reading :: Name -> String -> [SItem] -> Q (Clause, [FieldExp]) +reading con argn is = do arg <- newName "_arg" b <- newName "bin" - flip (clause [varP arg, varP b]) [] $ letRec $ readfs c is (varE b) $ - \ret -> expression ret (varE arg) argn . argOf - -letRec :: (ExpQ -> ExpQ) -> BodyQ -letRec e = normalB $ do - (ret, rest) <- (,) <$> newName "ret" <*> newName "rest" - letE [valD (tupP [varP ret, varP rest]) (normalB $ e $ varE ret) []] $ - tupE [varE ret, varE rest] + (r, fe) <- readfs' con is (varE b) + (\ret -> expression ret (varE arg) argn . argOf) undefined + c <- flip (clause [varP arg, varP b]) [] $ normalB $ return r + return (c, fe) -readfs :: Name -> [SItem] -> ExpQ -> (ExpQ -> SItem -> ExpQ) -> ExpQ -> ExpQ -readfs con items bin size ret = do - ((binds, rest), rts) <- runWriterT $ (`runStateT` bin) $ - (zipWithM readf <$> map (size ret) <*> map valueOf) items - letE (return <$> binds) $ tupE $ (: [rest]) $ recConE con $ return <$> rts +readfs' :: Name -> [SItem] -> ExpQ -> ([FieldExp] -> SItem -> ExpQ) -> ExpQ -> + Q (Exp, [FieldExp]) +readfs' con items bin size _ = do + ((binds, (rest, rts2)), rts) <- runWriterT $ (`runStateT` (bin, [])) $ + (zipWithM readf' <$> map (flip size) <*> map valueOf) items +-- let binds' = map (uncurry bindS) binds + l <- doE $ concat binds ++ [noBindS $ + appE (varE 'return) $ tupE $ (: [rest]) $ recConE con $ + return <$> rts ] + return (l, rts2) -type FieldMonad = StateT ExpQ (WriterT [FieldExp] Q) +type FieldMonad = StateT (ExpQ, [FieldExp]) (WriterT [FieldExp] Q) liftQ :: Q a -> FieldMonad a liftQ = lift . lift @@ -64,36 +68,39 @@ liftW :: WriterT [FieldExp] Q a -> FieldMonad a liftW = lift -readf :: ExpQ -> Value -> FieldMonad Dec -readf size (Left val) = do - bin <- get - [rv, rest, bin'] <- liftQ $ mapM newName ["rv", "rst", "bin'"] - put $ varE bin' +readf' :: ([FieldExp] -> ExpQ) -> Value -> FieldMonad [StmtQ] +readf' size (Left val) = 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) (appE (varE 'pack) . litE . stringL) (\b -> if b then conE 'True else conE 'False) val - liftQ $ flip (valD $ varP bin') [] $ normalB $ - letE [flip (valD $ tupP [varP rv, varP rest]) [] $ normalB $ - appsE [varE 'fromBits, size, bin]] $ + 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" |], + letS [flip (valD $ varP bin') [] $ normalB $ condE (infixApp (varE rv) (varE '(==)) lit) (varE rest) - [e| error "bad value" |] -readf size (Right (var, _)) = do - bin <- get - [bin', tmp] <- liftQ $ mapM newName ["bin'", "tmp"] - put $ varE bin' + [e| error "bad value" |]]] +readf' size (Right (var, _)) = do + (bin, rts2) <- get + [bin', tmp] <- liftQ $ mapM newName ["_bin'", "_tmp"] + put $ (varE bin', (var, VarE tmp) : rts2) liftW $ tell [(var, VarE tmp)] - liftQ $ valD (tupP [varP tmp, varP bin']) - (normalB $ appsE [varE 'fromBits, size, bin]) [] + return [bindS (tildeP $ tupP [varP tmp, varP bin']) $ + appsE [varE 'fromBits, size rts2, bin]] -writing :: String -> [SItem] -> ClauseQ -writing argn items = do +writing :: [FieldExp] -> String -> [SItem] -> ClauseQ +writing fe argn items = do [arg, dat, bin0] <- mapM newName ["_arg", "_dat", "bin0"] + let fe' = map (\n -> (n, VarE n `AppE` VarE dat)) $ map fst fe flip (clause [varP arg, varP dat, varP bin0]) [] $ normalB $ appE (appsE [varE 'foldr, varE '($), varE bin0]) $ listE $ (<$> items) $ writef dat - <$> expression (varE dat) (varE arg) argn . argOf + <$> expression fe' (varE arg) argn . argOf <*> valueOf writef :: Name -> ExpQ -> Value -> ExpQ