Use more expressive notation for deriveSerializeWith

core/src/Streamly/Internal/Data/Serialize.hs

@@ -61,8 +61,8 @@ import Streamly.Internal.Data.Serialize.Type
 $(Serialize.deriveSerialize ''Maybe)
 $(Serialize.deriveSerialize ''Either)
 $(Serialize.deriveSerializeWith
-      (Serialize.defaultConfig {Serialize.unconstrained = ["t"]})
-      ''Proxy)
+      Serialize.defaultConfig
+      [d|instance Serialize (Proxy a)|])
 
 --------------------------------------------------------------------------------
 -- Integer

core/src/Streamly/Internal/Data/Serialize/TH.hs

@@ -30,7 +30,6 @@ import Streamly.Internal.Data.Unbox.TH
     ( DataCon(..)
     , DataType(..)
     , appsT
-    , plainInstanceD
     , reifyDataType
     )
 
@@ -381,44 +380,47 @@ mkSerializeDec (Config {..}) headTy cons = do
 --       ])
 -- @
 deriveSerializeInternal ::
-       Config -> Cxt -> Type -> [DataCon] -> Q [Dec]
-deriveSerializeInternal conf preds headTy cons = do
+       Config -> Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
+deriveSerializeInternal conf headTy cons next = do
     sizeDec <- mkSizeDec conf headTy cons
     peekDec <- mkDeserializeDec conf headTy cons
     pokeDec <- mkSerializeDec conf headTy cons
     let methods = concat [sizeDec, peekDec, pokeDec]
-    return [plainInstanceD preds (AppT (ConT ''Serialize) headTy) methods]
+    next methods
 
--- | Similar to 'deriveSerialize,' but take a 'Config' to control how
--- the instance is generated.
+-- | Similar to 'deriveSerialize' but take a 'Config' to control how the
+-- instance is generated.
 --
--- Usage: @$(deriveSerializeWith config ''CustomDataType)@
-deriveSerializeWith :: Config -> Name -> Q [Dec]
-deriveSerializeWith conf@(Config {..}) name = do
-    dt <- reifyDataType name
-    let preds = map (unboxPred . VarT) (filterOutVars (dtTvs dt))
-        headTy = appsT (ConT name) (map substituteVar (dtTvs dt))
-        cons = dtCons dt
-    deriveSerializeInternal conf preds headTy cons
+-- Usage:
+-- @
+-- $(deriveSerializeWith
+--       config
+--       [d|instance Serialize a => Serialize (Maybe a)|])
+-- @
+deriveSerializeWith :: Config -> Q [Dec] -> Q [Dec]
+deriveSerializeWith conf mDecs = do
+    dec <- mDecs
+    case dec of
+        [inst@(InstanceD _ _ headTy [])] -> do
+            dt <- reifyDataType (getMainTypeName headTy)
+            let cons = dtCons dt
+            deriveSerializeInternal conf headTy cons (next inst)
+        _ -> errorUnsupported
+  where
 
-    where
-    allUnconstrainedTypeVars =
-        unconstrained ++ map fst specializations
-    filterOutVars vs =
-        map mkName
-            $ filter (not . flip elem allUnconstrainedTypeVars)
-            $ map nameBase vs
-    substituteVar v =
-        case lookup (nameBase v) specializations of
-            Nothing -> VarT v
-            Just ty -> ty
+    next (InstanceD mo preds headTy []) methods =
+        pure [InstanceD mo preds headTy methods]
+    next _ _ = errorUnsupported
+
+    getMainTypeName = go . unwrap
+
+    unwrap (AppT (ConT _) r) = r
+    unwrap _ = error "getMainTypeName.unwrap: Undefined instance declaration."
+
+    go (ConT nm) = nm
+    go (AppT l _) = go l
+    go _ = error "getMainTypeName.go: Undefined instance declaration."
 
-    unboxPred ty =
-#if MIN_VERSION_template_haskell(2,10,0)
-        AppT (ConT ''Serialize) ty
-#else
-        ClassP ''Serialize [ty]
-#endif
 
 -- | Template haskell helper to create instances of 'Serialize' automatically.
 --
@@ -438,8 +440,18 @@ deriveSerializeWith conf@(Config {..}) name = do
 --
 -- To control which type variables don't get the Serialize constraint, use
 -- 'deriveSerializeWith'.
---
--- >>> import qualified Streamly.Internal.Data.Serialize.TH as Serialize
--- >>> deriveSerialize = Serialize.deriveSerializeWith Serialize.defaultConfig
 deriveSerialize :: Name -> Q [Dec]
-deriveSerialize name = deriveSerializeWith defaultConfig name
+deriveSerialize name = do
+    dt <- reifyDataType name
+    let preds = map (unboxPred . VarT) (dtTvs dt)
+        headTy = appsT (ConT name) (map VarT (dtTvs dt))
+        cons = dtCons dt
+    deriveSerializeInternal defaultConfig headTy cons (next preds headTy)
+
+
+    where
+
+    next preds headTy methods =
+        pure [InstanceD Nothing preds (AppT (ConT ''Serialize) headTy) methods]
+
+    unboxPred ty = AppT (ConT ''Serialize) ty

