Storable.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}

module Spec.Storable (tests) where

import Data.Proxy (Proxy(..))
import Data.Vector.Storable qualified as Storable
import Foreign (Storable)
import Geomancy
import Hedgehog
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testPropertyNamed)

import Geomancy.DVec3 qualified
import Geomancy.IVec3 qualified
import Geomancy.UVec3 qualified
import Geomancy.Vec3 qualified

import Support.Gen (forAllDTransform, forAllTransform, genDVec4, genVec4)
import Support.Property (pattern PROP_TESTS, layout140)

tests :: TestTree
tests = testGroup "Storable"
  [ testPropertyNamed "vec4_strict_reads" "prop_vec4_strict_reads" prop_vec4_strict_reads
  , testPropertyNamed "dvec4_strict_reads" "prop_dvec4_strict_reads" prop_dvec4_strict_reads
  , testPropertyNamed "mat4_strict_reads" "prop_mat4_strict_reads" prop_mat4_strict_reads
  , testPropertyNamed "dmat4_strict_reads" "prop_dmat4_strict_reads" prop_dmat4_strict_reads
  , testPropertyNamed "block_layout" "prop_block_layout" prop_block_layout
  ]

prop_vec4_strict_reads :: Property
prop_vec4_strict_reads = withTests PROP_TESTS $ property do
  a <- forAll genVec4
  b <- forAll genVec4
  strictReads (Storable.fromList [a, b]) === (a, b)

prop_dvec4_strict_reads :: Property
prop_dvec4_strict_reads = withTests PROP_TESTS $ property do
  a <- forAll genDVec4
  b <- forAll genDVec4
  strictReads (Storable.fromList [a, b]) === (a, b)

prop_mat4_strict_reads :: Property
prop_mat4_strict_reads = withTests PROP_TESTS $ property do
  (a, _) <- forAllTransform
  (b, _) <- forAllTransform
  strictReads (Storable.fromList [a, b]) === (a, b)

prop_dmat4_strict_reads :: Property
prop_dmat4_strict_reads = withTests PROP_TESTS $ property do
  (a, _) <- forAllDTransform
  (b, _) <- forAllDTransform
  strictReads (Storable.fromList [a, b]) === (a, b)

prop_block_layout :: Property
prop_block_layout = withTests 1 $ property do
  (8, 8) === layout140 (Proxy @Vec2)
  (16, 16) === layout140 (Proxy @Vec3)
  (16, 12) === layout140 (Proxy @Geomancy.Vec3.Packed)
  (16, 16) === layout140 (Proxy @Vec4)
  (8, 8) === layout140 (Proxy @IVec2)
  (16, 16) === layout140 (Proxy @IVec3)
  (16, 12) === layout140 (Proxy @Geomancy.IVec3.Packed)
  (16, 16) === layout140 (Proxy @IVec4)
  (8, 8) === layout140 (Proxy @UVec2)
  (16, 16) === layout140 (Proxy @UVec3)
  (16, 12) === layout140 (Proxy @Geomancy.UVec3.Packed)
  (16, 16) === layout140 (Proxy @UVec4)
  (16, 16) === layout140 (Proxy @DVec2)
  (32, 32) === layout140 (Proxy @DVec3)
  (32, 24) === layout140 (Proxy @Geomancy.DVec3.Packed)
  (32, 32) === layout140 (Proxy @DVec4)
  (16, 16) === layout140 (Proxy @Quaternion)
  (32, 32) === layout140 (Proxy @DQuaternion)
  (16, 64) === layout140 (Proxy @Transform)
  (32, 128) === layout140 (Proxy @DTransform)

data Both a = Both !a !a

{-# INLINE strictReads #-}
strictReads :: Storable a => Storable.Vector a -> (a, a)
strictReads v =
  case Both (Storable.unsafeIndex v 0) (Storable.unsafeIndex v 1) of
    Both a b -> (a, b)