Serialize.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- Required for Eq instance declaration of HigherOrderType
{-# LANGUAGE UndecidableInstances #-}

-- We are generating an orphan instance of Serialize for Identity.
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      : Streamly.Test.Data.Serialize
-- Copyright   : (c) 2022 Composewell technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC

module Streamly.Test.Data.Serialize (main) where

--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

import Data.Foldable (forM_)
import Data.Word (Word8)
import System.Random (randomRIO)
import Streamly.Internal.Data.MutByteArray (MutByteArray)
import GHC.Generics (Generic)
import Streamly.Data.MutByteArray (Serialize)
import Streamly.Test.Data.Serialize.TH (genDatatype)

import Data.Functor.Identity (Identity (..))

import qualified Streamly.Internal.Data.Array as Array
import qualified Streamly.Internal.Data.MutArray as MutArray
import qualified Streamly.Internal.Data.MutByteArray as Serialize

import qualified Streamly.Test.Data.Serialize.CompatV0 as CompatV0
import qualified Streamly.Test.Data.Serialize.CompatV1 as CompatV1

import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.Hspec as H

--------------------------------------------------------------------------------
-- Serialize configuration
--------------------------------------------------------------------------------

#ifdef ENABLE_constructorTagAsString
#define CONF_NAME "ENABLE_constructorTagAsString"
#define CONF (Serialize.encodeConstrNames True)
#else
#define CONF_NAME "DEFAULT"
#define CONF id
#endif

--------------------------------------------------------------------------------
-- Edge case types
--------------------------------------------------------------------------------

data Unit =
    Unit
    deriving (Eq, Show)
$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|])

data The =
    The Unit Int Char
    deriving (Eq, Show)
$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|])

--------------------------------------------------------------------------------
-- Generated types
--------------------------------------------------------------------------------

$(genDatatype "CustomDatatype" 15)
$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|])

--------------------------------------------------------------------------------
-- Types with functional parameters
--------------------------------------------------------------------------------

data HigherOrderType f =
    HigherOrderType
        { field0 :: f Int
        , field1 :: f Char
        }

instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where
    (==) a b = (field0 a == field0 b) && (field1 a == field1 b)

instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where
    show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a)

$(Serialize.deriveSerializeWith CONF
      [d|instance Serialize a => Serialize (Identity a)|])
$(Serialize.deriveSerializeWith CONF
      [d|instance Serialize (HigherOrderType Identity)|])

--------------------------------------------------------------------------------
-- Recursive type
--------------------------------------------------------------------------------

-- Recursive ADT
data BinTree a
  = Tree (BinTree a) (BinTree a)
  | Leaf a
  deriving (Show, Read, Eq, Generic)

$(Serialize.deriveSerializeWith
      CONF
      [d|instance Serialize a => Serialize (BinTree a)|])

-- XXX This may not terminate, or could become really large.
instance Arbitrary a => Arbitrary (BinTree a) where
  arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary]

-- Make a balanced tree of given level
mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a)
mkBinTree = go (generate arbitrary)

    where

    go r 0 = Leaf <$> r
    go r n = Tree <$> go r (n - 1) <*> go r (n - 1)

--------------------------------------------------------------------------------
-- Record syntax type
--------------------------------------------------------------------------------

upgradeRec :: (a -> b) -> CompatV0.Rec a -> CompatV1.Rec b
upgradeRec f val =
    CompatV1.Rec
        { CompatV1.initialField = CompatV0.initialField val
        , CompatV1.otherField = f (CompatV0.otherField val)
        , CompatV1.theLastField = CompatV0.theLastField val
        , CompatV1.aNewField = Nothing
        }

upgradeRiver :: CompatV0.River -> CompatV1.River
upgradeRiver = read . show

downgradeRec  :: (a -> b) -> CompatV1.Rec a -> CompatV0.Rec b
downgradeRec f val =
    CompatV0.Rec
        { CompatV0.initialField = CompatV1.initialField val
        , CompatV0.otherField = f (CompatV1.otherField val)
        , CompatV0.theLastField = CompatV1.theLastField val
        }

downgradeRiver :: CompatV1.River -> CompatV0.River
downgradeRiver = read . show

testCompatibility ::
       CompatV0.Rec (CompatV0.Rec CompatV0.River)
    -> CompatV1.Rec (CompatV1.Rec CompatV1.River)
    -> IO ()
testCompatibility v0 v1 = do
    let upgradedV0 = upgradeRec (upgradeRec upgradeRiver) v0
        downgradedV1 = downgradeRec (downgradeRec downgradeRiver) v1

    res <- poke v0
    peekAndVerify res upgradedV0

    res1 <- poke v1
    peekAndVerify res1 downgradedV1

