git.iko.soy/streamly
on 5d096df help sign in
streamly/test/Streamly/Test/Data/Serialize.hs
306 lines 9.5 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 Data.Foldable (forM_)
25import Data.Word (Word8)
26import System.Random (randomRIO)
27import Streamly.Internal.Data.MutByteArray (MutByteArray)
28import GHC.Generics (Generic)
29import Streamly.Data.MutByteArray (Serialize)
30import Streamly.Test.Data.Serialize.TH (genDatatype)
32import Data.Functor.Identity (Identity (..))
34import qualified Streamly.Internal.Data.Array as Array
35import qualified Streamly.Internal.Data.MutByteArray 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.encodeConstrNames True)
51#else
52#define CONF_NAME "DEFAULT"
53#define CONF id
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)|])
112-- XXX This may not terminate, or could become really large.
113instance Arbitrary a => Arbitrary (BinTree a) where
114 arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]
116-- Make a balanced tree of given level
117mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a)
118mkBinTree = go (generate arbitrary)
120 where
122 go r 0 = Leaf <$> r
123 go r n = Tree <$> go r (n - 1) <*> go r (n - 1)
125--------------------------------------------------------------------------------
126-- Record syntax type
127--------------------------------------------------------------------------------
129upgradeRec :: (a -> b) -> CompatV0.Rec a -> CompatV1.Rec b
130upgradeRec f val =
131 CompatV1.Rec
132 { CompatV1.initialField = CompatV0.initialField val
133 , CompatV1.otherField = f (CompatV0.otherField val)
134 , CompatV1.theLastField = CompatV0.theLastField val
135 , CompatV1.aNewField = Nothing
136 }
138upgradeRiver :: CompatV0.River -> CompatV1.River
139upgradeRiver = read . show
141downgradeRec :: (a -> b) -> CompatV1.Rec a -> CompatV0.Rec b
142downgradeRec f val =
143 CompatV0.Rec
144 { CompatV0.initialField = CompatV1.initialField val
145 , CompatV0.otherField = f (CompatV1.otherField val)
146 , CompatV0.theLastField = CompatV1.theLastField val
147 }
149downgradeRiver :: CompatV1.River -> CompatV0.River
150downgradeRiver = read . show
152testCompatibility ::
153 CompatV0.Rec (CompatV0.Rec CompatV0.River)
154 -> CompatV1.Rec (CompatV1.Rec CompatV1.River)
155 -> IO ()
156testCompatibility v0 v1 = do
157 let upgradedV0 = upgradeRec (upgradeRec upgradeRiver) v0
158 downgradedV1 = downgradeRec (downgradeRec downgradeRiver) v1
160 res <- poke v0
161 peekAndVerify res upgradedV0
163 res1 <- poke v1
164 peekAndVerify res1 downgradedV1
166--------------------------------------------------------------------------------
167-- Test helpers
168--------------------------------------------------------------------------------
170poke ::
171 forall a. Serialize.Serialize a
172 => a
173 -> IO (MutByteArray, Int, Int)
174poke val = do
175 let sz = Serialize.addSizeTo 0 val
177 let excessSize = 100
178 randomOff <- randomRIO (10, excessSize)
179 -- Use a proper slice to test instead of the array directly. This will catch
180 -- any hardcoded 0 offsets
181 let arrSize = sz + excessSize
182 serStartOff = randomOff
183 serEndOff = randomOff + sz
184 arr <- Serialize.new arrSize
185 arr2 <- Serialize.new arrSize
186 -- Re-initialize the array with random value
187 forM_ [0..(arrSize - 1)] $ \i -> Serialize.pokeAt i arr2 (8 :: Word8)
189 off1 <- Serialize.serializeAt serStartOff arr val
190 off2 <- Serialize.serializeAt 0 arr2 val
192 let slice1 = Array.Array arr serStartOff off1 :: Array.Array Word8
193 slice2 = Array.Array arr2 0 off2 :: Array.Array Word8
194 -- The serialized representation should be the same
195 slice1 `shouldBe` slice2
197 off1 `shouldBe` serEndOff
198 pure (arr, serStartOff, serEndOff)
200peekAndVerify ::
201 forall a. (Eq a, Show a, Serialize.Serialize a)
202 => (MutByteArray, Int, Int)
203 -> a
204 -> IO ()
205peekAndVerify (arr, serStartOff, serEndOff) val = do
206 (off2, val2) <- Serialize.deserializeAt serStartOff arr serEndOff
207 val2 `shouldBe` val
208 off2 `shouldBe` serEndOff
209 let slice = Array.Array arr serStartOff serEndOff
210 val `shouldBe` Array.deserialize slice
211 clonedSlice <- Array.clone slice
212 val `shouldBe` Array.deserialize clonedSlice
214roundtrip
215 :: forall a. (Eq a, Show a, Serialize.Serialize a)
216 => a
217 -> IO ()
218roundtrip val = do
220 -- For debugging large size generated by arbitrary
221 -- let sz = Serialize.addSizeTo 0 val
222 -- putStrLn $ "Size is: " ++ show sz
224 val `shouldBe` Array.deserialize (Array.pinnedSerialize val)
226 res <- poke val
227 peekAndVerify res val
229testSerializeList
230 :: forall a. (Eq a, Show a, Serialize.Serialize a)
231 => Int
232 -> a
233 -> IO ()
234testSerializeList sizeOfA val = do
236 let sz = Serialize.addSizeTo 0 val
238 sz `shouldBe` sizeOfA
240 roundtrip val
242--------------------------------------------------------------------------------
243-- Tests
244--------------------------------------------------------------------------------
246testCases :: Spec
247testCases = do
249 it "Serialize [Int]"
250 $ testSerializeList (8 + 4 * 8) ([1, 2, 3, 4] :: [Int])
251 it "Serialize [[Int]]"
252 $ testSerializeList
253 (8 + 3 * 8 + 6 * 8)
254 ([[1], [1, 2], [1, 2, 3]] :: [[Int]])
256 describe "Edge Cases" $ do
257 it "Unit" $ roundtrip Unit
258 it "The" $ roundtrip $ The Unit 1 'a'
260 it "HigherOrderType"
261 $ roundtrip $ HigherOrderType (Identity 5) (Identity 'e')
263 prop "Integer"
264 $ \(x :: Integer) -> roundtrip x
266 prop "([Integer], [Int])"
267 $ \(x :: ([Integer], [Int])) -> roundtrip x
269 prop "Array Int"
270 $ \(x :: [Int]) -> roundtrip (Array.fromList x)
272 prop "Compatible Record"
273 $ \(a :: CompatV1.Rec (CompatV0.Rec CompatV1.River)) -> roundtrip a
275 prop "Compatibility"
276 $ \a b -> testCompatibility a b
278 limitQC
279 $ prop "CustomDatatype"
280 $ \(x :: CustomDatatype) -> roundtrip x
282 limitQC
283 $ prop "[CustomDatatype]"
284 $ \(x :: [CustomDatatype]) -> roundtrip x
286 limitQC
287 $ prop "BinTree"
288 $ forAll (elements [1..15])
289 (\(x :: Int) -> do
290 (r :: BinTree Int) <- mkBinTree x
291 roundtrip r
292 )
294 where
296 limitQC = modifyMaxSize (const 50)
298--------------------------------------------------------------------------------
299-- Main function
300--------------------------------------------------------------------------------
302moduleName :: String
303moduleName = "Data.Serialize." ++ CONF_NAME
305main :: IO ()
306main = hspec $ H.parallel $ describe moduleName testCases