core/src/Streamly/Internal/Data/Unbox/TH.hs

@@ -17,7 +17,6 @@ module Streamly.Internal.Data.Unbox.TH
     , DataType(..)
     , reifyDataType
     , appsT
-    , plainInstanceD
     ) where
 
 --------------------------------------------------------------------------------
@@ -35,6 +34,8 @@ import Streamly.Internal.Data.Unbox
 -- th-utilities
 --------------------------------------------------------------------------------
 
+-- Note: We don't support template-haskell < 2.14 (GHC < 8.6)
+
 -- The following are copied to remove the dependency on th-utilities.
 -- The code has been copied from th-abstraction and th-utilities.
 
@@ -72,16 +73,6 @@ appsT :: Type -> [Type] -> Type
 appsT x [] = x
 appsT x (y:xs) = appsT (AppT x y) xs
 
--- | Utility to conveniently handle change to 'InstanceD' API in
--- template-haskell-2.11.0
-plainInstanceD :: Cxt -> Type -> [Dec] -> Dec
-plainInstanceD =
-#if MIN_VERSION_template_haskell(2,11,0)
-    InstanceD Nothing
-#else
-    InstanceD
-#endif
-
 -- | Simplified info about a 'DataD'. Omits deriving, strictness,
 -- kind info, and whether it's @data@ or @newtype@.
 data DataType = DataType
@@ -437,7 +428,7 @@ deriveUnboxInternal preds headTy cons = do
                         []
                   ]
             ]
-    return [plainInstanceD preds (AppT (ConT ''Unbox) headTy) methods]
+    return [InstanceD Nothing preds (AppT (ConT ''Unbox) headTy) methods]
 
 -- | Template haskell helper to create instances of 'Unbox' automatically.
 --

test/Streamly/Test/Data/Serialize.hs

@@ -24,18 +24,22 @@ module Streamly.Test.Data.Serialize (main) where
 import System.Random (randomRIO)
 import Streamly.Internal.Data.Unbox (MutableByteArray, newBytes)
 import GHC.Generics (Generic)
+import Streamly.Data.Serialize (Serialize)
 import Streamly.Test.Data.Serialize.TH (genDatatype)
+
 import qualified Streamly.Internal.Data.Serialize.TH as Serialize
-    ( Config(..)
+    ( deriveSerializeWith
+#ifdef ENABLE_constructorTagAsString
+    , Config(..)
+#endif
     , defaultConfig
-    , deriveSerializeWith
     )
+
 import Data.Functor.Identity (Identity (..))
 
 import qualified Streamly.Internal.Data.Array as Array
 import qualified Streamly.Internal.Data.Serialize as Serialize
 
-import Language.Haskell.TH
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Test.Hspec as H
@@ -59,19 +63,19 @@ import Test.Hspec as H
 data Unit =
     Unit
     deriving (Eq, Show)
-$(Serialize.deriveSerializeWith CONF ''Unit)
+$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|])
 
 data The =
     The Unit Int Char
     deriving (Eq, Show)
-$(Serialize.deriveSerializeWith CONF ''The)
+$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|])
 
 --------------------------------------------------------------------------------
 -- Generated types
 --------------------------------------------------------------------------------
 
 $(genDatatype "CustomDatatype" 15)
-$(Serialize.deriveSerializeWith CONF ''CustomDatatype)
+$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|])
 
 --------------------------------------------------------------------------------
 -- Types with functional parameters
@@ -89,11 +93,10 @@ instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where
 instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
     show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)
 
-$(Serialize.deriveSerializeWith CONF ''Identity)
-$(Serialize.deriveSerializeWith
-      (CONF
-           {Serialize.specializations = [("f", ConT ''Identity)]})
-      ''HigherOrderType)
+$(Serialize.deriveSerializeWith CONF
+      [d|instance Serialize a => Serialize (Identity a)|])
+$(Serialize.deriveSerializeWith CONF
+      [d|instance Serialize (HigherOrderType Identity)|])
 
 --------------------------------------------------------------------------------
 -- Recursive type
@@ -105,7 +108,9 @@ data BinTree a
   | Leaf a
   deriving (Show, Read, Eq, Generic)
 
-$(Serialize.deriveSerializeWith CONF ''BinTree)
+$(Serialize.deriveSerializeWith
+      CONF
+      [d|instance Serialize a => Serialize (BinTree a)|])
 
 instance Arbitrary a => Arbitrary (BinTree a) where
   arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]

test/Streamly/Test/Data/Unbox.hs

@@ -193,8 +193,8 @@ deriving instance Generic (Ratio Int)
 $(Serialize.deriveSerialize ''Complex)
 $(Serialize.deriveSerialize ''Ratio)
 $(Serialize.deriveSerializeWith
-      (Serialize.defaultConfig {Serialize.unconstrained = ["b"]})
-      ''Const)
+      Serialize.defaultConfig
+      [d|instance Serialize a => Serialize (Const a b)|])
 $(Serialize.deriveSerialize ''Identity)
 #endif