Property.hs

module Test.Property
  ( Test
  , generated
  , example
  , returns
  , adopt
  , owned
  , array
  , alignedBytes
  ) where

import Control.Monad (unless, when)
import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT)
import Data.Word (Word8)
import Foreign.Marshal.Alloc (free, mallocBytes)
import Foreign.Marshal.Array (mallocArray)
import Foreign.Ptr (Ptr, alignPtr, castPtr)
import Foreign.Storable (Storable)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Hedgehog (Property, PropertyT, annotate, evalIO, failure, property, withTests, (===))

type Test = PropertyT (ResourceT IO)

generated :: Test () -> Property
generated = property . hoist runResourceT

example :: Test () -> Property
example = withTests 1 . generated

infix 1 `returns`

returns :: (HasCallStack, Eq a, Show a) => IO a -> a -> Test ()
returns action expected =
  withFrozenCallStack $ do
    actual <- evalIO action
    actual === expected

adopt :: (Eq handle) => handle -> (handle -> IO ()) -> IO handle -> Test handle
adopt missing release create = snd <$> allocate create releasePresent
  where
    releasePresent handle = unless (handle == missing) $ release handle

owned :: (Eq handle) => handle -> (handle -> IO ()) -> IO handle -> Test handle
owned missing release create = do
  handle <- adopt missing release create
  when (handle == missing) $ do
    annotate "C returned a NULL handle"
    failure
  pure handle

array :: (Storable a) => Int -> Test (Ptr a)
array count = snd <$> allocate (mallocArray $ max 1 count) free

alignedBytes :: Int -> Int -> Test (Ptr a)
alignedBytes size alignment = do
  (_, bytes) <- allocate (mallocBytes $ size + alignment) free
  pure . castPtr $ alignPtr (bytes :: Ptr Word8) alignment