content: {-# LANGUAGE ViewPatterns #-}
  
  module Test.HsBindgen.Runtime.Bitfield (tests) where
  
  import Data.Bits (Bits (..))
  import Data.Word (Word64)
  import Foreign (Ptr)
  import Foreign.C.Types (CInt)
  import Foreign.Marshal.Alloc (allocaBytes)
  import Foreign.Marshal.Utils (fillBytes)
  import Test.QuickCheck (NonNegative (..), Positive (..), Property, Small (..),
                          counterexample, ioProperty, label, (===), (==>))
  import Test.Tasty (TestTree, testGroup)
  import Test.Tasty.QuickCheck (testProperty)
  
  import HsBindgen.Runtime.Bitfield (Bitfield (..), hiMask, loMask,
                                     peekBitOffWidth, pokeBitOffWidth)
  
  {-------------------------------------------------------------------------------
    Tests
  -------------------------------------------------------------------------------}
  
  tests :: TestTree
  tests = testGroup "HsBindgen.Runtime.Bitfield" [
        testProperty "extend . narrow" extend_narrow_prop
      , testProperty "bit peek . poke" bit_peek_poke_prop
      ]
  
  extend_narrow_prop :: Positive (Small Int) -> CInt -> Property
  extend_narrow_prop (Positive (Small w)) x' =
      (w <= 32 && topBit == negative) ==>
      label (if negative then "negative" else "non-negative")
      (counterexample (show (x, negative, topBit))
      (extend (narrow x w) w === x))
    where
      -- we fill or clear the top bits based on the signedness.
      --
      -- this is to make ==> discard less cases (most generated cases otherwise would be discarded)
      x :: CInt
      x = if x' < 0 then x' .|. hiMask w else x' .&. loMask w
  
      negative = x < 0
      topBit   = testBit x (w - 1)
  
  bit_peek_poke_prop_impl
      :: (Int -> Int -> Int -> Ptr a -> Word64 -> IO Property)
      -> NonNegative (Small Int) -> Positive (Small Int) -> Word64 -> Property
  bit_peek_poke_prop_impl test (NonNegative (Small off)) (Positive (Small (mod64 -> width))) x =
      label l $ mod off 64 + width <= 64 ==> ioProperty prop
    where
      l | mod off 8  + width <=  8 = "uint8"
        | mod off 16 + width <= 16 = "uint16"
        | mod off 32 + width <= 32 = "uint32"
        | mod off 64 + width <= 64 = "uint64"
        | otherwise                = "panic"
  
      size = div (off + width) 8 + 1
      prop = allocaBytes size $ \ptr -> do
          fillBytes ptr 0xAA size
          test off width size ptr x
  
  bit_peek_poke_prop :: NonNegative (Small Int) -> Positive (Small Int) -> Word64 -> Property
  bit_peek_poke_prop = bit_peek_poke_prop_impl $ \off width _size ptr x -> do
      pokeBitOffWidth ptr off width x
      x' <- peekBitOffWidth ptr off width
  
      return $ narrow x width === x'
  
  mod64 :: Integral a => a -> a
  mod64 x = mod x 64
  