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
beam :: a -> Builder
unbeam :: ByteString -> (a, ByteString)
typeSignR :: [String] -> a -> Word64
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)
typeSign :: Beamable a => a -> Word64
typeSign = typeSignR []
signMur :: Hashable64 a => a -> Word64
signMur !a = asWord64 $ hash64 a
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)
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
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))
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))
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))
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))
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
beamWordX :: Integral w => w -> Builder
beamWordX = beamWord . fromIntegral
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)
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"
instance Beamable () where
beam = const mempty
unbeam bs = ((), bs)
typeSignR _ _ = signMur "()"
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"