--------------------------------------------------------------------------------
-- Test helpers
--------------------------------------------------------------------------------

poke ::
       forall a. Serialize.Serialize a
    => a
    -> IO (MutByteArray, Int, Int)
poke val = do
    let sz = Serialize.addSizeTo 0 val

    let excessSize = 100
    randomOff <- randomRIO (10, excessSize)
    -- Use a proper slice to test instead of the array directly. This will catch
    -- any hardcoded 0 offsets
    let arrSize = sz + excessSize
        serStartOff = randomOff
        serEndOff = randomOff + sz
    arr <- Serialize.new arrSize
    arr2 <- Serialize.new arrSize
    -- Re-initialize the array with random value
    forM_ [0..(arrSize - 1)] $ \i -> Serialize.pokeAt i arr2 (8 :: Word8)

    off1 <- Serialize.serializeAt serStartOff arr val
    off2 <- Serialize.serializeAt 0 arr2 val

    let slice1 = Array.Array arr serStartOff off1 :: Array.Array Word8
        slice2 = Array.Array arr2 0 off2 :: Array.Array Word8
    -- The serialized representation should be the same
    slice1 `shouldBe` slice2

    off1 `shouldBe` serEndOff
    pure (arr, serStartOff, serEndOff)

peekAndVerify ::
       forall a. (Eq a, Show a, Serialize.Serialize a)
    => (MutByteArray, Int, Int)
    -> a
    -> IO ()
peekAndVerify (arr, serStartOff, serEndOff) val = do
    (off2, val2) <- Serialize.deserializeAt serStartOff arr serEndOff
    val2 `shouldBe` val
    off2 `shouldBe` serEndOff
    let slice = Array.Array arr serStartOff serEndOff
    val `shouldBe` fst (Array.deserialize slice)
    clonedSlice <-
        fmap Array.unsafeFreeze $ MutArray.clone $ Array.unsafeThaw slice
    val `shouldBe` fst (Array.deserialize clonedSlice)

roundtrip
    :: forall a. (Eq a, Show a, Serialize.Serialize a)
    => a
    -> IO ()
roundtrip val = do

    -- For debugging large size generated by arbitrary
    -- let sz = Serialize.addSizeTo 0 val
    -- putStrLn $ "Size is: " ++ show sz

    val `shouldBe` fst (Array.deserialize (Array.serialize' val))

    res <- poke val
    peekAndVerify res val

testSerializeList
    :: forall a. (Eq a, Show a, Serialize.Serialize a)
    => Int
    -> a
    -> IO ()
testSerializeList sizeOfA val = do

    let sz = Serialize.addSizeTo 0 val

    sz `shouldBe` sizeOfA

    roundtrip val

--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------

testCases :: Spec
testCases = do

    it "Serialize [Int]"
        $ testSerializeList (8 + 4 * 8) ([1, 2, 3, 4] :: [Int])
    it "Serialize [[Int]]"
        $ testSerializeList
              (8 + 3 * 8 + 6 * 8)
              ([[1], [1, 2], [1, 2, 3]] :: [[Int]])

    describe "Edge Cases" $ do
        it "Unit" $ roundtrip Unit
        it "The" $ roundtrip $ The Unit 1 'a'

    it "HigherOrderType"
        $ roundtrip $ HigherOrderType (Identity 5) (Identity 'e')

    prop "Integer"
        $ \(x :: Integer) -> roundtrip x

    prop "([Integer], [Int])"
        $ \(x :: ([Integer], [Int])) -> roundtrip x

    prop "Array Int"
        $ \(x :: [Int]) -> roundtrip (Array.fromList x)

    prop "Compatible Record"
        $ \(a :: CompatV1.Rec (CompatV0.Rec CompatV1.River)) -> roundtrip a

    prop "Compatibility"
        $ \a b -> testCompatibility a b

    limitQC
        $ prop "CustomDatatype"
        $ \(x :: CustomDatatype) -> roundtrip x

    limitQC
        $ prop "[CustomDatatype]"
        $ \(x :: [CustomDatatype]) -> roundtrip x

    limitQC
        $ prop "BinTree"
        $ forAll (elements [1..15])
            (\(x :: Int) -> do
                (r :: BinTree Int) <- mkBinTree x
                roundtrip r
            )

    where

    limitQC = modifyMaxSize (const 50)

--------------------------------------------------------------------------------
-- Main function
--------------------------------------------------------------------------------

moduleName :: String
moduleName = "Data.Serialize." ++ CONF_NAME

main :: IO ()
main = hspec $ H.parallel $ describe moduleName testCases