binary-generic 0.1 → 0.2

raw patch · 3 files changed

+325/−98 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• binary-generic.cabal +7/−4
• src/Data/Binary/Generic.hs +69/−94
• src/Data/Binary/Generic/Extensions.hs +249/−0

@@ -1,5 +1,5 @@ name:            binary-generic-version:         0.1+version:         0.2 license:         BSD3 license-file:    LICENSE author:          Lars Petersen <info@lars-petersen.net>@@ -7,8 +7,10 @@ homepage:        http://github.com/lpeterse/binary-generic description:     Instead of manual or semi-automated generation of                  instances of 'Data.Binary.Binary' you just derive -                 'Data.Data' and the library automatically figures-                 out how to (de-)serialize the type.+                 'Data.Data.Data' and the library automatically+                 figures out how to (de-)serialize the type.+                 You may also define your own type-specific +                 stack of serialisation functions. synopsis:        Generic binary serialisation using binary and syb. category:        Data, Parsing stability:       experimental@@ -25,6 +27,7 @@                    syb,                    text   hs-source-dirs:  src-  exposed-modules: Data.Binary.Generic+  exposed-modules: Data.Binary.Generic,+                   Data.Binary.Generic.Extensions   ghc-options:     -Wall 

@@ -1,4 +1,4 @@-{-# OPTIONS -XNoMonomorphismRestriction #-}+{-# OPTIONS -XNoMonomorphismRestriction -XRankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -9,115 +9,90 @@ -- Maintainer  : Lars Petersen <info@lars-petersen.net> -- Stability   : experimental ----- The following primitive datatypes are used as basecases and get serialized--- according to their instances of @Data.Binary@: -- --- - 'Char'--- --- - 'Int'--- --- - 'Word'--- --- - 'Integer'--- --- - 'Int8'--- --- - 'Int16'--- --- - 'Int32'--- --- - 'Int64'--- --- - 'Word8'--- --- - 'Word16'--- --- - 'Word32'--- --- - 'Word64'+-- For any algebraic datatype just make it an instance of class @Data.Data.Data@+-- by simply deriving 'Data' on definition or try stand-alone-deriving. This+-- allows the library to enumerate the value constructors and thereby+-- encoding their index. Notice that serialisation depends on a type's+-- structure. Serialisations might get unreadable if the type is altered. -- --- - 'Data.ByteString.Lazy.ByteString'+-- 'getGeneric' and 'putGeneric' implement a selection of type-specific +-- defaults and are grounded by a canonical serialisation for all algebraic+-- types that instantiate 'Data.Data.Data'.+-- Have a look at @Data.Binary.Generic.Extensions@ for details. -- --- - 'Data.Text.Lazy.Text' encoded as Utf8+-- If you want to ground your own type-specific stack @myStack@ of extensions+-- write the following for the @Get@-part (the @Put@-part follows+-- analogously): -- --- 'Float' and 'Double' are serialized according to 'IEEE754'.--- For any algebraic datatype just make it an instance of class @Data.Data@--- by simply deriving 'Data' on definition or try stand-alone-deriving.+-- > getMyStack :: Data a => Get a+-- > getMyStack  = myStack (getGenericByCallback getMyStack) -- -----------------------------------------------------------------------------  module Data.Binary.Generic (-    -     getGeneric++     getAlgebraic+   , putAlgebraic++   , getGeneric    , putGeneric +   , getGenericByCallback+   , putGenericByCallback+    ) where +import Data.Data import Data.Binary-import Data.Binary.IEEE754 (putFloat32be, getFloat32be, putFloat64be, getFloat64be)-import Data.ByteString.Lazy (ByteString)  +import Data.Binary.Put  (putWord16be)+import Data.Binary.Get  (getWord16be)+import Data.Binary.Generic.Extensions -import Data.Data-import Data.Generics -import Data.Word ()-import Data.Int  -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)+getAlgebraic :: Data a => Get a+getAlgebraic  = getGenericByCallback getAlgebraic +putAlgebraic :: Data a => a -> Put+putAlgebraic  = putGenericByCallback putAlgebraic -getGeneric :: (Data a) => Get a-getGeneric  = generalCase -              `extR` (get          :: Get Char)-              `extR` (get          :: Get Int)-              `extR` (get          :: Get Word)-              `extR` (get          :: Get Integer)-              `extR` (get          :: Get Int8)-              `extR` (get          :: Get Int16)-              `extR` (get          :: Get Int32)-              `extR` (get          :: Get Int64)-              `extR` (get          :: Get Word8)-              `extR` (get          :: Get Word16)-              `extR` (get          :: Get Word32)-              `extR` (get          :: Get Word64)-              `extR` (get          :: Get ByteString)-              `extR` (getText      :: Get Text)-              `extR` (getFloat32be :: Get Float)-              `extR` (getFloat64be :: Get Double)-              where-                getText       = get >>= (return . decodeUtf8)-                fromIntegralM = return . fromIntegral-                myDataType    = dataTypeOf ((undefined :: Get b -> b) generalCase)-                generalCase   = let imax  = maxConstrIndex myDataType-                                    index | imax == 1   = return 1 :: Get Int-                                          | imax <= 255 = (get :: Get Word8)  >>= fromIntegralM-                                          | otherwise   = (get :: Get Word16) >>= fromIntegralM-                                in  index >>= \i-> fromConstrM getGeneric (indexConstr myDataType i) -putGeneric  :: (Data a) => a -> Put -putGeneric   = generalCase -               `extQ` (put              :: Char       -> Put)-               `extQ` (put              :: Int        -> Put) -               `extQ` (put              :: Word       -> Put) -               `extQ` (put              :: Integer    -> Put)-               `extQ` (put              :: Int8       -> Put)-               `extQ` (put              :: Int16      -> Put)-               `extQ` (put              :: Int32      -> Put)-               `extQ` (put              :: Int64      -> Put)-               `extQ` (put              :: Word8      -> Put)-               `extQ` (put              :: Word16     -> Put)-               `extQ` (put              :: Word32     -> Put)-               `extQ` (put              :: Word64     -> Put)-               `extQ` (put              :: ByteString -> Put)-               `extQ` (put . encodeUtf8 :: Text       -> Put)-               `extQ` (putFloat32be     :: Float      -> Put)-               `extQ` (putFloat64be     :: Double     -> Put)-               where-                 generalCase t = let i    = fromIntegral $ constrIndex (toConstr t)-                                     imax = maxConstrIndex (dataTypeOf t) -                                     putIndex | imax == 1   =                      return ()-                                              | imax <= 255 = put (i :: Word8)  >> return ()-                                              | otherwise   = put (i :: Word16) >> return ()-                                 in  foldl (>>) putIndex (gmapQ putGeneric t) -  +getGeneric   :: Data a => Get a+getGeneric    = getExtDefault (getGenericByCallback getGeneric)++putGeneric   :: Data a => a -> Put+putGeneric    = putExtDefault (putGenericByCallback putGeneric)+++--------------------------------------------------------------+-- algebraic basecases with callbacks+--------------------------------------------------------------++getGenericByCallback  :: Data a => (forall d. Data d => Get d) -> Get a+getGenericByCallback c = generalCase +       where+         myDataType    = dataTypeOf ((undefined :: Get b -> b) generalCase)+         typeName      = showsTypeRep (typeOf $ (undefined :: Get b -> b) generalCase) ""+         generalCase   = let imax  = maxConstrIndex myDataType+                             index | imax == 0     = error "getGeneric: constructor count is 0."+                                   | imax == 1     = return 0     :: Get Int+                                   | imax <= 256   = getWord8    >>= (return . fromIntegral)+                                   | imax <= 65536 = getWord16be >>= (return . fromIntegral)+                                   | otherwise     = error "getGeneric: constructor count out of range."+                         in  if isAlgType myDataType+                               then index >>= \i-> fromConstrM c (indexConstr myDataType (i+1))+                               else error $ "getGeneric: `" ++ typeName ++ "' is not algebraic."++putGenericByCallback    :: Data a => (forall d. Data d => d -> Put) -> a -> Put +putGenericByCallback c t = let i        = fromIntegral $ constrIndex (toConstr t) - 1 +                               imax     = maxConstrIndex (dataTypeOf t) +                               typeName = showsTypeRep (typeOf t) ""+                               putIndex | imax == 0     = error "putGeneric: constructor count is 0."+                                        | imax == 1     = return      ()+                                        | imax <= 256   = putWord8     i +                                        | imax <= 65536 = putWord16be  i +                                        | otherwise     = error "putGeneric: constructor count out of range."+                               in  if isAlgType (dataTypeOf t)+                                     then foldl (>>) putIndex (gmapQ c t) +                                     else error $ "putGeneric: `" ++ typeName ++ "' is not algebraic." 

@@ -0,0 +1,249 @@+{-# OPTIONS -XNoMonomorphismRestriction #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Generic.Extensions+-- Copyright   : Lars Petersen+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Lars Petersen <info@lars-petersen.net>+-- Stability   : experimental+--+-- You can build your own type-specific stacks. For example the default stack+-- looks like this, whereas the ordering determines, which function matches+-- first for a specific type. This especially allows you to override the+-- default choices:+--+-- > getExtDefault    :: Typeable a => Get a -> Get a+-- > getExtDefault     = getExtInteger+-- >                   . getExtChar+-- >                   . getExtWord+-- >                   . getExtInt+-- >                   . getExtFloat+-- >                   . getExtText+-- >                   . getExtByteString+-- >+-- > putExtDefault    :: Typeable a => (a -> Put) -> a -> Put+-- > putExtDefault     = putExtInteger+-- >                   . putExtChar+-- >                   . putExtWord+-- >                   . putExtInt+-- >                   . putExtFloat+-- >                   . putExtText+-- >                   . putExtByteString+-- +-- Notice that these stacks have to be grounded, ideally with something+-- that handles algebraic types.+-- Have a look at @Data.Binary.Generic@ how this is done for the default +-- stack.+-- +-- IMPORTANT: You cannot simply apply an extension to 'getGeneric' or+-- 'putGeneric', since these do a recursive call at the bottom level+-- which points to the top of the stack.+-- +--+-----------------------------------------------------------------------------++module Data.Binary.Generic.Extensions (+    +     extGet+   , extPut++   , getExtDefault+   , putExtDefault++   , getExtInteger+   , putExtInteger+   , getExtChar+   , putExtChar+   , getExtWord+   , putExtWord+   , getExtInt+   , putExtInt+   , getExtFloat+   , putExtFloat+   , getExtText+   , putExtText+   , getExtByteString+   , putExtByteString++   ) where++import Data.Binary+import Data.Binary.IEEE754 (putFloat32be, getFloat32be, putFloat64be, getFloat64be)++import Data.Data+import Data.Generics++import Data.Word ()+import Data.Int  +import Data.List+import Data.Bits+import Data.ByteString.Lazy              (ByteString)  ++import qualified Data.Text               as T +import qualified Data.Text.Encoding      as TE+import qualified Data.Text.Lazy          as LT +import qualified Data.Text.Lazy.Encoding as LTE++import Control.Monad+++extGet           :: (Monad m, Typeable a, Typeable b) => m b -> m a -> m a+extGet            = flip extR++extPut           :: (Typeable a, Typeable b) => (b -> q) -> (a -> q) -> a -> q+extPut            = flip extQ+++getExtDefault    :: Typeable a => Get a -> Get a+getExtDefault     = getExtInteger+                  . getExtChar+                  . getExtWord+                  . getExtInt+                  . getExtFloat+                  . getExtText+                  . getExtByteString++putExtDefault    :: Typeable a => (a -> Put) -> a -> Put+putExtDefault     = putExtInteger+                  . putExtChar+                  . putExtWord+                  . putExtInt+                  . putExtFloat+                  . putExtText+                  . putExtByteString+++getExtInteger    :: Typeable a => Get a -> Get a+getExtInteger     = extGet         (getInteger :: Get        Integer) ++putExtInteger    :: Typeable a => (a -> Put) -> a -> Put +putExtInteger     = extPut         (putInteger :: Integer     -> Put)+++getExtChar       :: Typeable a => Get a -> Get a+getExtChar        = extGet         (get        :: Get           Char) ++putExtChar       :: Typeable a => (a -> Put) -> a -> Put +putExtChar        = extPut         (put        :: Char        -> Put)+++getExtWord       :: Typeable a => Get a -> Get a+getExtWord        =  extGet        (get        :: Get         Word  )+                  .  extGet        (get        :: Get         Word8 ) +                  .  extGet        (get        :: Get         Word16) +                  .  extGet        (get        :: Get         Word32) +                  .  extGet        (get        :: Get         Word64) ++putExtWord       :: Typeable a => (a -> Put) -> a -> Put +putExtWord        =  extPut        (put        :: Word        -> Put) +                  .  extPut        (put        :: Word8       -> Put) +                  .  extPut        (put        :: Word16      -> Put) +                  .  extPut        (put        :: Word32      -> Put) +                  .  extPut        (put        :: Word64      -> Put)  + ++getExtInt        :: Typeable a => Get a -> Get a+getExtInt         =  extGet        (get        :: Get         Int  )+                  .  extGet        (get        :: Get         Int8 ) +                  .  extGet        (get        :: Get         Int16) +                  .  extGet        (get        :: Get         Int32) +                  .  extGet        (get        :: Get         Int64) ++putExtInt        :: Typeable a => (a -> Put) -> a -> Put +putExtInt         =  extPut        (put        :: Int         -> Put) +                  .  extPut        (put        :: Int8        -> Put) +                  .  extPut        (put        :: Int16       -> Put) +                  .  extPut        (put        :: Int32       -> Put) +                  .  extPut        (put        :: Int64       -> Put)  +++getExtFloat      :: Typeable a => Get a -> Get a+getExtFloat       = extGet       (getFloat32be :: Get         Float)+                  . extGet       (getFloat64be :: Get        Double)++putExtFloat      :: Typeable a => (a -> Put) -> a -> Put +putExtFloat       = extPut       (putFloat32be :: Float      -> Put)+                  . extPut       (putFloat64be :: Double     -> Put)+++getExtText       :: Typeable a => Get a -> Get a+getExtText        = extGet         (getText    :: Get         T.Text) +                  . extGet         (getTextL   :: Get        LT.Text)++putExtText       :: Typeable a => (a -> Put) -> a -> Put +putExtText        = extPut         (putText    :: T.Text      -> Put)+                  . extPut         (putTextL   :: LT.Text     -> Put)+++getExtByteString :: Typeable a => Get a -> Get a+getExtByteString  = extGet         (get        :: Get     ByteString) ++putExtByteString :: Typeable a => (a -> Put) -> a -> Put +putExtByteString  = extPut         (put        :: ByteString  -> Put)++++-------------------------------------------------------------------+-- serialisation for Data.Text+-------------------------------------------------------------------++getText  :: Get  T.Text+getText   = get >>= (return .  TE.decodeUtf8)++getTextL :: Get LT.Text+getTextL  = get >>= (return . LTE.decodeUtf8)++putText  :: T.Text  -> Put+putText   = put .  TE.encodeUtf8++putTextL :: LT.Text -> Put+putTextL  = put . LTE.encodeUtf8+++-------------------------------------------------------------------+-- integer serialisation with consistent big-endian byteorder+-------------------------------------------------------------------+++{-# INLINE putInteger #-}+putInteger  :: Integer -> Put +putInteger n | n >= lo && n <= hi = do+        putWord8 0+        put (fromIntegral n :: Int32)  -- fast path+     where+        lo = fromIntegral (minBound :: Int32) :: Integer+        hi = fromIntegral (maxBound :: Int32) :: Integer+putInteger n = do+        putWord8 1+        put sign+        put $ reverse (unroll (abs n))         -- unroll the bytes+     where+        sign = fromIntegral (signum n) :: Word8++{-# INLINE getInteger #-}+getInteger  :: Get Integer+getInteger   = do+        tag <- get :: Get Word8+        case tag of+            0 -> liftM fromIntegral (get :: Get Int32)+            _ -> do sign  <- get+                    bytes <- get+                    let v = roll (reverse bytes)+                    return $! if sign == (1 :: Word8) then v else - v++--+-- Fold and unfold an Integer to and from a list of its bytes+--+unroll :: Integer -> [Word8]+unroll = unfoldr step+  where+    step 0 = Nothing+    step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll   = foldr unstep 0+  where+    unstep b a = a `shiftL` 8 .|. fromIntegral b+