mirror of
https://github.com/composewell/streamly.git
synced 2024-08-17 07:20:36 +03:00
Rename serialize/deserialize/size of Serialize class
This commit is contained in:
parent
1efeed403b
commit
13581bfec1
@ -49,8 +49,8 @@ import Streamly.Benchmark.Data.Serialize.RecNonCompatible
|
||||
#else
|
||||
#define SERIALIZE_CLASS Serialize
|
||||
#define DERIVE_CLASS(typ) $(deriveSerialize [d|instance Serialize typ|])
|
||||
#define SERIALIZE_OP serialize
|
||||
#define DESERIALIZE_OP deserialize
|
||||
#define SERIALIZE_OP serializeAt
|
||||
#define DESERIALIZE_OP deserializeAt
|
||||
#endif
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
@ -288,7 +288,7 @@ getSize :: forall a. SERIALIZE_CLASS a => a -> Int
|
||||
#ifdef USE_UNBOX
|
||||
getSize _ = sizeOf (Proxy :: Proxy a)
|
||||
#else
|
||||
getSize = size 0
|
||||
getSize = addSizeTo 0
|
||||
#endif
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
@ -75,9 +75,9 @@ module Streamly.Data.MutByteArray
|
||||
-- Deriving Serialize
|
||||
, SerializeConfig
|
||||
, serializeConfig
|
||||
, inlineSize
|
||||
, inlineSerialize
|
||||
, inlineDeserialize
|
||||
, inlineAddSizeTo
|
||||
, inlineSerializeAt
|
||||
, inlineDeserializeAt
|
||||
|
||||
, deriveSerialize
|
||||
, deriveSerializeWith
|
||||
|
@ -561,9 +561,9 @@ streamFold f arr = f (A.read arr)
|
||||
encodeAs :: forall a. Serialize a => PinnedState -> a -> Array Word8
|
||||
encodeAs ps a =
|
||||
unsafeInlineIO $ do
|
||||
let len = Serialize.size 0 a
|
||||
let len = Serialize.addSizeTo 0 a
|
||||
mbarr <- MBA.newBytesAs ps len
|
||||
off <- Serialize.serialize 0 mbarr a
|
||||
off <- Serialize.serializeAt 0 mbarr a
|
||||
assertM(len == off)
|
||||
pure $ Array mbarr 0 off
|
||||
|
||||
@ -584,6 +584,7 @@ pinnedSerialize = encodeAs Pinned
|
||||
deserialize :: Serialize a => Array Word8 -> a
|
||||
deserialize arr@(Array {..}) = unsafeInlineIO $ do
|
||||
let lenArr = length arr
|
||||
(off, val) <- Serialize.deserialize arrStart arrContents (arrStart + lenArr)
|
||||
(off, val) <-
|
||||
Serialize.deserializeAt arrStart arrContents (arrStart + lenArr)
|
||||
assertM(off == arrStart + lenArr)
|
||||
pure val
|
||||
|
@ -88,73 +88,73 @@ import Streamly.Internal.Data.Unbox.TH
|
||||
-- $(Serialize.deriveSerialize ''Maybe)
|
||||
instance Serialize a => Serialize (Maybe a) where
|
||||
|
||||
{-# INLINE size #-}
|
||||
size acc x =
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
Nothing -> (acc + 1)
|
||||
Just field0 -> (size (acc + 1)) field0
|
||||
Just field0 -> (addSizeTo (acc + 1)) field0
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> pure (i0, Nothing)
|
||||
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, Just a0)
|
||||
_ -> error "Found invalid tag while peeking (Maybe a)"
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize initialOffset arr val =
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
Nothing -> do
|
||||
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
pure i0
|
||||
Just field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
|
||||
-- $(Serialize.deriveSerialize ''Either)
|
||||
instance (Serialize a, Serialize b) => Serialize (Either a b) where
|
||||
|
||||
{-# INLINE size #-}
|
||||
size acc x =
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
Left field0 -> (size (acc + 1)) field0
|
||||
Right field0 -> (size (acc + 1)) field0
|
||||
Left field0 -> (addSizeTo (acc + 1)) field0
|
||||
Right field0 -> (addSizeTo (acc + 1)) field0
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, Left a0)
|
||||
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, Right a0)
|
||||
_ -> error "Found invalid tag while peeking (Either a b)"
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize initialOffset arr val =
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
Left field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
Right field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
|
||||
instance Serialize (Proxy a) where
|
||||
|
||||
{-# INLINE size #-}
|
||||
size acc _ = (acc + 1)
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc _ = (acc + 1)
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize initialOffset _ _ = pure ((initialOffset + 1), Proxy)
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset _ _ = pure ((initialOffset + 1), Proxy)
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize initialOffset _ _ = pure (initialOffset + 1)
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset _ _ = pure (initialOffset + 1)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Integer
|
||||
@ -168,39 +168,39 @@ data LiftedInteger
|
||||
-- $(Serialize.deriveSerialize ''LiftedInteger)
|
||||
instance Serialize LiftedInteger where
|
||||
|
||||
{-# INLINE size #-}
|
||||
size acc x =
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
LIS field0 -> (size (acc + 1)) field0
|
||||
LIP field0 -> (size (acc + 1)) field0
|
||||
LIN field0 -> (size (acc + 1)) field0
|
||||
LIS field0 -> (addSizeTo (acc + 1)) field0
|
||||
LIP field0 -> (addSizeTo (acc + 1)) field0
|
||||
LIN field0 -> (addSizeTo (acc + 1)) field0
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, LIS a0)
|
||||
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, LIP a0)
|
||||
2 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
|
||||
2 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
pure (i1, LIN a0)
|
||||
_ -> error "Found invalid tag while peeking (LiftedInteger)"
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize initialOffset arr val =
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
LIS field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
LIP field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
LIN field0 -> do
|
||||
i0 <- ((serialize initialOffset) arr) (2 :: Word8)
|
||||
i1 <- ((serialize i0) arr) field0
|
||||
i0 <- ((serializeAt initialOffset) arr) (2 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 900
|
||||
@ -240,11 +240,12 @@ unliftInteger (LIN (Array (MutByteArray x) _ _)) =
|
||||
#endif
|
||||
|
||||
instance Serialize Integer where
|
||||
{-# INLINE size #-}
|
||||
size i a = size i (liftInteger a)
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo i a = addSizeTo i (liftInteger a)
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize off arr end = fmap unliftInteger <$> deserialize off arr end
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt off arr end =
|
||||
fmap unliftInteger <$> deserializeAt off arr end
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize off arr val = serialize off arr (liftInteger val)
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt off arr val = serializeAt off arr (liftInteger val)
|
||||
|
@ -50,7 +50,7 @@ import Streamly.Internal.Data.Serialize.TH.RecHeader
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
|
||||
exprGetSize acc (i, _) = [|size $(acc) $(varE (mkFieldName i))|]
|
||||
exprGetSize acc (i, _) = [|addSizeTo $(acc) $(varE (mkFieldName i))|]
|
||||
|
||||
getTagSize :: Int -> Int
|
||||
getTagSize numConstructors
|
||||
@ -170,9 +170,9 @@ mkSizeDec (SerializeConfig {..}) headTy cons = do
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
(\x -> [PragmaD (InlineP 'size x FunLike AllPhases)])
|
||||
(\x -> [PragmaD (InlineP 'addSizeTo x FunLike AllPhases)])
|
||||
cfgInlineSize
|
||||
++ [FunD 'size [Clause [] (NormalB sizeOfMethod) []]]
|
||||
++ [FunD 'addSizeTo [Clause [] (NormalB sizeOfMethod) []]]
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -192,7 +192,7 @@ mkDeserializeExpr True False headTy tyOfTy =
|
||||
conLen <- newName "conLen"
|
||||
off1 <- newName "off1"
|
||||
[|do ($(varP off1), $(varP conLen) :: Word8) <-
|
||||
deserialize
|
||||
deserializeAt
|
||||
$(varE _initialOffset)
|
||||
$(varE _arr)
|
||||
$(varE _endOffset)
|
||||
@ -212,7 +212,7 @@ mkDeserializeExpr True False headTy tyOfTy =
|
||||
[|($(litIntegral lenCname) == $(varE conLen))
|
||||
&& $(xorCmp tag off _arr)|]
|
||||
[|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
|
||||
in $(mkDeserializeExprOne 'deserialize con)|]
|
||||
in $(mkDeserializeExprOne 'deserializeAt con)|]
|
||||
|
||||
mkDeserializeExpr False False headTy tyOfTy =
|
||||
case tyOfTy of
|
||||
@ -223,7 +223,7 @@ mkDeserializeExpr False False headTy tyOfTy =
|
||||
TheType con ->
|
||||
letE
|
||||
[valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
|
||||
(mkDeserializeExprOne 'deserialize con)
|
||||
(mkDeserializeExprOne 'deserializeAt con)
|
||||
-- Sum type
|
||||
MultiType cons -> do
|
||||
let lenCons = length cons
|
||||
@ -231,7 +231,7 @@ mkDeserializeExpr False False headTy tyOfTy =
|
||||
doE
|
||||
[ bindS
|
||||
(tupP [varP (mkName "i0"), varP _tag])
|
||||
[|deserialize $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
|
||||
[|deserializeAt $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
|
||||
, noBindS
|
||||
(caseE
|
||||
(sigE (varE _tag) (conT tagType))
|
||||
@ -241,7 +241,7 @@ mkDeserializeExpr False False headTy tyOfTy =
|
||||
peekMatch (i, con) =
|
||||
match
|
||||
(litP (IntegerL i))
|
||||
(normalB (mkDeserializeExprOne 'deserialize con)) []
|
||||
(normalB (mkDeserializeExprOne 'deserializeAt con)) []
|
||||
peekErr =
|
||||
match
|
||||
wildP
|
||||
@ -279,11 +279,11 @@ mkDeserializeDec (SerializeConfig {..}) headTy cons = do
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
(\x -> [PragmaD (InlineP 'deserialize x FunLike AllPhases)])
|
||||
(\x -> [PragmaD (InlineP 'deserializeAt x FunLike AllPhases)])
|
||||
cfgInlineDeserialize
|
||||
++
|
||||
[ FunD
|
||||
'deserialize
|
||||
'deserializeAt
|
||||
[ Clause
|
||||
(if isUnitType cons && not cfgConstructorTagAsString
|
||||
then [VarP _initialOffset, WildP, WildP]
|
||||
@ -300,7 +300,7 @@ mkDeserializeDec (SerializeConfig {..}) headTy cons = do
|
||||
|
||||
mkSerializeExprTag :: Name -> Int -> Q Exp
|
||||
mkSerializeExprTag tagType tagVal =
|
||||
[|serialize
|
||||
[|serializeAt
|
||||
$(varE _initialOffset)
|
||||
$(varE _arr)
|
||||
$((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
|
||||
@ -335,7 +335,7 @@ mkSerializeExpr True False tyOfTy =
|
||||
(doE [ bindS
|
||||
(varP (mkName "i0"))
|
||||
(serializeW8List _initialOffset _arr conEnc)
|
||||
, noBindS (mkSerializeExprFields 'serialize fields)
|
||||
, noBindS (mkSerializeExprFields 'serializeAt fields)
|
||||
])
|
||||
|
||||
mkSerializeExpr False False tyOfTy =
|
||||
@ -351,7 +351,7 @@ mkSerializeExpr False False tyOfTy =
|
||||
[ matchConstructor
|
||||
cname
|
||||
(length fields)
|
||||
(mkSerializeExprFields 'serialize fields)
|
||||
(mkSerializeExprFields 'serializeAt fields)
|
||||
])
|
||||
-- Sum type
|
||||
(MultiType cons) -> do
|
||||
@ -368,7 +368,7 @@ mkSerializeExpr False False tyOfTy =
|
||||
(mkSerializeExprTag tagType tagVal)
|
||||
, noBindS
|
||||
(mkSerializeExprFields
|
||||
'serialize
|
||||
'serializeAt
|
||||
fields)
|
||||
]))
|
||||
(zip [0 ..] cons))
|
||||
@ -388,11 +388,11 @@ mkSerializeDec (SerializeConfig {..}) headTy cons = do
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
(\x -> [PragmaD (InlineP 'serialize x FunLike AllPhases)])
|
||||
(\x -> [PragmaD (InlineP 'serializeAt x FunLike AllPhases)])
|
||||
cfgInlineSerialize
|
||||
++
|
||||
[FunD
|
||||
'serialize
|
||||
'serializeAt
|
||||
[ Clause
|
||||
(if isUnitType cons && not cfgConstructorTagAsString
|
||||
then [VarP _initialOffset, WildP, WildP]
|
||||
|
@ -13,9 +13,9 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
|
||||
-- ** Config
|
||||
SerializeConfig(..)
|
||||
, serializeConfig
|
||||
, inlineSize
|
||||
, inlineSerialize
|
||||
, inlineDeserialize
|
||||
, inlineAddSizeTo
|
||||
, inlineSerializeAt
|
||||
, inlineDeserializeAt
|
||||
, encodeConstrNames
|
||||
, encodeRecordFields
|
||||
|
||||
@ -84,7 +84,7 @@ import Streamly.Internal.Data.Unbox.TH (DataCon(..))
|
||||
-- 'serializeConfig' and config setter functions to generate desired Config. For
|
||||
-- example:
|
||||
--
|
||||
-- >>> (inlineSize (Just Inline)) . (inlineSerialize (Just Inlinable)) serializeConfig
|
||||
-- >>> (inlineAddSizeTo (Just Inline)) . (inlineSerializeAt (Just Inlinable)) serializeConfig
|
||||
--
|
||||
data SerializeConfig =
|
||||
SerializeConfig
|
||||
@ -95,11 +95,11 @@ data SerializeConfig =
|
||||
, cfgRecordSyntaxWithHeader :: Bool
|
||||
}
|
||||
|
||||
-- | How should we inline the 'size' function? The default in 'serializeConfig'
|
||||
-- is 'Nothing' which means left to the compiler. Forcing inline on @size@
|
||||
-- | How should we inline the 'addSizeTo' function? The default in 'serializeConfig'
|
||||
-- is 'Nothing' which means left to the compiler. Forcing inline on @addSizeTo@
|
||||
-- function actually worsens some benchmarks and improves none.
|
||||
inlineSize :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineSize v cfg = cfg {cfgInlineSize = v}
|
||||
inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineAddSizeTo v cfg = cfg {cfgInlineSize = v}
|
||||
|
||||
-- XXX Should we make the default Inlinable instead?
|
||||
|
||||
@ -108,15 +108,15 @@ inlineSize v cfg = cfg {cfgInlineSize = v}
|
||||
-- the code and increase in compilation times when there are big functions and
|
||||
-- too many nesting levels so you can change it accordingly. A 'Nothing' value
|
||||
-- leaves the decision to the compiler.
|
||||
inlineSerialize :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineSerialize v cfg = cfg {cfgInlineSerialize = v}
|
||||
inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineSerializeAt v cfg = cfg {cfgInlineSerialize = v}
|
||||
|
||||
-- XXX Should we make the default Inlinable instead?
|
||||
|
||||
-- | How should we inline the 'deserialize' function? See guidelines in
|
||||
-- 'inlineSerialize'.
|
||||
inlineDeserialize :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineDeserialize v cfg = cfg {cfgInlineDeserialize = v}
|
||||
-- 'inlineSerializeAt'.
|
||||
inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
|
||||
inlineDeserializeAt v cfg = cfg {cfgInlineDeserialize = v}
|
||||
|
||||
-- | __Experimental__
|
||||
--
|
||||
@ -184,9 +184,9 @@ encodeRecordFields v cfg = cfg {cfgRecordSyntaxWithHeader = v}
|
||||
|
||||
-- | The default configuration settings are:
|
||||
--
|
||||
-- * 'inlineSize' 'Nothing'
|
||||
-- * 'inlineSerialize' (Just Inline)
|
||||
-- * 'inlineDeserialize' (Just Inline)
|
||||
-- * 'inlineAddSizeTo' 'Nothing'
|
||||
-- * 'inlineSerializeAt' (Just Inline)
|
||||
-- * 'inlineDeserializeAt' (Just Inline)
|
||||
--
|
||||
serializeConfig :: SerializeConfig
|
||||
serializeConfig =
|
||||
@ -425,7 +425,7 @@ serializeW8List off arr w8List = do
|
||||
makeBind i =
|
||||
bindS
|
||||
(varP (makeN (i + 1)))
|
||||
[|$(varE 'serialize)
|
||||
[|$(varE 'serializeAt)
|
||||
$(varE (makeN i))
|
||||
$(varE arr)
|
||||
($(litIntegral (w8List !! i)) :: Word8)|]
|
||||
|
@ -103,36 +103,36 @@ newtype CompactList a =
|
||||
-- the list is 255.
|
||||
instance forall a. Serialize a => Serialize (CompactList a) where
|
||||
|
||||
-- {-# INLINE size #-}
|
||||
size acc (CompactList xs) =
|
||||
foldl' size (acc + (Unbox.sizeOf (Proxy :: Proxy Word8))) xs
|
||||
-- {-# INLINE addSizeTo #-}
|
||||
addSizeTo acc (CompactList xs) =
|
||||
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Word8))) xs
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE deserialize #-}
|
||||
deserialize off arr sz = do
|
||||
(off1, len8) <- deserialize off arr sz :: IO (Int, Word8)
|
||||
{-# INLINABLE deserializeAt #-}
|
||||
deserializeAt off arr sz = do
|
||||
(off1, len8) <- deserializeAt off arr sz :: IO (Int, Word8)
|
||||
let len = w8_int len8
|
||||
peekList f o i | i >= 3 = do
|
||||
-- Unfold the loop three times
|
||||
(o1, x1) <- deserialize o arr sz
|
||||
(o2, x2) <- deserialize o1 arr sz
|
||||
(o3, x3) <- deserialize o2 arr sz
|
||||
(o1, x1) <- deserializeAt o arr sz
|
||||
(o2, x2) <- deserializeAt o1 arr sz
|
||||
(o3, x3) <- deserializeAt o2 arr sz
|
||||
peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3)
|
||||
peekList f o 0 = pure (o, f [])
|
||||
peekList f o i = do
|
||||
(o1, x) <- deserialize o arr sz
|
||||
(o1, x) <- deserializeAt o arr sz
|
||||
peekList (f . (x:)) o1 (i - 1)
|
||||
(nextOff, lst) <- peekList id off1 len
|
||||
pure (nextOff, CompactList lst)
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE serialize #-}
|
||||
serialize off arr (CompactList val) = do
|
||||
void $ serialize off arr (int_w8 (length val) :: Word8)
|
||||
{-# INLINABLE serializeAt #-}
|
||||
serializeAt off arr (CompactList val) = do
|
||||
void $ serializeAt off arr (int_w8 (length val) :: Word8)
|
||||
let off1 = off + Unbox.sizeOf (Proxy :: Proxy Word8)
|
||||
let pokeList o [] = pure o
|
||||
pokeList o (x:xs) = do
|
||||
o1 <- serialize o arr x
|
||||
o1 <- serializeAt o arr x
|
||||
pokeList o1 xs
|
||||
pokeList off1 val
|
||||
|
||||
@ -154,7 +154,7 @@ isMaybeType _ = False
|
||||
-- We add 4 here because we use 'serializeWithSize' for serializing.
|
||||
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
|
||||
exprGetSize acc (i, _) =
|
||||
[|size $(acc) $(varE (mkFieldName i)) + 4|]
|
||||
[|addSizeTo $(acc) $(varE (mkFieldName i)) + 4|]
|
||||
|
||||
sizeOfHeader :: SimpleDataCon -> Int
|
||||
sizeOfHeader (SimpleDataCon _ fields) =
|
||||
@ -227,7 +227,7 @@ headerValue (SimpleDataCon _ fields) =
|
||||
{-# INLINE serializeWithSize #-}
|
||||
serializeWithSize :: Serialize a => Int -> MutByteArray -> a -> IO Int
|
||||
serializeWithSize off arr val = do
|
||||
off1 <- serialize (off + 4) arr val
|
||||
off1 <- serializeAt (off + 4) arr val
|
||||
Unbox.pokeAt off arr (int_w32 (off1 - off - 4) :: Word32)
|
||||
pure off1
|
||||
|
||||
@ -238,7 +238,7 @@ mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
|
||||
-- We first compare the header length encoded and the current header
|
||||
-- length. Only if the header lengths match, we compare the headers.
|
||||
[|do $(varP afterHLen) <-
|
||||
serialize
|
||||
serializeAt
|
||||
($(varE initialOffset) + 4)
|
||||
$(varE _arr)
|
||||
($(litIntegral hlen) :: Word32)
|
||||
@ -264,7 +264,7 @@ mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
|
||||
{-# INLINE deserializeWithSize #-}
|
||||
deserializeWithSize ::
|
||||
Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
|
||||
deserializeWithSize off arr endOff = deserialize (off + 4) arr endOff
|
||||
deserializeWithSize off arr endOff = deserializeAt (off + 4) arr endOff
|
||||
|
||||
conUpdateFuncDec :: Name -> [Field] -> Q [Dec]
|
||||
conUpdateFuncDec funcName fields = do
|
||||
@ -282,7 +282,7 @@ conUpdateFuncDec funcName fields = do
|
||||
wildP
|
||||
(normalB
|
||||
[|do (valOff, valLen :: Word32) <-
|
||||
deserialize
|
||||
deserializeAt
|
||||
$(varE curOff)
|
||||
$(varE arr)
|
||||
$(varE endOff)
|
||||
@ -317,7 +317,7 @@ conUpdateFuncDec funcName fields = do
|
||||
(litP fnameLit)
|
||||
(normalB
|
||||
[|do (valOff, valLen :: Word32) <-
|
||||
deserialize
|
||||
deserializeAt
|
||||
$(varE currOff)
|
||||
$(varE arr)
|
||||
$(varE endOff)
|
||||
@ -345,7 +345,7 @@ mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do
|
||||
errorUnsupported "The datatype should use record syntax."
|
||||
method <-
|
||||
[|do (dataOff, hlist :: CompactList (CompactList Word8)) <-
|
||||
deserialize $(varE hOff) $(varE arr) $(varE endOff)
|
||||
deserializeAt $(varE hOff) $(varE arr) $(varE endOff)
|
||||
let keys = wListToString . unCompactList <$> unCompactList hlist
|
||||
($(varP kvEncoded), _) <-
|
||||
foldlM
|
||||
@ -390,9 +390,9 @@ mkRecDeserializeExpr initialOff endOff deserializeWithKeys con = do
|
||||
sizeForHeaderLength = 4 -- Word32
|
||||
sizePreData = sizeForFinalOff + sizeForHeaderLength + hlen
|
||||
[|do (hlenOff, encLen :: Word32) <-
|
||||
deserialize $(varE initialOff) $(varE _arr) $(varE endOff)
|
||||
deserializeAt $(varE initialOff) $(varE _arr) $(varE endOff)
|
||||
($(varP hOff), hlen1 :: Word32) <-
|
||||
deserialize hlenOff $(varE _arr) $(varE endOff)
|
||||
deserializeAt hlenOff $(varE _arr) $(varE endOff)
|
||||
if (hlen1 == $(litIntegral hlen)) && $(xorCmp hval hOff _arr)
|
||||
then do
|
||||
let $(varP (makeI 0)) =
|
||||
|
@ -58,14 +58,14 @@ import GHC.Exts
|
||||
-- particular constructor. For variable length data types the length is encoded
|
||||
-- along with the data.
|
||||
--
|
||||
-- The 'deserialize' operation reads bytes from the mutable byte array and
|
||||
-- The 'deserializeAt' operation reads bytes from the mutable byte array and
|
||||
-- builds a Haskell data type from these bytes, the number of bytes it reads
|
||||
-- depends on the type and the encoded value it is reading. 'serialize'
|
||||
-- depends on the type and the encoded value it is reading. 'serializeAt'
|
||||
-- operation converts a Haskell data type to its binary representation which
|
||||
-- must consist of as many bytes as returned by the @size@ operation on that
|
||||
-- must consist of as many bytes as added by the @addSizeTo@ operation for that
|
||||
-- value and then stores these bytes into the mutable byte array. The
|
||||
-- programmer is expected to use the @size@ operation and allocate an array of
|
||||
-- sufficient length before calling 'serialize'.
|
||||
-- programmer is expected to use the @addSizeTo@ operation and allocate an
|
||||
-- array of sufficient length before calling 'serializeAt'.
|
||||
--
|
||||
-- IMPORTANT: The serialized data's byte ordering remains the same as the host
|
||||
-- machine's byte order. Therefore, it can not be deserialized from host
|
||||
@ -98,15 +98,15 @@ import GHC.Exts
|
||||
--
|
||||
-- >>> :{
|
||||
-- instance Serialize Object where
|
||||
-- size acc obj = size (size acc (_obj1 obj)) (_obj2 obj)
|
||||
-- deserialize i arr len = do
|
||||
-- addSizeTo acc obj = addSizeTo (addSizeTo acc (_obj1 obj)) (_obj2 obj)
|
||||
-- deserializeAt i arr len = do
|
||||
-- -- Check the array bounds before reading
|
||||
-- (i1, x0) <- deserialize i arr len
|
||||
-- (i2, x1) <- deserialize i1 arr len
|
||||
-- (i1, x0) <- deserializeAt i arr len
|
||||
-- (i2, x1) <- deserializeAt i1 arr len
|
||||
-- pure (i2, Object x0 x1)
|
||||
-- serialize i arr (Object x0 x1) = do
|
||||
-- i1 <- serialize i arr x0
|
||||
-- i2 <- serialize i1 arr x1
|
||||
-- serializeAt i arr (Object x0 x1) = do
|
||||
-- i1 <- serializeAt i arr x0
|
||||
-- i2 <- serializeAt i1 arr x1
|
||||
-- pure i2
|
||||
-- :}
|
||||
--
|
||||
@ -117,30 +117,30 @@ class Serialize a where
|
||||
-- It is of the form @Int -> a -> Int@ because you can have tail-recursive
|
||||
-- traversal of the structures.
|
||||
|
||||
-- | @size accum value@ returns @accum@ incremented by the size of the
|
||||
-- | @addSizeTo accum value@ returns @accum@ incremented by the size of the
|
||||
-- serialized representation of @value@ in bytes. Size cannot be zero. It
|
||||
-- should be at least 1 byte.
|
||||
size :: Int -> a -> Int
|
||||
addSizeTo :: Int -> a -> Int
|
||||
|
||||
-- We can implement the following functions without returning the `Int`
|
||||
-- offset but that may require traversing the Haskell structure again to get
|
||||
-- the size. Therefore, this is a performance optimization.
|
||||
|
||||
-- | @deserialize byte-offset array arrayLen@ deserializes a value from the
|
||||
-- | @deserializeAt byte-offset array arrayLen@ deserializes a value from the
|
||||
-- given byte-offset in the array. Returns a tuple consisting of the next
|
||||
-- byte-offset and the deserialized value.
|
||||
--
|
||||
-- Throws an exception if the operation would exceed the supplied arrayLen.
|
||||
deserialize :: Int -> MutByteArray -> Int -> IO (Int, a)
|
||||
deserializeAt :: Int -> MutByteArray -> Int -> IO (Int, a)
|
||||
|
||||
-- | @serialize byte-offset array value@ writes the serialized
|
||||
-- | @serializeAt byte-offset array value@ writes the serialized
|
||||
-- representation of the @value@ in the array at the given byte-offset.
|
||||
-- Returns the next byte-offset.
|
||||
--
|
||||
-- This is an unsafe operation, the programmer must ensure that the array
|
||||
-- has enough space available to serialize the value as determined by the
|
||||
-- @size@ operation.
|
||||
serialize :: Int -> MutByteArray -> a -> IO Int
|
||||
-- @addSizeTo@ operation.
|
||||
serializeAt :: Int -> MutByteArray -> a -> IO Int
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Instances
|
||||
@ -191,7 +191,7 @@ deserializeUnsafe off arr sz =
|
||||
if (next <= sz)
|
||||
then Unbox.peekAt off arr >>= \val -> pure (next, val)
|
||||
else error
|
||||
$ "deserialize: accessing array at offset = "
|
||||
$ "deserializeAt: accessing array at offset = "
|
||||
++ show (next - 1)
|
||||
++ " max valid offset = " ++ show (sz - 1)
|
||||
|
||||
@ -201,19 +201,19 @@ serializeUnsafe off arr val =
|
||||
let next = off + Unbox.sizeOf (Proxy :: Proxy a)
|
||||
in do
|
||||
#ifdef DEBUG
|
||||
checkBounds "serialize" next arr
|
||||
checkBounds "serializeAt" next arr
|
||||
#endif
|
||||
Unbox.pokeAt off arr val
|
||||
pure next
|
||||
|
||||
#define DERIVE_SERIALIZE_FROM_UNBOX(_type) \
|
||||
instance Serialize _type where \
|
||||
; {-# INLINE size #-} \
|
||||
; size acc _ = acc + Unbox.sizeOf (Proxy :: Proxy _type) \
|
||||
; {-# INLINE deserialize #-} \
|
||||
; deserialize off arr end = deserializeUnsafe off arr end :: IO (Int, _type) \
|
||||
; {-# INLINE serialize #-} \
|
||||
; serialize = \
|
||||
; {-# INLINE addSizeTo #-} \
|
||||
; addSizeTo acc _ = acc + Unbox.sizeOf (Proxy :: Proxy _type) \
|
||||
; {-# INLINE deserializeAt #-} \
|
||||
; deserializeAt off arr end = deserializeUnsafe off arr end :: IO (Int, _type) \
|
||||
; {-# INLINE serializeAt #-} \
|
||||
; serializeAt = \
|
||||
serializeUnsafe :: Int -> MutByteArray -> _type -> IO Int
|
||||
|
||||
DERIVE_SERIALIZE_FROM_UNBOX(())
|
||||
@ -237,68 +237,69 @@ DERIVE_SERIALIZE_FROM_UNBOX((FunPtr a))
|
||||
|
||||
instance forall a. Serialize a => Serialize [a] where
|
||||
|
||||
-- {-# INLINE size #-}
|
||||
size acc xs = foldl' size (acc + (Unbox.sizeOf (Proxy :: Proxy Int))) xs
|
||||
-- {-# INLINE addSizeTo #-}
|
||||
addSizeTo acc xs =
|
||||
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Int))) xs
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE deserialize #-}
|
||||
deserialize off arr sz = do
|
||||
(off1, len64) <- deserialize off arr sz :: IO (Int, Int64)
|
||||
{-# INLINABLE deserializeAt #-}
|
||||
deserializeAt off arr sz = do
|
||||
(off1, len64) <- deserializeAt off arr sz :: IO (Int, Int64)
|
||||
let len = (fromIntegral :: Int64 -> Int) len64
|
||||
peekList f o i | i >= 3 = do
|
||||
-- Unfold the loop three times
|
||||
(o1, x1) <- deserialize o arr sz
|
||||
(o2, x2) <- deserialize o1 arr sz
|
||||
(o3, x3) <- deserialize o2 arr sz
|
||||
(o1, x1) <- deserializeAt o arr sz
|
||||
(o2, x2) <- deserializeAt o1 arr sz
|
||||
(o3, x3) <- deserializeAt o2 arr sz
|
||||
peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3)
|
||||
peekList f o 0 = pure (o, f [])
|
||||
peekList f o i = do
|
||||
(o1, x) <- deserialize o arr sz
|
||||
(o1, x) <- deserializeAt o arr sz
|
||||
peekList (f . (x:)) o1 (i - 1)
|
||||
peekList id off1 len
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE serialize #-}
|
||||
serialize off arr val = do
|
||||
{-# INLINABLE serializeAt #-}
|
||||
serializeAt off arr val = do
|
||||
let off1 = off + Unbox.sizeOf (Proxy :: Proxy Int64)
|
||||
let pokeList acc o [] =
|
||||
Unbox.pokeAt off arr (acc :: Int64) >> pure o
|
||||
pokeList acc o (x:xs) = do
|
||||
o1 <- serialize o arr x
|
||||
o1 <- serializeAt o arr x
|
||||
pokeList (acc + 1) o1 xs
|
||||
pokeList 0 off1 val
|
||||
|
||||
instance Serialize (Array a) where
|
||||
{-# INLINE size #-}
|
||||
size i (Array {..}) = i + (arrEnd - arrStart) + 8
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo i (Array {..}) = i + (arrEnd - arrStart) + 8
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize off arr end = do
|
||||
(off1, byteLen) <- deserialize off arr end :: IO (Int, Int)
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt off arr end = do
|
||||
(off1, byteLen) <- deserializeAt off arr end :: IO (Int, Int)
|
||||
let off2 = off1 + byteLen
|
||||
let slice = MutArray.MutArray arr off1 off2 off2
|
||||
newArr <- MutArray.clone slice
|
||||
pure (off2, Array.unsafeFreeze newArr)
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize off arr (Array {..}) = do
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt off arr (Array {..}) = do
|
||||
let arrLen = arrEnd - arrStart
|
||||
off1 <- serialize off arr arrLen
|
||||
off1 <- serializeAt off arr arrLen
|
||||
MBA.putSliceUnsafe arrContents arrStart arr off1 arrLen
|
||||
pure (off1 + arrLen)
|
||||
|
||||
instance (Serialize a, Serialize b) => Serialize (a, b) where
|
||||
|
||||
{-# INLINE size #-}
|
||||
size acc (a, b) = size (size acc a) b
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc (a, b) = addSizeTo (addSizeTo acc a) b
|
||||
|
||||
{-# INLINE serialize #-}
|
||||
serialize off arr (a, b) = do
|
||||
off1 <- serialize off arr a
|
||||
serialize off1 arr b
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt off arr (a, b) = do
|
||||
off1 <- serializeAt off arr a
|
||||
serializeAt off1 arr b
|
||||
|
||||
{-# INLINE deserialize #-}
|
||||
deserialize off arr end = do
|
||||
(off1, a) <- deserialize off arr end
|
||||
(off2, b) <- deserialize off1 arr end
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt off arr end = do
|
||||
(off1, a) <- deserializeAt off arr end
|
||||
(off2, b) <- deserializeAt off1 arr end
|
||||
pure (off2, (a, b))
|
||||
|
@ -160,7 +160,7 @@ poke ::
|
||||
=> a
|
||||
-> IO (MutByteArray, Int, Int)
|
||||
poke val = do
|
||||
let sz = Serialize.size 0 val
|
||||
let sz = Serialize.addSizeTo 0 val
|
||||
|
||||
let excessSize = 100
|
||||
randomOff <- randomRIO (10, excessSize)
|
||||
@ -171,7 +171,7 @@ poke val = do
|
||||
serEndOff = randomOff + sz
|
||||
arr <- Serialize.new arrSize
|
||||
|
||||
off1 <- Serialize.serialize serStartOff arr val
|
||||
off1 <- Serialize.serializeAt serStartOff arr val
|
||||
off1 `shouldBe` serEndOff
|
||||
pure (arr, serStartOff, serEndOff)
|
||||
|
||||
@ -181,7 +181,7 @@ peekAndVerify ::
|
||||
-> a
|
||||
-> IO ()
|
||||
peekAndVerify (arr, serStartOff, serEndOff) val = do
|
||||
(off2, val2) <- Serialize.deserialize serStartOff arr serEndOff
|
||||
(off2, val2) <- Serialize.deserializeAt serStartOff arr serEndOff
|
||||
val2 `shouldBe` val
|
||||
off2 `shouldBe` serEndOff
|
||||
let slice = Array.Array arr serStartOff serEndOff
|
||||
@ -207,7 +207,7 @@ testSerializeList
|
||||
-> IO ()
|
||||
testSerializeList sizeOfA val = do
|
||||
|
||||
let sz = Serialize.size 0 val
|
||||
let sz = Serialize.addSizeTo 0 val
|
||||
|
||||
sz `shouldBe` sizeOfA
|
||||
|
||||
|
@ -40,8 +40,8 @@ import Test.Hspec as H
|
||||
|
||||
#define MODULE_NAME "Data.Serialize.Deriving.TH"
|
||||
#define DERIVE_UNBOX(typ) $(deriveSerialize [d|instance Serialize typ|])
|
||||
#define PEEK(i, arr, sz) (deserialize i arr sz)
|
||||
#define POKE(i, arr, val) (serialize i arr val)
|
||||
#define PEEK(i, arr, sz) (deserializeAt i arr sz)
|
||||
#define POKE(i, arr, val) (serializeAt i arr val)
|
||||
#define TYPE_CLASS Serialize
|
||||
|
||||
#else
|
||||
@ -185,7 +185,7 @@ variableSizeOf ::
|
||||
forall a. Serialize a
|
||||
=> a
|
||||
-> Int
|
||||
variableSizeOf = size 0
|
||||
variableSizeOf = addSizeTo 0
|
||||
#endif
|
||||
|
||||
testSerialization ::
|
||||
|
Loading…
Reference in New Issue
Block a user