diff --git a/core/src/Streamly/Internal/Data/Serialize.hs b/core/src/Streamly/Internal/Data/Serialize.hs index b6e971ba8..ae1268132 100644 --- a/core/src/Streamly/Internal/Data/Serialize.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/Serialize/TH.hs b/core/src/Streamly/Internal/Data/Serialize/TH.hs index 37df1622b..b858fdea6 100644 --- a/core/src/Streamly/Internal/Data/Serialize/TH.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/Unbox/TH.hs b/core/src/Streamly/Internal/Data/Unbox/TH.hs index af84bedb0..8a3572582 100644 --- a/core/src/Streamly/Internal/Data/Unbox/TH.hs +++ b/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. -- diff --git a/test/Streamly/Test/Data/Serialize.hs b/test/Streamly/Test/Data/Serialize.hs index d21168854..f0f22519a 100644 --- a/test/Streamly/Test/Data/Serialize.hs +++ b/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] diff --git a/test/Streamly/Test/Data/Unbox.hs b/test/Streamly/Test/Data/Unbox.hs index dac1279d1..6c6a8aaaf 100644 --- a/test/Streamly/Test/Data/Unbox.hs +++ b/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