diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Michael Baikov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Michael Baikov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT +OWNER 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/beamable.cabal b/beamable.cabal new file mode 100644 --- /dev/null +++ b/beamable.cabal @@ -0,0 +1,93 @@ +-- Initial beamable.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: beamable + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Generic serializer/deserializer with compact representation + +-- A longer description of the package. +description: + Yet another binary serialization library. Beamable + provides efficient and fast serialization, often requiring less + space than alternative serializers. + Incremental de-serialization is supported. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael Baikov + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: manpacket@gmail.com + +-- A copyright notice. +-- copyright: + +category: Data, Serialization + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + + +library + + Hs-source-dirs: src + Ghc-options: -Wall + -- Modules exported by the library. + exposed-modules: + Data.Beamable + Data.Beamable.Internal + Data.Beamable.Util + + -- Modules included in this library but not exported. + other-modules: + Data.Beamable.Int + Data.Beamable.Integer + + -- Other library packages from which modules are imported. + build-depends: + base >= 4.5 && < 4.7, + blaze-builder >= 0.3, + bytestring >= 0.9, + ghc-prim, + integer-gmp >= 0.4 && < 0.6, + murmur-hash >= 0.1 && < 0.2 + +test-suite beamable-tests + ghc-options: -Wall + hs-source-dirs: src tests + main-is: TestSuite.hs + type: exitcode-stdio-1.0 + + build-depends: + test-framework >= 0.4 && < 0.7, + test-framework-quickcheck2 >= 0.2 && < 0.3, + QuickCheck >= 2.4 && < 2.6, + -- Copied from regular dependencies... + base >= 4.5 && < 4.7, + blaze-builder >= 0.3, + bytestring >= 0.9, + ghc-prim, + integer-gmp >= 0.4 && < 0.6, + murmur-hash >= 0.1 && < 0.2 + +source-repository head + type: git + location: git@github.com:tsurucapital/beamable.git diff --git a/src/Data/Beamable.hs b/src/Data/Beamable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable.hs @@ -0,0 +1,113 @@ +{-# OPTIONS -Wall #-} + +-- | To serialize your own datatype first you need to add DeriveGeneric pragma to the module +-- where your data is declared, derive Generic instance for that datatype and add empty +-- instance declaration for Beamable class +-- +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- +-- > data Foo = Foo1 Int | Foo2 String deriving (Generic} +-- > instance Beamable Foo + +module Data.Beamable + ( Beamable + , beam + , unbeam + , typeSign + , encode + , decode + , encodeSigned + , decodeSigned + , Decoder + , encodeLive + , decodeLive + , feed + + -- reexport + , Builder + , toByteString + ) where + +import Data.Beamable.Internal + +import Blaze.ByteString.Builder + +import qualified Data.ByteString as B +import Data.Word (Word) + +data Decoder a + = WantAnyData + | WantPrefix B.ByteString + | WantBytes Int B.ByteString + + + +-- | Encode single value into compact bytestring, for encoding large number of values +-- use beam and toByteString from Blaze.ByteString.Builder +encode :: Beamable a => a -> B.ByteString +encode = toByteString . beam + +-- | Decode single value from bytestring. ByteString must be exactly correct size +decode :: Beamable a => B.ByteString -> a +decode bs = case unbeam bs of + (a, rest) | B.null rest -> a + _ -> error $ "Beam decode failed: There are some leftovers!" + +-- | Encode single value with extra type singature added, this adds 8 bytes to +-- binary representation, but will prevent decoding using invalid data instances +encodeSigned :: Beamable a => a -> B.ByteString +encodeSigned a = toByteString $ beam (TypeSign (typeSign a), a) + +-- | Decode single value encoded with encodeSigned +decodeSigned :: Beamable a => B.ByteString -> a +decodeSigned bs = case unbeam bs of + ((s, a), rest) | B.null rest && s == TypeSign (typeSign a) -> a + _ -> error $ "Beam decode failed: Type signature mismatch!" + + +encodeLive :: Beamable a => a -> B.ByteString +encodeLive a = toByteString . beam . toByteString . beam $ (TypeSign (typeSign a), a) + +decodeLive :: Beamable a => Decoder a +decodeLive = WantAnyData + +feed :: Beamable a => Decoder a -> B.ByteString -> Either (Decoder a) (a, B.ByteString) +feed state next = case state of + WantAnyData | validPrefix next -> handlePrefix next + WantAnyData -> Left (WantPrefix next) + + WantPrefix prev -> + let bs = prev `B.append` next + in if validPrefix bs + then handlePrefix bs + else Left (WantPrefix bs) + + WantBytes l prev -> + let bs = prev `B.append` next + in if B.length bs >= l + then doneDecoding bs + else Left (WantBytes l bs) + where + + handlePrefix :: Beamable a => B.ByteString -> Either (Decoder a) (a, B.ByteString) + handlePrefix bs | B.null bs = Left WantAnyData + handlePrefix bs = + let bsLength = (fromIntegral :: Word -> Int) $ fst $ unbeam bs + Just prefixLength = succ `fmap` B.findIndex (<128) bs + fullLength = bsLength + prefixLength + in if fullLength <= B.length bs + then doneDecoding bs + else Left (WantBytes fullLength bs) + + -- valid prefix means that there is proper word64 encoded somewhere at the front = + -- it's end marked by a byte with 8th bit off + validPrefix :: B.ByteString -> Bool + validPrefix = B.any (<128) + + doneDecoding :: Beamable a => B.ByteString -> Either (Decoder a) (a, B.ByteString) + doneDecoding bs = let (bs', rest) = unbeam bs + ((s, a), _) = unbeam bs' + in if s == TypeSign (typeSign a) + then Right (a, rest) + else error $ "Beam decode failed: Type signature mismatch!" diff --git a/src/Data/Beamable/Int.hs b/src/Data/Beamable/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable/Int.hs @@ -0,0 +1,81 @@ +module Data.Beamable.Int + ( beamInt + , unbeamInt + ) where + +import Data.Bits ((.|.), (.&.), shift, testBit) +import qualified Data.ByteString as B +import Data.List (unfoldr) +import Data.Word (Word8) +import Data.Int (Int64) + +import Blaze.ByteString.Builder + +{- +Beamed int representation: + +1. The integer is chunked up into 7-bit groups. Each of these 7bit +chunks are encoded as a single octet. + +2. All the octets except the last one has its 8th bit set. + +3. 7th bit of the first octet represents sign. + +3. Octets with bits 1..7 containing only 1 or 0 can be ignored when it's not affecting the sign: + +0 | 0 0000000 +1 | 0 0000001 +63 | 0 0111111 +64 | 1 0000000 0 1000000 +127 | 1 0000000 0 1111111 +128 | 1 0000001 0 0000000 +8191 | 1 0111111 0 1111111 +8192 | 1 0000000 1 1000000 0 0000000 +65535 | 1 0000011 1 1111111 0 1111111 +-1 | 0 1111111 +-64 | 0 1000000 +-65 | 1 1111111 0 0111111 +-127 | 1 1111111 0 0000001 +-128 | 1 1111111 0 0000000 +-129 | 1 1111110 0 0111111 +-8191 | 1 1000000 0 0000001 +-8192 | 1 1000000 0 0000000 +-8193 | 1 1111111 1 0111111 0 1111111 +-} + +-- This might not work well for 32bit platform +beamInt :: Int64 -> Builder -- {{{ +beamInt 0 = fromWord8 0 +beamInt n = toBldr . bitmark . reverse . unfoldr f $ n + where + f :: Int64 -> Maybe (Word8, Int64) + f 0 = Nothing + f x = let w = fromIntegral x .&. 0x7F :: Word8 + rest = x `shift` (negate 7) + in Just (w, if rest == (-1) then 0 else rest) + + bitmark :: [Word8] -> [Word8] + bitmark (w:[]) = [w] + bitmark (w:ws) = (w .|. 0x80) : bitmark ws + bitmark [] = [] + + toBldr :: [Word8] -> Builder + toBldr ws = + let ws' = if testBit (head ws) 6 + then if n > 0 then 0x80:ws else ws + else if n > 0 then ws else 0xFF:ws + in fromWriteList writeWord8 ws' + +-- This might not work well for 32bit platform +unbeamInt :: B.ByteString -> (Int64, B.ByteString) +unbeamInt bs = (fixSign (B.foldl f 0 this), rest) + where + f :: Int64 -> Word8 -> Int64 + f i w = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) + + fixSign :: Int64 -> Int64 + fixSign x = x `shift` (64 - l * 7) `shift` (l * 7 - 64) + + Just lastWord = B.findIndex (not . flip testBit 7) bs + l = lastWord + 1 + (this, rest) = B.splitAt l bs-- }}} diff --git a/src/Data/Beamable/Integer.hs b/src/Data/Beamable/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable/Integer.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Data.Beamable.Integer + ( beamInteger + , unbeamInteger + ) where + +import Control.Arrow (first) +import Data.ByteString (ByteString) +import Data.Monoid (mappend) +import Blaze.ByteString.Builder +import qualified Data.ByteString as B +import GHC.Integer.GMP.Internals +import GHC.Base +import GHC.Word +import GHC.ST + +import Data.Beamable.Int + +beamInteger :: Integer -> Builder +beamInteger (S# x#) = beamInt (-1) `mappend` beamInt (fromIntegral $ I# x#) +beamInteger (J# x# ba#) = + beamInt (fromIntegral $ I# baSize#) `mappend` beamInt (fromIntegral $ I# x#) `mappend` + fromWord8s [W8# (indexWord8Array# ba# i#) | I# i# <- [0 .. baSize - 1]] + where + baSize# = sizeofByteArray# ba# + baSize = I# baSize# +{-# INLINE beamInteger #-} + +unbeamInteger :: ByteString -> (Integer, ByteString) +unbeamInteger bs + | baSize# <# 0# = (S# x#, bs'') + | otherwise = runSTRep $ \s# -> + let (# s'#, mba# #) = newByteArray# baSize# s# + s''# = go mba# 0# s'# + (# s'''#, ba# #) = unsafeFreezeByteArray# mba# s''# + + in (# s'''#, (J# x# ba#, B.drop (I# baSize#) bs'') #) + where + !(I# baSize#, bs') = first fromIntegral $ unbeamInt bs + !(I# x#, bs'') = first fromIntegral $ unbeamInt bs' + + go mba# i# s# + | i# >=# baSize# = s# + | otherwise = + let !(W8# b#) = B.index bs'' (I# i#) + s'# = writeWord8Array# mba# i# b# s# + in go mba# (i# +# 1#) s'# +{-# INLINE unbeamInteger #-} diff --git a/src/Data/Beamable/Internal.hs b/src/Data/Beamable/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable/Internal.hs @@ -0,0 +1,247 @@ +{-# OPTIONS -Wall #-} +{-# LANGUAGE DeriveGeneric, TypeOperators, FlexibleContexts, DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Beamable.Internal + ( Beamable + , beam + , unbeam + , typeSignR + , typeSign + , TypeSign (..) + ) where + +import Data.Beamable.Int +import Data.Beamable.Integer +import Data.Beamable.Util + +import Blaze.ByteString.Builder +import Data.Digest.Murmur64 + +import Control.Arrow (first) +import Data.Bits ((.|.), (.&.), shift, testBit) +import Data.ByteString (ByteString) +import Data.Char (ord, chr) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Monoid (mempty, mappend, mconcat) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Foreign.Storable +import GHC.Generics +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +class Beamable a where + -- | Serialize value into 'Builder' + beam :: a -> Builder + -- | Deserialize next value from 'ByteString', also returns leftovers + unbeam :: ByteString -> (a, ByteString) + -- | Get value's type signature, should work fine on 'undefined' values + -- takes list of strings with datatypes which already been traversed + -- workaround to support recursive datatypes. In most cases you should be + -- passing empty list in there. + typeSignR :: [String] -> a -> Word64 + + -- by default let's use generic version + + default beam :: (Generic a, GBeamable (Rep a)) => a -> Builder + beam v = gbeam (from v) (0,0) + + default unbeam :: (Generic a, GBeamable (Rep a)) => ByteString -> (a, ByteString) + unbeam v = first to $ gunbeam v (0,0) + + default typeSignR :: (Generic a, GBeamable (Rep a)) => [String] -> a -> Word64 + typeSignR prev v = gtypeSign prev (from v) + +-- | Get type signature of arbitrary Beamable datatatype encoded as Word64 hash +-- with all constructors and datatypes in it. It's preferable to use 'typeSign' +-- against typeSignR, because implementation of later might change. +typeSign :: Beamable a => a -> Word64 +typeSign = typeSignR [] + +signMur :: Hashable64 a => a -> Word64 +signMur !a = asWord64 $ hash64 a + +-- | It's possible to beam arbitrary Storable instances (not very size efficient) +beamStorable :: Storable a => a -> Builder-- {{{ +beamStorable = fromStorable + +unbeamStorable :: Storable a => ByteString -> (a, ByteString) +unbeamStorable bs = let v = peekBS bs in (v, B.drop (sizeOf v) bs)-- }}} + +-- | It's possible to beam arbitrary Enum instances +beamEnum :: Enum a => a -> Builder-- {{{ +beamEnum = beamInt . fromIntegral . fromEnum + +unbeamEnum :: Enum a => ByteString -> (a, ByteString) +unbeamEnum bs = let (i, bs') = unbeamInt bs in (toEnum (fromIntegral i), bs')-- }}} + + +class GBeamable f where + gbeam :: f a -> (Int, Word) -> Builder + gunbeam :: B.ByteString -> (Int, Word) -> (f a, B.ByteString) + gtypeSign :: [String] -> f a -> Word64 + +-- this instance used for datatypes with single constructor only +instance (GBeamable a, Datatype d, Constructor c) => GBeamable (M1 D d (M1 C c a)) where + gbeam (M1 (M1 x)) = gbeam x + gunbeam x = first M1 . gunbeam x + gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') + gtypeSign prev x = signMur (datatypeName x, ':', gtypeSign (datatypeName x : prev) (unM1 x)) + +-- this instance used for datatypes with multiple constructors and +-- values are prefixed by uniq number for each constructor +instance (GBeamable a, Constructor c) => GBeamable (M1 C c a) where + gbeam (M1 x) t@(_, dirs) = mappend (beamWord $ fromIntegral dirs) (gbeam x t) + gunbeam bs = first M1 . gunbeam bs + gtypeSign prev x = signMur (conName x, '<', gtypeSign prev (unM1 x)) + +-- this instance is needed to avoid overlapping instances with (M1 D d (M1 C c a)) +instance (Datatype d, GBeamable a, GBeamable b) => GBeamable (M1 D d (a :+: b) ) where + gbeam (M1 x) = gbeam x + gunbeam bs (lev, _) = let (dirs, bs') = unbeamWord bs + in first M1 $ gunbeam bs' (lev, fromIntegral dirs) + gtypeSign prev x | elem (datatypeName x) prev = signMur (datatypeName x, '_') + + gtypeSign prev x = signMur ( gtypeSign (datatypeName x : prev) (unL . unM1 $ x), '|' + , gtypeSign (datatypeName x : prev) (unR . unM1 $ x)) + +-- choose correct constructor based on the first word uncoded from the BS (dirs variable) +instance (GBeamable a, GBeamable b) => GBeamable (a :+: b) where + gbeam (L1 x) (lev, dirs) = gbeam x (lev + 1, dirs) + gbeam (R1 x) (lev, dirs) = gbeam x (lev + 1, dirs + 2^lev) + gunbeam bs (lev, dirs) = if testBit dirs lev + then first R1 $ gunbeam bs (lev + 1, dirs) + else first L1 $ gunbeam bs (lev + 1, dirs) + gtypeSign prev x = signMur (gtypeSign prev (unL x), '|', gtypeSign prev (unR x)) + +instance GBeamable a => GBeamable (M1 S c a) where + gbeam (M1 x) = gbeam x + gunbeam bs = first M1 . gunbeam bs + gtypeSign prev ~(M1 x) = signMur ('[', gtypeSign prev x) + +instance GBeamable U1 where + gbeam _ _ = mempty + gunbeam bs _ = (U1, bs) + gtypeSign _ _x = signMur 'U' + +instance (GBeamable a, GBeamable b) => GBeamable (a :*: b) where + gbeam (x :*: y) t = gbeam x t `mappend` gbeam y t + gunbeam bs t = let (ra, bs') = gunbeam bs t + (rb, bs'') = gunbeam bs' t + in (ra :*: rb, bs'') + gtypeSign prev ~(x :*: y) = signMur (gtypeSign prev x, '*', gtypeSign prev y) + +instance Beamable a => GBeamable (K1 i a) where + gbeam (K1 x) _ = beam x + gunbeam bs _ = first K1 (unbeam bs) + gtypeSign prev x = signMur ('K', typeSignR prev (unK1 x)) + +-- | [un]beamWord functions are a bit more efficient than [un]beamInt +-- it assumes that values are non-negative which allows more compact representation + +beamWord :: Word64 -> Builder-- {{{ +beamWord 0 = fromWord8 0 +beamWord i = fromByteString . B.reverse . fst $ B.unfoldrN 10 octets (i, True) + where + octets :: (Word64, Bool) -> Maybe (Word8, (Word64, Bool)) + octets (x, isFirst) + | x > 0 = let r = (fromIntegral (x .&. 0x7F)) .|. (if isFirst then 0 else 0x80) + in Just (r, (x `shift` (negate 7), False)) + | otherwise = Nothing + + +unbeamWord :: B.ByteString -> (Word64, B.ByteString) +unbeamWord bs = (B.foldl f 0 this, rest) + where + f :: Word64 -> Word8 -> Word64 + f i w = (i `shift` 7) .|. fromIntegral (w .&. 0x7F) + + Just lastWord = B.findIndex (not . flip testBit 7) bs + (this, rest) = B.splitAt (lastWord + 1) bs + + +{-# SPECIALIZE beamWordX :: Word8 -> Builder #-} +{-# SPECIALIZE beamWordX :: Word16 -> Builder #-} +{-# SPECIALIZE beamWordX :: Word32 -> Builder #-} +{-# SPECIALIZE beamWordX :: Word64 -> Builder #-} +beamWordX :: Integral w => w -> Builder +beamWordX = beamWord . fromIntegral + +{-# SPECIALIZE unbeamWordX :: B.ByteString -> (Word8, B.ByteString) #-} +{-# SPECIALIZE unbeamWordX :: B.ByteString -> (Word16, B.ByteString) #-} +{-# SPECIALIZE unbeamWordX :: B.ByteString -> (Word32, B.ByteString) #-} +{-# SPECIALIZE unbeamWordX :: B.ByteString -> (Word64, B.ByteString) #-} +unbeamWordX :: Integral w => B.ByteString -> (w, B.ByteString) +unbeamWordX bs = let (i, bs') = unbeamWord bs in (fromIntegral i, bs')-- }}} + +newtype TypeSign = TypeSign { unTypeSign :: Word64 } deriving (Num, Show, Eq, Storable) + +-- (de)serialization for numbers -- {{{ +instance Beamable Int where { beam = beamEnum ; unbeam = unbeamEnum ; typeSignR _ _ = signMur "Int" } +instance Beamable Int8 where { beam = beamEnum ; unbeam = unbeamEnum ; typeSignR _ _ = signMur "Int8" } +instance Beamable Int16 where { beam = beamEnum ; unbeam = unbeamEnum ; typeSignR _ _ = signMur "Int16" } +instance Beamable Int32 where { beam = beamEnum ; unbeam = unbeamEnum ; typeSignR _ _ = signMur "Int32" } +instance Beamable Int64 where { beam = beamInt ; unbeam = unbeamInt ; typeSignR _ _ = signMur "Int64" } +instance Beamable Word where { beam = beamWordX ; unbeam = unbeamWordX ; typeSignR _ _ = signMur "Word" } +instance Beamable Word8 where { beam = beamWordX ; unbeam = unbeamWordX ; typeSignR _ _ = signMur "Word8" } +instance Beamable Word16 where { beam = beamWordX ; unbeam = unbeamWordX ; typeSignR _ _ = signMur "Word16" } +instance Beamable Word32 where { beam = beamWordX ; unbeam = unbeamWordX ; typeSignR _ _ = signMur "Word32" } +instance Beamable Word64 where { beam = beamWord ; unbeam = unbeamWord ; typeSignR _ _ = signMur "Word64" } +instance Beamable Float where { beam = beamStorable ; unbeam = unbeamStorable ; typeSignR _ _ = signMur "Float" } +instance Beamable Double where { beam = beamStorable ; unbeam = unbeamStorable ; typeSignR _ _ = signMur "Double" } +instance Beamable TypeSign where { beam = beamStorable ; unbeam = unbeamStorable ; typeSignR _ _ = signMur "TypeSign" } +instance Beamable Integer where { beam = beamInteger ; unbeam = unbeamInteger ; typeSignR _ _ = signMur "Integer" } +-- }}} + +instance Beamable Char where + beam = beamWord . fromIntegral . ord + unbeam = first (chr . fromIntegral) . unbeamWord + typeSignR _ _ = signMur "Char" + +-- Unit +instance Beamable () where + beam = const mempty + unbeam bs = ((), bs) + typeSignR _ _ = signMur "()" + +-- Tuples +instance (Beamable a, Beamable b) => Beamable (a, b) +instance (Beamable a, Beamable b, Beamable c) => Beamable (a, b, c) +instance (Beamable a, Beamable b, Beamable c, Beamable d) => Beamable (a, b, c, d) +instance (Beamable a, Beamable b, Beamable c, Beamable d + ,Beamable e) => Beamable (a, b, c, d, e) +instance (Beamable a, Beamable b, Beamable c, Beamable d + ,Beamable e, Beamable f) => Beamable (a, b, c, d, e, f) +instance (Beamable a, Beamable b, Beamable c, Beamable d + ,Beamable e, Beamable f, Beamable g) => Beamable (a, b, c, d, e, f, g) + +instance (Beamable a, Beamable b) => Beamable (Either a b) +instance Beamable a => Beamable (Maybe a) + +instance Beamable Bool + +instance Beamable a => Beamable [a] where + beam xs = beamWord (fromIntegral $ length xs) `mappend` mconcat (map beam xs) + unbeam bs = let (cnt, bs') = unbeamWord bs + in unfoldCnt (fromIntegral cnt) unbeam bs' + typeSignR prev _ = signMur ('L', typeSignR prev (undefined :: a)) + +unfoldCnt :: Int -> (b -> (a, b)) -> b -> ([a], b) +unfoldCnt cnt_i f = unfoldCnt' [] cnt_i + where + unfoldCnt' xs 0 b = (reverse xs, b) + unfoldCnt' xs cnt b = let (x, b') = f b + in unfoldCnt' (x:xs) (cnt - 1) b' + +instance Beamable ByteString where + beam bs = beamWord (fromIntegral $ B.length bs) `mappend` fromByteString bs + unbeam = uncurry (B.splitAt . fromIntegral) . unbeamWord + typeSignR _ _ = signMur "ByteString.Strict" + +instance Beamable BL.ByteString where + beam = beam . BL.toChunks + unbeam bs = let (chunks, bs') = unbeam bs + in (BL.fromChunks chunks, bs') + typeSignR _ _ = signMur "ByteString.Lazy" diff --git a/src/Data/Beamable/Util.hs b/src/Data/Beamable/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Beamable/Util.hs @@ -0,0 +1,26 @@ +{-# OPTIONS -Wall #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Beamable.Util + ( peekBS + , unL + , unR + ) where + +import Data.ByteString.Internal (ByteString (..)) +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import GHC.Generics +import System.IO.Unsafe (unsafeDupablePerformIO) + +peekBS :: Storable a => ByteString -> a +peekBS (PS fptr offset _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr' -> + let ptr = plusPtr ptr' offset + in peek (castPtr ptr) + +unL :: (l :+: r) a -> l a +unL = error "unL should be used only for type recovery operations" + +unR :: (l :+: r) a -> r a +unR = error "unR should be used only for type recovery operations" diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,8 @@ +import Test.Framework (defaultMain) + +import qualified Data.Beamable.Tests + +main :: IO () +main = defaultMain + [ Data.Beamable.Tests.tests + ]