@@ -19,18 +19,13 @@ module Streamly.Internal.Data.Serialize.TH
1919-- Imports
2020--------------------------------------------------------------------------------
2121
22−import Data.Char (ord)
2322import Data.List (foldl')
2423import Data.Word (Word16, Word32, Word64, Word8)
25−import Data.Bits (Bits, (.|.), shiftL, zeroBits, xor)
26−import Streamly.Internal.System.IO (unsafeInlineIO)
2724
2825import Language.Haskell.TH
2926import Language.Haskell.TH.Syntax
3027import Streamly.Internal.Data.Serialize.Type
3128
32−import qualified Streamly.Internal.Data.Unbox as Unbox
33−
3429import Streamly.Internal.Data.Unbox.TH
3530 ( DataCon(..)
3631 , DataType(..)
@@ -38,130 +33,12 @@ import Streamly.Internal.Data.Unbox.TH
3833 , plainInstanceD
3934 , reifyDataType
4035 )
41−
42−--------------------------------------------------------------------------------
43−-- Config
44−--------------------------------------------------------------------------------
45−
46−-- | Config to control how the 'Serialize' instance is generated.
47−data Config =
48− Config
49− { unconstrained :: [String]
50− -- ^ Type variables that should not have the 'Serialize' constraint.
51− --
52− -- @
53− -- data CustomDataType a b c d = CustomDataType a c
54− -- @
55− --
56− -- @
57− -- conf = defaultConf {unconstrained = ["b", "d"]}
58− -- \$(deriveSerializeWith conf ''CustomDataType)
59− -- @
60− --
61− -- @
62− -- instance (Serialize a, Serialize c) => Serialize (CustomDataType a b c d) where
63− -- ...
64− -- @
65− , specializations :: [(String, Type)]
66− -- ^ Specialize the type variable with the given type. All type
67− -- variables listed here will not have the 'Serialize' constriant as
68− -- they are specialized.
69− --
70− -- @
71− -- data CustomDataType f a = CustomDataType (f a)
72− -- @
73− --
74− -- @
75− -- conf = defaultConf {specializations = [("f", ''Identity)]}
76− -- \$(deriveSerializeWith conf ''CustomDataType)
77− -- @
78− --
79− -- @
80− -- instance (Serialize a) => Serialize (CustomDataType Identity a) where
81− -- ...
82− -- @
83− --
84− -- @f@ is replaced with 'Identity' and becomes unconstrained.
85− , inlineSize :: Inline
86− -- ^ Inline value for 'size'. Default is Inline.
87− , inlineSerialize :: Inline
88− -- ^ Inline value for 'serialize'. Default is Inline.
89− , inlineDeserialize :: Inline
90− -- ^ Inline value for 'deserialize'. Default is Inline.
91− , constructorTagAsString :: Bool
92− -- ^ __Experimental__
93− --
94− -- If True, encode constructors using the constructor names as Latin-1
95− -- byte sequence.
96− , recordSyntaxWithHeader :: Bool
97− -- ^ __Experimental__
98− --
99− -- If True, encode the keys of the record as a header and then
100− -- serialize the data.
101− }
102−
103−defaultConfig :: Config
104−defaultConfig =
105− Config
106− { unconstrained = []
107− , specializations = []
108− , inlineSize = Inline
109− , inlineSerialize = Inline
110− , inlineDeserialize = Inline
111− , constructorTagAsString = False
112− , recordSyntaxWithHeader = False
113− }
114−
115−--------------------------------------------------------------------------------
116−-- Helpers
117−--------------------------------------------------------------------------------
118−
119−type Field = (Maybe Name, Type)
120−
121−_x :: Name
122−_x = mkName "x"
123−
124−_acc :: Name
125−_acc = mkName "acc"
126−
127−_arr :: Name
128−_arr = mkName "arr"
129−
130−_tag :: Name
131−_tag = mkName "tag"
132−
133−_initialOffset :: Name
134−_initialOffset = mkName "initialOffset"
135−
136−_endOffset :: Name
137−_endOffset = mkName "endOffset"
138−
139−_val :: Name
140−_val = mkName "val"
141−
142−mkFieldName :: Int -> Name
143−mkFieldName i = mkName ("field" ++ show i)
144−
145−makeI :: Int -> Name
146−makeI i = mkName $ "i" ++ show i
147−
148−makeN :: Int -> Name
149−makeN i = mkName $ "n" ++ show i
150−
151−makeA :: Int -> Name
152−makeA i = mkName $ "a" ++ show i
36+import Streamly.Internal.Data.Serialize.TH.Bottom
15337
15438--------------------------------------------------------------------------------
15539-- Domain specific helpers
15640--------------------------------------------------------------------------------
15741
158−matchConstructor :: Name -> Int -> Q Exp -> Q Match
159−matchConstructor cname numFields exp0 =
160− match
161− (conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
162− (normalB exp0)
163− []
164−
16542exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
16643exprGetSize acc (i, _) = [|size $(acc) $(varE (mkFieldName i))|]
16744
@@ -183,182 +60,10 @@ getTagType numConstructors
18360 | fromIntegral (maxBound :: Word64) >= numConstructors = ''Word64
18461 | otherwise = error "Too many constructors"
18562
186−--------------------------------------------------------------------------------
187−-- Constructor types
188−--------------------------------------------------------------------------------
189−
190−data SimpleDataCon =
191− SimpleDataCon Name [Field]
192− deriving (Eq)
193−
194−simplifyDataCon :: DataCon -> SimpleDataCon
195−simplifyDataCon (DataCon cname _ _ fields) = SimpleDataCon cname fields
196−
197−data TypeOfType
198− = UnitType Name -- 1 constructor and 1 field
199− | TheType SimpleDataCon -- 1 constructor and 1+ fields
200− | MultiType [SimpleDataCon] -- 1+ constructors
201− deriving (Eq)
202−
203−typeOfType :: Type -> [DataCon] -> TypeOfType
204−typeOfType headTy [] =
205− error
206− ("Attempting to get size with no constructors (" ++
207− (pprint headTy) ++ ")")
208−typeOfType _ [DataCon cname _ _ []] = UnitType cname
209−typeOfType _ [con@(DataCon _ _ _ _)] = TheType $ simplifyDataCon con
210−typeOfType _ cons = MultiType $ map simplifyDataCon cons
211−
212−isUnitType :: [DataCon] -> Bool
213−isUnitType [DataCon _ _ _ []] = True
214−isUnitType _ = False
215−
216−--------------------------------------------------------------------------------
217−-- Size
218−--------------------------------------------------------------------------------
219−
220−{-
221−int_w8 :: Int -> Word8
222−int_w8 = fromIntegral
223−-}
224−
225−w8_w16 :: Word8 -> Word16
226−w8_w16 = fromIntegral
227−
228−w8_w32 :: Word8 -> Word32
229−w8_w32 = fromIntegral
230−
231−w8_w64 :: Word8 -> Word64
232−w8_w64 = fromIntegral
233−
234−{-
235−w32_int :: Word32 -> Int
236−w32_int = fromIntegral
237−-}
238−
239−c2w :: Char -> Word8
240−c2w = fromIntegral . ord
241−
242−shiftAdd :: Bits a => (b -> a) -> [b] -> a
243−shiftAdd conv xs =
244− foldl' (.|.) zeroBits $
245− map (\(j, x) -> shiftL x (j * 8)) $ zip [0 ..] $ map conv xs
246−
247−-- Note: This only works in little endian machines
248−-- TODO:
249−-- Instead of generating this via TH can't we write it directly in Haskell and
250−-- use that? Creating one comparison function for each deserialization may be
251−-- too much code and may not be necessary.
252−-- Benchmark both the implementations and check.
253−xorCmp :: [Word8] -> Name -> Name -> Q Exp
254−xorCmp tag off arr =
255− case tagLen of
256− x | x < 2 -> [|$(go8 0) == zeroBits|]
257− x | x < 4 -> [|$(go16 0) == zeroBits|]
258− x | x < 8 -> [|$(go32 0) == zeroBits|]
259− _ -> [|$(go64 0) == zeroBits|]
260− where
261− tagLen = length tag
262− go8 i | i >= tagLen = [|zeroBits|]
263− go8 i = do
264− let wIntegral = litIntegral i
265− [|xor (unsafeInlineIO
266− (Unbox.peekByteIndex
267− ($(varE off) + $(litIntegral i))
268− $(varE arr)))
269− ($(wIntegral) :: Word8) .|.
270− $(go8 (i + 1))|]
271− go16 i
272− | i >= tagLen = [|zeroBits|]
273− go16 i
274− | tagLen - i < 2 = go16 (tagLen - 2)
275− go16 i = do
276− let wIntegral =
277− litIntegral
278− (shiftAdd w8_w16 [tag !! i, tag !! (i + 1)] :: Word16)
279− [|xor (unsafeInlineIO
280− (Unbox.peekByteIndex
281− ($(varE off) + $(litIntegral i))
282− $(varE arr)))
283− ($(wIntegral) :: Word16) .|.
284− $(go16 (i + 2))|]
285− go32 i
286− | i >= tagLen = [|zeroBits|]
287− go32 i
288− | tagLen - i < 4 = go32 (tagLen - 4)
289− go32 i = do
290− let wIntegral =
291− litIntegral
292− (shiftAdd
293− w8_w32
294− [ tag !! i
295− , tag !! (i + 1)
296− , tag !! (i + 2)
297− , tag !! (i + 3)
298− ] :: Word32)
299− [|xor (unsafeInlineIO
300− (Unbox.peekByteIndex
301− ($(varE off) + $(litIntegral i))
302− $(varE arr)))
303− ($(wIntegral) :: Word32) .|.
304− $(go32 (i + 4))|]
305− go64 i
306− | i >= tagLen = [|zeroBits|]
307− go64 i
308− | tagLen - i < 8 = go64 (tagLen - 8)
309− go64 i = do
310− let wIntegral =
311− litIntegral
312− (shiftAdd
313− w8_w64
314− [ tag !! i
315− , tag !! (i + 1)
316− , tag !! (i + 2)
317− , tag !! (i + 3)
318− , tag !! (i + 4)
319− , tag !! (i + 5)
320− , tag !! (i + 6)
321− , tag !! (i + 7)
322− ])
323− [|xor (unsafeInlineIO
324− (Unbox.peekByteIndex
325− ($(varE off) + $(litIntegral i))
326− $(varE arr)))
327− ($(wIntegral) :: Word64) .|.
328− $(go64 (i + 8))|]
329−
330−--------------------------------------------------------------------------------
331−-- Primitive serialization
332−--------------------------------------------------------------------------------
333−
334−-- TODO:
335−-- Will this be too much of a code bloat?
336−-- Loop with the loop body unrolled?
337−-- Serialize this in batches similar to batch comparision in xorCmp?
338−serializeW8List :: Name -> Name -> [Word8] -> Q Exp
339−serializeW8List off arr w8List = do
340− [|let $(varP (makeN 0)) = $(varE off)
341− in $(doE (fmap makeBind [0 .. (lenW8List - 1)] ++
342− [noBindS ([|pure $(varE (makeN lenW8List))|])]))|]
343−
344− where
345−
346− lenW8List = length w8List
347− makeBind i =
348− bindS
349− (varP (makeN (i + 1)))
350− [|$(varE 'serialize)
351− $(varE (makeN i))
352− $(varE arr)
353− ($(litIntegral (w8List !! i)) :: Word8)|]
354−
35563--------------------------------------------------------------------------------
35664-- Size
35765--------------------------------------------------------------------------------
35866
359−litIntegral :: Integral a => a -> Q Exp
360−litIntegral = litE . IntegerL . fromIntegral
361−
36267getNameBaseLen :: Name -> Word8
36368getNameBaseLen cname =
36469 let x = length (nameBase cname)