beamable (empty) → 0.1.0.0
raw patch · 9 files changed
+650/−0 lines, 9 filesdep +QuickCheckdep +basedep +blaze-buildersetup-changed
Dependencies added: QuickCheck, base, blaze-builder, bytestring, ghc-prim, integer-gmp, murmur-hash, test-framework, test-framework-quickcheck2
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- beamable.cabal +93/−0
- src/Data/Beamable.hs +113/−0
- src/Data/Beamable/Int.hs +81/−0
- src/Data/Beamable/Integer.hs +50/−0
- src/Data/Beamable/Internal.hs +247/−0
- src/Data/Beamable/Util.hs +26/−0
- tests/TestSuite.hs +8/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ beamable.cabal view
@@ -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
+ src/Data/Beamable.hs view
@@ -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!"
+ src/Data/Beamable/Int.hs view
@@ -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-- }}}
+ src/Data/Beamable/Integer.hs view
@@ -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 #-}
+ src/Data/Beamable/Internal.hs view
@@ -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"
+ src/Data/Beamable/Util.hs view
@@ -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"
+ tests/TestSuite.hs view
@@ -0,0 +1,8 @@+import Test.Framework (defaultMain)++import qualified Data.Beamable.Tests++main :: IO ()+main = defaultMain+ [ Data.Beamable.Tests.tests+ ]