git.iko.soy/streamly
on a11fe00 help sign in
streamly/test/Streamly/Test/Data/Serialize.hs
277 lines 8.6 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TemplateHaskell #-}
4-- Required for Eq instance declaration of HigherOrderType
5{-# LANGUAGE UndecidableInstances #-}
7-- We are generating an orphan instance of Serialize for Identity.
8{-# OPTIONS_GHC -fno-warn-orphans #-}
10-- |
11-- Module : Streamly.Test.Data.Serialize
12-- Copyright : (c) 2022 Composewell technologies
13-- License : BSD-3-Clause
14-- Maintainer : streamly@composewell.com
15-- Stability : experimental
16-- Portability : GHC
18module Streamly.Test.Data.Serialize (main) where
20--------------------------------------------------------------------------------
21-- Imports
22--------------------------------------------------------------------------------
24import System.Random (randomRIO)
25import Streamly.Internal.Data.Unbox (MutableByteArray, newBytes)
26import GHC.Generics (Generic)
27import Streamly.Data.Serialize (Serialize)
28import Streamly.Test.Data.Serialize.TH (genDatatype)
30import qualified Streamly.Internal.Data.Serialize.TH as Serialize
32import Data.Functor.Identity (Identity (..))
34import qualified Streamly.Internal.Data.Array as Array
35import qualified Streamly.Internal.Data.Serialize as Serialize
37import qualified Streamly.Test.Data.Serialize.CompatV0 as CompatV0
38import qualified Streamly.Test.Data.Serialize.CompatV1 as CompatV1
40import Test.Hspec.QuickCheck
41import Test.QuickCheck
42import Test.Hspec as H
44--------------------------------------------------------------------------------
45-- Serialize configuration
46--------------------------------------------------------------------------------
48#ifdef ENABLE_constructorTagAsString
49#define CONF_NAME "ENABLE_constructorTagAsString"
50#define CONF (Serialize.defaultConfig {Serialize.constructorTagAsString = True})
51#else
52#define CONF_NAME "DEFAULT"
53#define CONF Serialize.defaultConfig
54#endif
56--------------------------------------------------------------------------------
57-- Edge case types
58--------------------------------------------------------------------------------
60data Unit =
61 Unit
62 deriving (Eq, Show)
63$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|])
65data The =
66 The Unit Int Char
67 deriving (Eq, Show)
68$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|])
70--------------------------------------------------------------------------------
71-- Generated types
72--------------------------------------------------------------------------------
74$(genDatatype "CustomDatatype" 15)
75$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|])
77--------------------------------------------------------------------------------
78-- Types with functional parameters
79--------------------------------------------------------------------------------
81data HigherOrderType f =
82 HigherOrderType
83 { field0 :: f Int
84 , field1 :: f Char
85 }
87instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where
88 (==) a b = (field0 a == field0 b) && (field1 a == field1 b)
90instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
91 show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)
93$(Serialize.deriveSerializeWith CONF
94 [d|instance Serialize a => Serialize (Identity a)|])
95$(Serialize.deriveSerializeWith CONF
96 [d|instance Serialize (HigherOrderType Identity)|])
98--------------------------------------------------------------------------------
99-- Recursive type
100--------------------------------------------------------------------------------
102-- Recursive ADT
103data BinTree a
104 = Tree (BinTree a) (BinTree a)
105 | Leaf a
106 deriving (Show, Read, Eq, Generic)
108$(Serialize.deriveSerializeWith
109 CONF
110 [d|instance Serialize a => Serialize (BinTree a)|])
112instance Arbitrary a => Arbitrary (BinTree a) where
113 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
115--------------------------------------------------------------------------------
116-- Record syntax type
117--------------------------------------------------------------------------------
119upgradeRec :: (a -> b) -> CompatV0.Rec a -> CompatV1.Rec b
120upgradeRec f val =
121 CompatV1.Rec
122 { CompatV1.initialField = CompatV0.initialField val
123 , CompatV1.otherField = f (CompatV0.otherField val)
124 , CompatV1.theLastField = CompatV0.theLastField val
125 , CompatV1.aNewField = Nothing
126 }
128upgradeRiver :: CompatV0.River -> CompatV1.River
129upgradeRiver = read . show
131downgradeRec :: (a -> b) -> CompatV1.Rec a -> CompatV0.Rec b
132downgradeRec f val =
133 CompatV0.Rec
134 { CompatV0.initialField = CompatV1.initialField val
135 , CompatV0.otherField = f (CompatV1.otherField val)
136 , CompatV0.theLastField = CompatV1.theLastField val
137 }
139downgradeRiver :: CompatV1.River -> CompatV0.River
140downgradeRiver = read . show
142testCompatibility ::
143 CompatV0.Rec (CompatV0.Rec CompatV0.River)
144 -> CompatV1.Rec (CompatV1.Rec CompatV1.River)
145 -> IO ()
146testCompatibility v0 v1 = do
147 let upgradedV0 = upgradeRec (upgradeRec upgradeRiver) v0
148 downgradedV1 = downgradeRec (downgradeRec downgradeRiver) v1
150 res <- poke v0
151 peekAndVerify res upgradedV0
153 res1 <- poke v1
154 peekAndVerify res1 downgradedV1
156--------------------------------------------------------------------------------
157-- Test helpers
158--------------------------------------------------------------------------------
160poke ::
161 forall a. Serialize.Serialize a
162 => a
163 -> IO (MutableByteArray, Int, Int)
164poke val = do
165 let sz = Serialize.size 0 val
167 let excessSize = 100
168 randomOff <- randomRIO (10, excessSize)
169 -- Use a proper slice to test instead of the array directly. This will catch
170 -- any hardcoded 0 offsets
171 let arrSize = sz + excessSize
172 serStartOff = randomOff
173 serEndOff = randomOff + sz
174 arr <- newBytes arrSize
176 off1 <- Serialize.serialize serStartOff arr val
177 off1 `shouldBe` serEndOff
178 pure (arr, serStartOff, serEndOff)
180peekAndVerify ::
181 forall a. (Eq a, Show a, Serialize.Serialize a)
182 => (MutableByteArray, Int, Int)
183 -> a
184 -> IO ()
185peekAndVerify (arr, serStartOff, serEndOff) val = do
186 (off2, val2) <- Serialize.deserialize serStartOff arr serEndOff
187 val2 `shouldBe` val
188 off2 `shouldBe` serEndOff
189 let slice = Array.Array arr serStartOff serEndOff
190 val `shouldBe` Serialize.decode slice
191 clonedSlice <- Array.clone slice
192 val `shouldBe` Serialize.decode clonedSlice
194roundtrip
195 :: forall a. (Eq a, Show a, Serialize.Serialize a)
196 => a
197 -> IO ()
198roundtrip val = do
200 val `shouldBe` Serialize.decode (Serialize.encode val)
202 res <- poke val
203 peekAndVerify res val
205testSerializeList
206 :: forall a. (Eq a, Show a, Serialize.Serialize a)
207 => Int
208 -> a
209 -> IO ()
210testSerializeList sizeOfA val = do
212 let sz = Serialize.size 0 val
214 sz `shouldBe` sizeOfA
216 roundtrip val
218--------------------------------------------------------------------------------
219-- Tests
220--------------------------------------------------------------------------------
222testCases :: Spec
223testCases = do
225 it "Serialize [Int]"
226 $ testSerializeList (8 + 4 * 8) ([1, 2, 3, 4] :: [Int])
227 it "Serialize [[Int]]"
228 $ testSerializeList
229 (8 + 3 * 8 + 6 * 8)
230 ([[1], [1, 2], [1, 2, 3]] :: [[Int]])
232 describe "Edge Cases" $ do
233 it "Unit" $ roundtrip Unit
234 it "The" $ roundtrip $ The Unit 1 'a'
236 it "HigherOrderType"
237 $ roundtrip $ HigherOrderType (Identity 5) (Identity 'e')
239 prop "Integer"
240 $ \(x :: Integer) -> roundtrip x
242 prop "([Integer], [Int])"
243 $ \(x :: ([Integer], [Int])) -> roundtrip x
245 prop "Array Int"
246 $ \(x :: [Int]) -> roundtrip (Array.fromList x)
248 prop "Compatible Record"
249 $ \(a :: CompatV1.Rec (CompatV0.Rec CompatV1.River)) -> roundtrip a
251 prop "Compatibility"
252 $ \a b -> testCompatibility a b
254 limitQC
255 $ prop "CustomDatatype"
256 $ \(x :: CustomDatatype) -> roundtrip x
258 limitQC
259 $ prop "[CustomDatatype]"
260 $ \(x :: [CustomDatatype]) -> roundtrip x
262 limitQC
263 $ prop "BinTree" $ \(x :: BinTree Int) -> roundtrip x
265 where
267 limitQC = modifyMaxSize (const 50)
269--------------------------------------------------------------------------------
270-- Main function
271--------------------------------------------------------------------------------
273moduleName :: String
274moduleName = "Data.Serialize." ++ CONF_NAME
276main :: IO ()
277main = hspec $ H.parallel $ describe moduleName testCases