module Main where
import Test.Sandwich
import Control.Monad.IO.Class (liftIO)
import Data.Int (Int64)
import qualified Data.ByteString as BS
import qualified Data.HashMap.Lazy as H
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.PackStream (pack, unpack)
import Data.PackStream.Ps (Ps(..))
import Data.PackStream.Integer (ToPSInteger(..))
import Test.QuickCheck (Arbitrary(..), Gen, oneof,
quickCheckResult, isSuccess,
withMaxSuccess, chooseInt)
-- = Helpers
-- | Like 'listOf' but keeps the size small to avoid deep nesting.
listOfSmall :: Gen a -> Gen [a]
listOfSmall g = do
n <- chooseInt (0, 3)
sequence (replicate n g)
-- | Generate a finite (non-NaN, non-Infinite) Double.
arbitraryFiniteDouble :: Gen Double
arbitraryFiniteDouble = do
d <- arbitrary
pure $ if isNaN d || isInfinite d then 0.0 else d
-- | Arbitrary Ps value (no PsStructure — tag namespace is application-defined).
instance Arbitrary Ps where
arbitrary = oneof
[ pure PsNull
, PsBoolean <$> arbitrary
, PsInteger . toPSInteger <$> (arbitrary :: Gen Int64)
, PsFloat <$> arbitraryFiniteDouble
, PsString . T.pack <$> arbitrary
, PsBytes . BS.pack <$> arbitrary
, PsList . V.fromList <$> listOfSmall arbitrary
, PsDictionary . H.fromList <$> listOfSmall ((,) <$> (T.pack <$> arbitrary) <*> arbitrary)
]
-- | Assert a QuickCheck result, failing the sandwich test on property failure.
assertQC r
| isSuccess r = pure ()
| otherwise = expectationFailure $ "QuickCheck: " <> show r
-- = Unit tests: PackStream round-trips
packstreamRoundTripTests :: TopSpec
packstreamRoundTripTests = describe "PackStream round-trips" $ do
it "round-trips PsNull" $ do
unpack (pack PsNull) `shouldBe` Right PsNull
it "round-trips PsBoolean True" $ do
unpack (pack (PsBoolean True)) `shouldBe` Right (PsBoolean True)
it "round-trips PsBoolean False" $ do
unpack (pack (PsBoolean False)) `shouldBe` Right (PsBoolean False)
it "round-trips PsInteger small" $ do
unpack (pack (PsInteger 42)) `shouldBe` Right (PsInteger 42)
it "round-trips PsInteger negative" $ do
unpack (pack (PsInteger (-100))) `shouldBe` Right (PsInteger (-100))
it "round-trips PsInteger zero" $ do
unpack (pack (PsInteger 0)) `shouldBe` Right (PsInteger 0)
it "round-trips PsFloat" $ do
unpack (pack (PsFloat 3.14)) `shouldBe` Right (PsFloat 3.14)
it "round-trips PsString" $ do
unpack (pack (PsString "hello world")) `shouldBe` Right (PsString "hello world")
it "round-trips PsString empty" $ do
unpack (pack (PsString "")) `shouldBe` Right (PsString "")
it "round-trips PsString unicode" $ do
unpack (pack (PsString "\x1F600 emoji")) `shouldBe` Right (PsString "\x1F600 emoji")
it "round-trips PsList empty" $ do
unpack (pack (PsList V.empty)) `shouldBe` Right (PsList V.empty)
it "round-trips PsList with values" $ do
let v = PsList $ V.fromList [PsInteger 1, PsString "two", PsBoolean True]
unpack (pack v) `shouldBe` Right v
it "round-trips PsDictionary empty" $ do
unpack (pack (PsDictionary H.empty)) `shouldBe` Right (PsDictionary H.empty)
it "round-trips PsDictionary with entries" $ do
let d = PsDictionary $ H.fromList [("key", PsString "value"), ("num", PsInteger 42)]
unpack (pack d) `shouldBe` Right d
it "round-trips nested structures" $ do
let nested = PsList $ V.fromList
[ PsDictionary $ H.fromList [("a", PsInteger 1)]
, PsList $ V.fromList [PsNull, PsBoolean False]
]
unpack (pack nested) `shouldBe` Right nested
-- Integer range boundary tests
it "round-trips PsInteger tiny positive (127)" $ do
unpack (pack (PsInteger 127)) `shouldBe` Right (PsInteger 127)
it "round-trips PsInteger tiny negative (-16)" $ do
unpack (pack (PsInteger (-16))) `shouldBe` Right (PsInteger (-16))
it "round-trips PsInteger INT_8 range (128)" $ do
unpack (pack (PsInteger 128)) `shouldBe` Right (PsInteger 128)
it "round-trips PsInteger INT_8 range (-128)" $ do
unpack (pack (PsInteger (-128))) `shouldBe` Right (PsInteger (-128))
it "round-trips PsInteger INT_16 range (1000)" $ do
unpack (pack (PsInteger 1000)) `shouldBe` Right (PsInteger 1000)
it "round-trips PsInteger INT_32 range (100000)" $ do
unpack (pack (PsInteger 100000)) `shouldBe` Right (PsInteger 100000)
it "round-trips PsInteger INT_64 range (maxBound)" $ do
let big = PsInteger 9223372036854775807
unpack (pack big) `shouldBe` Right big
it "round-trips PsInteger INT_64 range (minBound)" $ do
let small = PsInteger (-9223372036854775808)
unpack (pack small) `shouldBe` Right small
-- Bytes tests
it "round-trips PsBytes empty" $ do
unpack (pack (PsBytes "")) `shouldBe` Right (PsBytes "")
it "round-trips PsBytes with data" $ do
let bs = PsBytes "\x00\x01\x02\xFF"
unpack (pack bs) `shouldBe` Right bs
-- Structure tests
it "round-trips PsStructure empty fields" $ do
let s = PsStructure 0x01 V.empty
unpack (pack s) `shouldBe` Right s
it "round-trips PsStructure with one field" $ do
let s = PsStructure 0x01 $ V.singleton $ PsDictionary $ H.fromList
[("user_agent", PsString "bolty/2.0"), ("scheme", PsString "none")]
unpack (pack s) `shouldBe` Right s
it "round-trips PsStructure with multiple fields" $ do
let s = PsStructure 0x4E $ V.fromList
[ PsInteger 1
, PsList (V.fromList [PsString "Person"])
, PsDictionary (H.fromList [("name", PsString "Alice")])
, PsString "4:abc:1"
]
unpack (pack s) `shouldBe` Right s
-- Larger collection tests
it "round-trips PsList with 16 elements (LIST_8)" $ do
let v = PsList $ V.fromList [PsInteger (fromIntegral i) | i <- [0..15 :: Int]]
unpack (pack v) `shouldBe` Right v
it "round-trips Text via PackStream class" $ do
let txt = "hello" :: T.Text
unpack (pack txt) `shouldBe` Right (PsString txt)
it "round-trips Bool via PackStream class" $ do
unpack (pack True) `shouldBe` Right (PsBoolean True)
-- = QuickCheck property tests
quickcheckTests :: TopSpec
quickcheckTests = describe "QuickCheck: pack/unpack round-trip" $ do
it "Ps round-trips through pack/unpack (1000 cases)" $ do
r <- liftIO $ quickCheckResult $ withMaxSuccess 1000 $ \(ps :: Ps) ->
unpack (pack ps) == Right ps
assertQC r
-- = Main
main :: IO ()
main = runSandwichWithCommandLineArgs defaultOptions $ do
packstreamRoundTripTests
quickcheckTests