@@ -30,7 +30,6 @@ import Streamly.Internal.Data.Unbox.TH
3030 ( DataCon(..)
3131 , DataType(..)
3232 , appsT
33− , plainInstanceD
3433 , reifyDataType
3534 )
3635
@@ -381,44 +380,47 @@ mkSerializeDec (Config {..}) headTy cons = do
381380-- ])
382381-- @
383382deriveSerializeInternal ::
384− Config -> Cxt -> Type -> [DataCon] -> Q [Dec]
385−deriveSerializeInternal conf preds headTy cons = do
383+ Config -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
384+deriveSerializeInternal conf headTy cons next = do
386385 sizeDec <- mkSizeDec conf headTy cons
387386 peekDec <- mkDeserializeDec conf headTy cons
388387 pokeDec <- mkSerializeDec conf headTy cons
389388 let methods = concat [sizeDec, peekDec, pokeDec]
390− return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
389+ next methods
391390
392−-- | Similar to 'deriveSerialize,' but take a 'Config' to control how
393−-- the instance is generated.
391+-- | Similar to 'deriveSerialize' but take a 'Config' to control how the
392+-- instance is generated.
394393--
395−-- Usage: @$(deriveSerializeWith config ''CustomDataType)@
396−deriveSerializeWith :: Config -> Name -> Q [Dec]
397−deriveSerializeWith conf@(Config {..}) name = do
398− dt <- reifyDataType name
399− let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
400− headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
401− cons = dtCons dt
402− deriveSerializeInternal conf preds headTy cons
394+-- Usage:
395+-- @
396+-- $(deriveSerializeWith
397+-- config
398+-- [d|instance Serialize a => Serialize (Maybe a)|])
399+-- @
400+deriveSerializeWith :: Config -> Q [Dec] -> Q [Dec]
401+deriveSerializeWith conf mDecs = do
402+ dec <- mDecs
403+ case dec of
404+ [inst@(InstanceD _ _ headTy [])] -> do
405+ dt <- reifyDataType (getMainTypeName headTy)
406+ let cons = dtCons dt
407+ deriveSerializeInternal conf headTy cons (next inst)
408+ _ -> errorUnsupported
409+ where
410+
411+ next (InstanceD mo preds headTy []) methods =
412+ pure [InstanceD mo preds headTy methods]
413+ next _ _ = errorUnsupported
414+
415+ getMainTypeName = go . unwrap
416+
417+ unwrap (AppT (ConT _) r) = r
418+ unwrap _ = error "getMainTypeName.unwrap: Undefined instance declaration."
419+
420+ go (ConT nm) = nm
421+ go (AppT l _) = go l
422+ go _ = error "getMainTypeName.go: Undefined instance declaration."
403423
404− where
405− allUnconstrainedTypeVars =
406− unconstrained ++ map fst specializations
407− filterOutVars vs =
408− map mkName
409− $ filter (not . flip elem allUnconstrainedTypeVars)
410− $ map nameBase vs
411− substituteVar v =
412− case lookup (nameBase v) specializations of
413− Nothing -> VarT v
414− Just ty -> ty
415−
416− unboxPred ty =
417−#if MIN_VERSION_template_haskell(2,10,0)
418− AppT (ConT ''Serialize) ty
419−#else
420− ClassP ''Serialize [ty]
421−#endif
422424
423425-- | Template haskell helper to create instances of 'Serialize' automatically.
424426--
@@ -438,8 +440,18 @@ deriveSerializeWith conf@(Config {..}) name = do
438440--
439441-- To control which type variables don't get the Serialize constraint, use
440442-- 'deriveSerializeWith'.
441−--
442−-- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize
443−-- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig
444443deriveSerialize :: Name -> Q [Dec]
445−deriveSerialize name = deriveSerializeWith defaultConfig name
444+deriveSerialize name = do
445+ dt <- reifyDataType name
446+ let preds = map (unboxPred . VarT) (dtTvs dt)
447+ headTy = appsT (ConT name) (map VarT (dtTvs dt))
448+ cons = dtCons dt
449+ deriveSerializeInternal defaultConfig headTy cons (next preds headTy)
450+
451+
452+ where
453+
454+ next preds headTy methods =
455+ pure [InstanceD Nothing preds (AppT (ConT ''Serialize) headTy) methods]
456+
457+ unboxPred ty = AppT (ConT ''Serialize) ty