diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) Lars Petersen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/binary-generic.cabal b/binary-generic.cabal new file mode 100644 --- /dev/null +++ b/binary-generic.cabal @@ -0,0 +1,30 @@ +name: binary-generic +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Lars Petersen +maintainer: Lars Petersen +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. +synopsis: Generic binary serialisation using binary and syb. +category: Data, Parsing +stability: experimental +build-type: Simple +cabal-version: >= 1.2 +tested-with: GHC == 6.12.1 +extra-source-files: README + +library + build-depends: base >= 3 && < 5, + binary, + data-binary-ieee754, + bytestring, + syb, + text + hs-source-dirs: src + exposed-modules: Data.Binary.Generic + ghc-options: -Wall + diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Generic.hs @@ -0,0 +1,123 @@ +{-# OPTIONS -XNoMonomorphismRestriction #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Generic +-- Copyright : Lars Petersen +-- License : BSD3-style (see LICENSE) +-- +-- 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' +-- +-- - 'Data.ByteString.Lazy.ByteString' +-- +-- - 'Data.Text.Lazy.Text' encoded as Utf8 +-- +-- '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. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Generic ( + + getGeneric + , putGeneric + + ) where + +import Data.Binary +import Data.Binary.IEEE754 (putFloat32be, getFloat32be, putFloat64be, getFloat64be) +import Data.ByteString.Lazy (ByteString) + +import Data.Data +import Data.Generics + +import Data.Word () +import Data.Int +import Data.Text.Lazy (Text) +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) + + +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) + +