git.iko.soy/streamly
on cedc81c help sign in
streamly/core/src/Streamly/Internal/Data/Serialize/TH.hs
750 lines 25 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3-- |
4-- Module : Streamly.Internal.Data.Serialize.TH
5-- Copyright : (c) 2023 Composewell Technologies
6-- License : BSD3-3-Clause
7-- Maintainer : streamly@composewell.com
8-- Stability : experimental
9-- Portability : GHC
10--
11module Streamly.Internal.Data.Serialize.TH
12 ( deriveSerialize
13 , Config(..)
14 , defaultConfig
15 , deriveSerializeWith
16 ) where
18--------------------------------------------------------------------------------
19-- Imports
20--------------------------------------------------------------------------------
22import Data.Char (ord)
23import Data.List (foldl')
24import Data.Word (Word16, Word32, Word64, Word8)
25import Data.Bits (Bits, (.|.), shiftL, zeroBits, xor)
26import Streamly.Internal.System.IO (unsafeInlineIO)
28import Language.Haskell.TH
29import Language.Haskell.TH.Syntax
30import Streamly.Internal.Data.Serialize
32import qualified Streamly.Internal.Data.Unbox as Unbox
34import Streamly.Internal.Data.Unbox.TH
35 ( DataCon(..)
36 , DataType(..)
37 , appsT
38 , plainInstanceD
39 , reifyDataType
40 )
42--------------------------------------------------------------------------------
43-- Helpers
44--------------------------------------------------------------------------------
46type Field = (Maybe Name, Type)
48_x :: Name
49_x = mkName "x"
51_acc :: Name
52_acc = mkName "acc"
54_arr :: Name
55_arr = mkName "arr"
57_tag :: Name
58_tag = mkName "tag"
60_initialOffset :: Name
61_initialOffset = mkName "initialOffset"
63_endOffset :: Name
64_endOffset = mkName "endOffset"
66_val :: Name
67_val = mkName "val"
69mkFieldName :: Int -> Name
70mkFieldName i = mkName ("field" ++ show i)
72makeI :: Int -> Name
73makeI i = mkName $ "i" ++ show i
75makeN :: Int -> Name
76makeN i = mkName $ "n" ++ show i
78makeA :: Int -> Name
79makeA i = mkName $ "a" ++ show i
81--------------------------------------------------------------------------------
82-- Domain specific helpers
83--------------------------------------------------------------------------------
85matchConstructor :: Name -> Int -> Q Exp -> Q Match
86matchConstructor cname numFields exp0 =
87 match
88 (conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
89 (normalB exp0)
90 []
92exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
93exprGetSize acc (i, _) = [|size $(acc) $(varE (mkFieldName i))|]
95getTagSize :: Int -> Int
96getTagSize numConstructors
97 | numConstructors == 1 = 0
98 | fromIntegral (maxBound :: Word8) >= numConstructors = 1
99 | fromIntegral (maxBound :: Word16) >= numConstructors = 2
100 | fromIntegral (maxBound :: Word32) >= numConstructors = 4
101 | fromIntegral (maxBound :: Word64) >= numConstructors = 8
102 | otherwise = error "Too many constructors"
104getTagType :: Int -> Name
105getTagType numConstructors
106 | numConstructors == 1 = error "No tag for 1 constructor"
107 | fromIntegral (maxBound :: Word8) >= numConstructors = ''Word8
108 | fromIntegral (maxBound :: Word16) >= numConstructors = ''Word16
109 | fromIntegral (maxBound :: Word32) >= numConstructors = ''Word32
110 | fromIntegral (maxBound :: Word64) >= numConstructors = ''Word64
111 | otherwise = error "Too many constructors"
113--------------------------------------------------------------------------------
114-- Constructor types
115--------------------------------------------------------------------------------
117data SimpleDataCon =
118 SimpleDataCon Name [Field]
119 deriving (Eq)
121simplifyDataCon :: DataCon -> SimpleDataCon
122simplifyDataCon (DataCon cname _ _ fields) = SimpleDataCon cname fields
124data TypeOfType
125 = UnitType Name -- 1 constructor and 1 field
126 | TheType SimpleDataCon -- 1 constructor and 1+ fields
127 | MultiType [SimpleDataCon] -- 1+ constructors
128 deriving (Eq)
130typeOfType :: Type -> [DataCon] -> TypeOfType
131typeOfType headTy [] =
132 error
133 ("Attempting to get size with no constructors (" ++
134 (pprint headTy) ++ ")")
135typeOfType _ [DataCon cname _ _ []] = UnitType cname
136typeOfType _ [con@(DataCon _ _ _ _)] = TheType $ simplifyDataCon con
137typeOfType _ cons = MultiType $ map simplifyDataCon cons
139isUnitType :: [DataCon] -> Bool
140isUnitType [DataCon _ _ _ []] = True
141isUnitType _ = False
143--------------------------------------------------------------------------------
144-- Size
145--------------------------------------------------------------------------------
147{-
148int_w8 :: Int -> Word8
149int_w8 = fromIntegral
150-}
152w8_w16 :: Word8 -> Word16
153w8_w16 = fromIntegral
155w8_w32 :: Word8 -> Word32
156w8_w32 = fromIntegral
158w8_w64 :: Word8 -> Word64
159w8_w64 = fromIntegral
161{-
162w32_int :: Word32 -> Int
163w32_int = fromIntegral
164-}
166c2w :: Char -> Word8
167c2w = fromIntegral . ord
169shiftAdd :: Bits a => (b -> a) -> [b] -> a
170shiftAdd conv xs =
171 foldl' (.|.) zeroBits $
172 map (\(j, x) -> shiftL x (j * 8)) $ zip [0 ..] $ map conv xs
174-- Note: This only works in little endian machines
175xorCmp :: [Word8] -> Name -> Name -> Q Exp
176xorCmp tag off arr =
177 case tagLen of
178 x | x < 2 -> [|$(go8 0) == zeroBits|]
179 x | x < 4 -> [|$(go16 0) == zeroBits|]
180 x | x < 8 -> [|$(go32 0) == zeroBits|]
181 _ -> [|$(go64 0) == zeroBits|]
182 where
183 tagLen = length tag
184 go8 i | i >= tagLen = [|zeroBits|]
185 go8 i = do
186 let wIntegral = litIntegral i
187 [|xor (unsafeInlineIO
188 (Unbox.peekByteIndex
189 ($(varE off) + $(litIntegral i))
190 $(varE arr)))
191 ($(wIntegral) :: Word8) .|.
192 $(go8 (i + 1))|]
193 go16 i
194 | i >= tagLen = [|zeroBits|]
195 go16 i
196 | tagLen - i < 2 = go16 (tagLen - 2)
197 go16 i = do
198 let wIntegral =
199 litIntegral
200 (shiftAdd w8_w16 [tag !! i, tag !! (i + 1)] :: Word16)
201 [|xor (unsafeInlineIO
202 (Unbox.peekByteIndex
203 ($(varE off) + $(litIntegral i))
204 $(varE arr)))
205 ($(wIntegral) :: Word16) .|.
206 $(go16 (i + 2))|]
207 go32 i
208 | i >= tagLen = [|zeroBits|]
209 go32 i
210 | tagLen - i < 4 = go32 (tagLen - 4)
211 go32 i = do
212 let wIntegral =
213 litIntegral
214 (shiftAdd
215 w8_w32
216 [ tag !! i
217 , tag !! (i + 1)
218 , tag !! (i + 2)
219 , tag !! (i + 3)
220 ] :: Word32)
221 [|xor (unsafeInlineIO
222 (Unbox.peekByteIndex
223 ($(varE off) + $(litIntegral i))
224 $(varE arr)))
225 ($(wIntegral) :: Word32) .|.
226 $(go32 (i + 4))|]
227 go64 i
228 | i >= tagLen = [|zeroBits|]
229 go64 i
230 | tagLen - i < 8 = go64 (tagLen - 8)
231 go64 i = do
232 let wIntegral =
233 litIntegral
234 (shiftAdd
235 w8_w64
236 [ tag !! i
237 , tag !! (i + 1)
238 , tag !! (i + 2)
239 , tag !! (i + 3)
240 , tag !! (i + 4)
241 , tag !! (i + 5)
242 , tag !! (i + 6)
243 , tag !! (i + 7)
244 ])
245 [|xor (unsafeInlineIO
246 (Unbox.peekByteIndex
247 ($(varE off) + $(litIntegral i))
248 $(varE arr)))
249 ($(wIntegral) :: Word64) .|.
250 $(go64 (i + 8))|]
252--------------------------------------------------------------------------------
253-- Primitive serialization
254--------------------------------------------------------------------------------
256-- XXX Batch serialize? See xorCmp
257serializeW8List :: Name -> Name -> [Word8] -> Q Exp
258serializeW8List off arr w8List = do
259 [|let $(varP (makeN 0)) = $(varE off)
260 in $(doE (fmap makeBind [0 .. (lenW8List - 1)] ++
261 [noBindS ([|pure $(varE (makeN lenW8List))|])]))|]
263 where
265 lenW8List = length w8List
266 makeBind i =
267 bindS
268 (varP (makeN (i + 1)))
269 [|$(varE 'serialize)
270 $(varE (makeN i))
271 $(varE arr)
272 ($(litIntegral (w8List !! i)) :: Word8)|]
274--------------------------------------------------------------------------------
275-- Size
276--------------------------------------------------------------------------------
278litIntegral :: Integral a => a -> Q Exp
279litIntegral = litE . IntegerL . fromIntegral
281getNameBaseLen :: Name -> Word8
282getNameBaseLen cname =
283 let x = length (nameBase cname)
284 in if x > 63
285 then error "Max Constructor Len: 63 characters"
286 else fromIntegral x
288conEncLen :: Name -> Word8
289conEncLen cname = getNameBaseLen cname + 1
291--------------------------------------------------------------------------------
292-- Size
293--------------------------------------------------------------------------------
295mkSizeOfExpr :: Bool -> TypeOfType -> Q Exp
296mkSizeOfExpr True tyOfTy =
297 case tyOfTy of
298 UnitType cname ->
299 lamE
300 [varP _acc, wildP]
301 [|$(varE _acc) + $(litIntegral (conEncLen cname))|]
302 TheType con ->
303 lamE
304 [varP _acc, varP _x]
305 (caseE (varE _x) [matchCons (varE _acc) con])
306 MultiType constructors -> sizeOfHeadDt constructors
308 where
310 sizeOfFields acc fields =
311 foldl' exprGetSize acc $ zip [0..] fields
313 matchCons acc (SimpleDataCon cname fields) =
314 let a = litIntegral (conEncLen cname)
315 b = sizeOfFields acc (map snd fields)
316 expr = [|$(a) + $(b)|]
317 in matchConstructor cname (length fields) expr
319 sizeOfHeadDt cons =
320 let acc = [|$(varE _acc)|]
321 in lamE
322 [varP _acc, varP _x]
323 (caseE (varE _x) (fmap (matchCons acc) cons))
325mkSizeOfExpr False tyOfTy =
326 case tyOfTy of
327 UnitType _ -> lamE [varP _acc, wildP] [|$(varE _acc) + 1|]
328 TheType con ->
329 lamE
330 [varP _acc, varP _x]
331 (caseE (varE _x) [matchCons (varE _acc) con])
332 MultiType constructors -> sizeOfHeadDt constructors
334 where
336 tagSizeExp numConstructors =
337 litE (IntegerL (fromIntegral (getTagSize numConstructors)))
339 -- XXX fields of the same type can be folded together, will reduce the code
340 -- size when there are many fields of the same type.
341 -- XXX const size fields can be calculated statically.
342 -- XXX This can result in large compilation times due to nesting when there
343 -- are many constructors. We can create a list and sum the list at run time
344 -- to avoid that depending on the number of constructors. Or using a let
345 -- statement for each case may help?
346 -- appE (varE 'sum) (listE (acc : map (exprGetSize (litE (IntegerL 0))) (zip [0..] fields)))
347 sizeOfFields acc fields =
348 foldl' exprGetSize acc $ zip [0..] fields
350 matchCons acc (SimpleDataCon cname fields) =
351 let expr = sizeOfFields acc (map snd fields)
352 in matchConstructor cname (length fields) expr
354 -- XXX We fix VarSize for simplicity. Should be changed later.
355 sizeOfHeadDt cons =
356 let numCons = length cons
357 acc = [|$(varE _acc) + $(tagSizeExp numCons)|]
358 in lamE
359 [varP _acc, varP _x]
360 (caseE (varE _x) (fmap (matchCons acc) cons))
362--------------------------------------------------------------------------------
363-- Peek
364--------------------------------------------------------------------------------
366mkDeserializeExprOne :: SimpleDataCon -> Q Exp
367mkDeserializeExprOne (SimpleDataCon cname fields) =
368 case fields of
369 -- Only tag is serialized for unit fields, no actual value
370 [] -> [|pure ($(varE (mkName "i0")), $(conE cname))|]
371 _ ->
372 doE
373 (concat
374 [ fmap makeBind [0 .. (numFields - 1)]
375 , [ noBindS
376 (appE
377 (varE 'pure)
378 (tupE
379 [ varE (makeI numFields)
380 , appsE
381 (conE cname :
382 (map (varE . makeA)
383 [0 .. (numFields - 1)]))
384 ]))
385 ]
386 ])
387 where
388 numFields = length fields
389 makeBind i =
390 bindS
391 (tupP [varP (makeI (i + 1)), varP (makeA i)])
392 [|deserialize $(varE (makeI i)) $(varE _arr) $(varE _endOffset)|]
395mkDeserializeExpr :: Bool -> Type -> TypeOfType -> Q Exp
396mkDeserializeExpr True headTy tyOfTy =
397 case tyOfTy of
398 UnitType cname -> deserializeConsExpr [SimpleDataCon cname []]
399 TheType con -> deserializeConsExpr [con]
400 MultiType cons -> deserializeConsExpr cons
402 where
404 deserializeConsExpr cons = do
405 conLen <- newName "conLen"
406 off1 <- newName "off1"
407 [|do ($(varP off1), $(varP conLen) :: Word8) <-
408 deserialize
409 $(varE _initialOffset)
410 $(varE _arr)
411 $(varE _endOffset)
412 $(multiIfE (map (guardCon conLen off1) cons ++ [catchAll]))|]
414 catchAll =
415 normalGE
416 [|True|]
417 [|error
418 ("Found invalid tag while peeking (" ++
419 $(lift (pprint headTy)) ++ ")")|]
421 guardCon conLen off con@(SimpleDataCon cname _) = do
422 let lenCname = getNameBaseLen cname
423 tag = map c2w (nameBase cname)
424 normalGE
425 [|($(litIntegral lenCname) == $(varE conLen))
426 && $(xorCmp tag off _arr)|]
427 [|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
428 in $(mkDeserializeExprOne con)|]
430mkDeserializeExpr False headTy tyOfTy =
431 case tyOfTy of
432 -- Unit constructor
433 UnitType cname ->
434 [|pure ($(varE _initialOffset) + 1, $(conE cname))|]
435 -- Product type
436 TheType con ->
437 letE
438 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
439 (mkDeserializeExprOne con)
440 -- Sum type
441 MultiType cons -> do
442 let lenCons = length cons
443 tagType = getTagType lenCons
444 doE
445 [ bindS
446 (tupP [varP (mkName "i0"), varP _tag])
447 [|deserialize $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
448 , noBindS
449 (caseE
450 (sigE (varE _tag) (conT tagType))
451 (map peekMatch (zip [0 ..] cons) ++ [peekErr]))
452 ]
453 where
454 peekMatch (i, con) =
455 match (litP (IntegerL i)) (normalB (mkDeserializeExprOne con)) []
456 peekErr =
457 match
458 wildP
459 (normalB
460 -- XXX Print the tag
461 [|error
462 ("Found invalid tag while peeking (" ++
463 $(lift (pprint headTy)) ++ ")")|])
464 []
466--------------------------------------------------------------------------------
467-- Poke
468--------------------------------------------------------------------------------
470mkSerializeExprTag :: Name -> Int -> Q Exp
471mkSerializeExprTag tagType tagVal =
472 [|serialize
473 $(varE _initialOffset)
474 $(varE _arr)
475 $((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
477mkSerializeExprFields :: [Field] -> Q Exp
478mkSerializeExprFields fields =
479 case fields of
480 -- Unit constructor, do nothing just tag is enough
481 [] -> [|pure ($(varE (mkName "i0")))|]
482 _ ->
483 doE
484 (fmap makeBind [0 .. (numFields - 1)] ++
485 [noBindS ([|pure $(varE (makeI numFields))|])])
486 where
487 numFields = length fields
488 makeBind i =
489 bindS
490 (varP (makeI (i + 1)))
491 [|serialize $(varE (makeI i)) $(varE _arr) $(varE (mkFieldName i))|]
493mkSerializeExpr :: Bool -> TypeOfType -> Q Exp
494mkSerializeExpr True tyOfTy =
495 case tyOfTy of
496 -- Unit type
497 UnitType cname ->
498 caseE
499 (varE _val)
500 [serializeDataCon (SimpleDataCon cname [])]
501 -- Product type
502 (TheType con) ->
503 caseE
504 (varE _val)
505 [serializeDataCon con]
506 -- Sum type
507 (MultiType cons) ->
508 caseE
509 (varE _val)
510 (map serializeDataCon cons)
512 where
514 serializeDataCon (SimpleDataCon cname fields) = do
515 let tagLen8 = getNameBaseLen cname
516 conEnc = tagLen8 : map c2w (nameBase cname)
517 matchConstructor
518 cname
519 (length fields)
520 (doE [ bindS
521 (varP (mkName "i0"))
522 (serializeW8List _initialOffset _arr conEnc)
523 , noBindS (mkSerializeExprFields fields)
524 ])
526mkSerializeExpr False tyOfTy =
527 case tyOfTy of
528 -- Unit type
529 UnitType _ -> [|pure ($(varE _initialOffset) + 1)|]
530 -- Product type
531 (TheType (SimpleDataCon cname fields)) ->
532 letE
533 [valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
534 (caseE
535 (varE _val)
536 [ matchConstructor
537 cname
538 (length fields)
539 (mkSerializeExprFields fields)
540 ])
541 -- Sum type
542 (MultiType cons) -> do
543 let lenCons = length cons
544 tagType = getTagType lenCons
545 caseE
546 (varE _val)
547 (map (\(tagVal, (SimpleDataCon cname fields)) ->
548 matchConstructor
549 cname
550 (length fields)
551 (doE [ bindS
552 (varP (mkName "i0"))
553 (mkSerializeExprTag tagType tagVal)
554 , noBindS (mkSerializeExprFields fields)
555 ]))
556 (zip [0 ..] cons))
558--------------------------------------------------------------------------------
559-- Main
560--------------------------------------------------------------------------------
562-- | A general function to derive Serialize instances where you can control
563-- which Constructors of the datatype to consider and what the Context for the
564-- 'Serialize' instance would be.
565--
566-- Consider the datatype:
567-- @
568-- data CustomDataType a b
569-- = CDTConstructor1
570-- | CDTConstructor2 Bool
571-- | CDTConstructor3 Bool b
572-- deriving (Show, Eq)
573-- @
574--
575-- Usage:
576-- @
577-- $(deriveSerializeInternal
578-- defaultConfig
579-- [AppT (ConT ''Serialize) (VarT (mkName "b"))]
580-- (AppT
581-- (AppT (ConT ''CustomDataType) (VarT (mkName "a")))
582-- (VarT (mkName "b")))
583-- [ DataCon 'CDTConstructor1 [] [] []
584-- , DataCon 'CDTConstructor2 [] [] [(Nothing, (ConT ''Bool))]
585-- , DataCon
586-- 'CDTConstructor3
587-- []
588-- []
589-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))]
590-- ])
591-- @
592deriveSerializeInternal ::
593 Config -> Cxt -> Type -> [DataCon] -> Q [Dec]
594deriveSerializeInternal (Config{..}) preds headTy cons = do
595 sizeOfMethod <- mkSizeOfExpr constructorTagAsString (typeOfType headTy cons)
596 peekMethod <-
597 mkDeserializeExpr constructorTagAsString headTy (typeOfType headTy cons)
598 pokeMethod <-
599 mkSerializeExpr constructorTagAsString (typeOfType headTy cons)
600 let methods =
601 -- INLINE on sizeOf actually worsens some benchmarks, and improves
602 -- none
603 [ PragmaD (InlineP 'size inlineSize FunLike AllPhases)
604 , FunD 'size [Clause [] (NormalB sizeOfMethod) []]
605 , PragmaD (InlineP 'deserialize inlineDeserialize FunLike AllPhases)
606 , FunD
607 'deserialize
608 [ Clause
609 (if isUnitType cons && not constructorTagAsString
610 then [VarP _initialOffset, WildP, WildP]
611 else [VarP _initialOffset, VarP _arr, VarP _endOffset])
612 (NormalB peekMethod)
613 []
614 ]
615 , PragmaD (InlineP 'serialize inlineSerialize FunLike AllPhases)
616 , FunD
617 'serialize
618 [ Clause
619 (if isUnitType cons && not constructorTagAsString
620 then [VarP _initialOffset, WildP, WildP]
621 else [VarP _initialOffset, VarP _arr, VarP _val])
622 (NormalB pokeMethod)
623 []
624 ]
625 ]
626 return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
628-- | Config to control how the 'Serialize' instance is generated.
629data Config =
630 Config
631 { unconstrained :: [String]
632 -- ^ Type variables that should not have the 'Serialize' constraint.
633 --
634 -- @
635 -- data CustomDataType a b c d = CustomDataType a c
636 -- @
637 --
638 -- @
639 -- conf = defaultConf {unconstrained = ["b", "d"]}
640 -- \$(deriveSerializeWith conf ''CustomDataType)
641 -- @
642 --
643 -- @
644 -- instance (Serialize a, Serialize c) => Serialize (CustomDataType a b c d) where
645 -- ...
646 -- @
647 , specializations :: [(String, Type)]
648 -- ^ Specialize the type variable with the given type. All type
649 -- variables listed here will not have the 'Serialize' constriant as
650 -- they are specialized.
651 --
652 -- @
653 -- data CustomDataType f a = CustomDataType (f a)
654 -- @
655 --
656 -- @
657 -- conf = defaultConf {specializations = [("f", ''Identity)]}
658 -- \$(deriveSerializeWith conf ''CustomDataType)
659 -- @
660 --
661 -- @
662 -- instance (Serialize a) => Serialize (CustomDataType Identity a) where
663 -- ...
664 -- @
665 --
666 -- @f@ is replaced with 'Identity' and becomes unconstrained.
667 , inlineSize :: Inline
668 -- ^ Inline value for 'size'. Default is Inline.
669 , inlineSerialize :: Inline
670 -- ^ Inline value for 'serialize'. Default is Inline.
671 , inlineDeserialize :: Inline
672 -- ^ Inline value for 'deserialize'. Default is Inline.
673 , constructorTagAsString :: Bool
674 -- ^ __Experimental__
675 --
676 -- If True, encode constructors using the constructor names as Latin-1
677 -- byte sequence.
678 , recordSyntaxWithHeader :: Bool
679 -- ^ __Experimental__
680 --
681 -- If True, encode the keys of the record as a header and then
682 -- serialize the data.
683 }
685defaultConfig :: Config
686defaultConfig =
687 Config
688 { unconstrained = []
689 , specializations = []
690 , inlineSize = Inline
691 , inlineSerialize = Inline
692 , inlineDeserialize = Inline
693 , constructorTagAsString = False
694 , recordSyntaxWithHeader = False
695 }
697-- | Similar to 'deriveSerialize,' but take a 'Config' to control how
698-- the instance is generated.
699--
700-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
701deriveSerializeWith :: Config -> Name -> Q [Dec]
702deriveSerializeWith conf@(Config {..}) name = do
703 dt <- reifyDataType name
704 let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
705 headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
706 cons = dtCons dt
707 deriveSerializeInternal conf preds headTy cons
709 where
710 allUnconstrainedTypeVars =
711 unconstrained ++ map fst specializations
712 filterOutVars vs =
713 map mkName
714 $ filter (not . flip elem allUnconstrainedTypeVars)
715 $ map nameBase vs
716 substituteVar v =
717 case lookup (nameBase v) specializations of
718 Nothing -> VarT v
719 Just ty -> ty
721 unboxPred ty =
722#if MIN_VERSION_template_haskell(2,10,0)
723 AppT (ConT ''Serialize) ty
724#else
725 ClassP ''Serialize [ty]
726#endif
728-- | Template haskell helper to create instances of 'Serialize' automatically.
729--
730-- Consider the datatype:
731-- @
732-- data CustomDataType a b c = ...
733-- @
734--
735-- Usage: @$(deriveSerialize ''CustomDataType)@
736--
737-- Note: All type variables automatcally get an "Serialize" constraint.
738-- The derived code will look like the following,
739-- @
740-- instance (Serialize a, Serialize b, Serialize c) => Serialize (CustomDataType a b c) where
741-- ...
742-- @
743--
744-- To control which type variables don't get the Serialize constraint, use
745-- 'deriveSerializeWith'.
746--
747-- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize
748-- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig
749deriveSerialize :: Name -> Q [Dec]
750deriveSerialize name = deriveSerializeWith defaultConfig name