diff --git a/binary-generic.cabal b/binary-generic.cabal --- a/binary-generic.cabal +++ b/binary-generic.cabal @@ -1,5 +1,5 @@ name: binary-generic -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE author: Lars Petersen @@ -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 diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs --- a/src/Data/Binary/Generic.hs +++ b/src/Data/Binary/Generic.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XNoMonomorphismRestriction #-} +{-# OPTIONS -XNoMonomorphismRestriction -XRankNTypes #-} ----------------------------------------------------------------------------- -- | @@ -9,115 +9,90 @@ -- Maintainer : Lars Petersen -- 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." diff --git a/src/Data/Binary/Generic/Extensions.hs b/src/Data/Binary/Generic/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Generic/Extensions.hs @@ -0,0 +1,249 @@ +{-# OPTIONS -XNoMonomorphismRestriction #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Generic.Extensions +-- Copyright : Lars Petersen +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lars Petersen +-- 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 +