Vec64.hs

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

module Spec.Vec64 (tests) where

import Geomancy
import Hedgehog
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testPropertyNamed)

import Data.Proxy (Proxy(..))
import Data.Word (Word64)
import Foreign (allocaBytes, peekByteOff, pokeByteOff)
import Graphics.Gl.Block qualified as Block

import Geomancy.I64Vec3 qualified
import Geomancy.U64Vec3 qualified

import Support.Gen (genInt64, genWord64)
import Support.Property (pattern PROP_TESTS, layout140, storableRoundtrip)

tests :: TestTree
tests = testGroup "Vec64"
  [ testPropertyNamed "storable_roundtrip" "prop_vec64_storable_roundtrip" prop_vec64_storable_roundtrip
  , testPropertyNamed "packed_write_bounds" "prop_vec64_packed_write_bounds" prop_vec64_packed_write_bounds
  , testPropertyNamed "abs" "prop_vec64_abs" prop_vec64_abs
  , testPropertyNamed "block_layout" "prop_vec64_block_layout" prop_vec64_block_layout
  ]

prop_vec64_storable_roundtrip :: Property
prop_vec64_storable_roundtrip = withTests PROP_TESTS $ property do
  i2 <- forAll $ i64vec2 <$> genInt64 <*> genInt64
  storableRoundtrip i2 >>= (i2 ===)

  i3 <- forAll $ i64vec3 <$> genInt64 <*> genInt64 <*> genInt64
  storableRoundtrip i3 >>= (i3 ===)

  let i3p = Geomancy.I64Vec3.Packed i3
  storableRoundtrip i3p >>= (i3p ===)

  i4 <- forAll $ i64vec4 <$> genInt64 <*> genInt64 <*> genInt64 <*> genInt64
  storableRoundtrip i4 >>= (i4 ===)

  u2 <- forAll $ u64vec2 <$> genWord64 <*> genWord64
  storableRoundtrip u2 >>= (u2 ===)

  u3 <- forAll $ u64vec3 <$> genWord64 <*> genWord64 <*> genWord64
  storableRoundtrip u3 >>= (u3 ===)

  let u3p = Geomancy.U64Vec3.Packed u3
  storableRoundtrip u3p >>= (u3p ===)

  u4 <- forAll $ u64vec4 <$> genWord64 <*> genWord64 <*> genWord64 <*> genWord64
  storableRoundtrip u4 >>= (u4 ===)

prop_vec64_packed_write_bounds :: Property
prop_vec64_packed_write_bounds = withTests PROP_TESTS $ property do
  i3 <- forAll $ i64vec3 <$> genInt64 <*> genInt64 <*> genInt64
  u3 <- forAll $ u64vec3 <$> genWord64 <*> genWord64 <*> genWord64
  let sentinel = 0x5EAF00D :: Word64
  (i3', u3', afterI, afterU) <- evalIO $ allocaBytes 64 \ptr -> do
    pokeByteOff ptr 24 sentinel
    pokeByteOff ptr 56 sentinel
    pokeByteOff ptr 0 (Block.Packed i3)
    pokeByteOff ptr 32 (Block.Packed u3)
    (,,,)
      <$> fmap Block.getPacked (peekByteOff ptr 0)
      <*> fmap Block.getPacked (peekByteOff ptr 32)
      <*> peekByteOff ptr 24
      <*> peekByteOff ptr 56
  i3 === i3'
  u3 === u3'
  sentinel === afterI
  sentinel === afterU

prop_vec64_abs :: Property
prop_vec64_abs = withTests 1 $ property do
  i64vec2 1 2 === abs (i64vec2 (-1) 2)
  i64vec3 1 2 3 === abs (i64vec3 (-1) 2 (-3))
  i64vec4 1 2 3 4 === abs (i64vec4 (-1) 2 (-3) 4)

prop_vec64_block_layout :: Property
prop_vec64_block_layout = withTests 1 $ property do
  (16, 16) === layout140 (Proxy @I64Vec2)
  (32, 32) === layout140 (Proxy @I64Vec3)
  (32, 24) === layout140 (Proxy @Geomancy.I64Vec3.Packed)
  (32, 32) === layout140 (Proxy @I64Vec4)
  (16, 16) === layout140 (Proxy @U64Vec2)
  (32, 32) === layout140 (Proxy @U64Vec3)
  (32, 24) === layout140 (Proxy @Geomancy.U64Vec3.Packed)
  (32, 32) === layout140 (Proxy @U64Vec4)