using Haskell's QuickCheck to property-test C's qsort

TestingCFromHaskell.hs

-- in response to https://www.reddit.com/r/haskell/comments/duopq8/create_tests_for_other_languages_using_haskell/
-- TLDR: yes, you can test C functions from Haskell; it's a bit painful to
-- call C from Haskell, but once you do, testing is the easy part!

{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TemplateHaskell #-}
module Main where

import Data.Foldable (for_)
import Data.Traversable (for)
import Foreign.C.Types (CInt, CSize)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (FunPtr, Ptr, castPtr)
import Foreign.Storable (Storable(peek, peekElemOff, pokeElemOff, sizeOf))
import Test.QuickCheck (quickCheck)
import Test.QuickCheck.Monadic (assert, monadicIO, run)
import qualified Language.C.Inline as C


------------------------------------------------------------------------------
-- PART 1: call C from Haskell                                              --
--                                                                          --
-- This part is long but straightforward. It looks longer than it really is --
-- because I was careful to define a lot of intermediate values, type       --
-- signatures, and comments in order to make sure everything is clear.      --
------------------------------------------------------------------------------

-- import qsort
C.include "<stdlib.h>"

-- define a way to transfer the Haskell comparison function to C
type Compare = Ptr () -> Ptr () -> IO CInt
foreign import ccall "wrapper"
  mkCompare :: Compare -> IO (FunPtr Compare)

qsort_wrapper :: forall a. Storable a
              => [a] -> (a -> a -> Ordering) -> IO [a]
qsort_wrapper xs f = do
  -- the Haskell arguments to qsort
  let nitems :: Int
      nitems = length xs

      bytesPerItem :: Int
      bytesPerItem = sizeOf (undefined :: a)

      compar :: Compare
      compar void_ptr1 void_ptr2 = do
        let ptr1 :: Ptr a
            ptr1 = castPtr void_ptr1

            ptr2 :: Ptr a
            ptr2 = castPtr void_ptr2

        x1 <- peek ptr1
        x2 <- peek ptr2
        case f x1 x2 of
          LT -> pure $ -1
          EQ -> pure $ 0
          GT -> pure $ 1

  -- allocate a buffer on the C side
  allocaBytes (nitems * bytesPerItem) $ \(buffer :: Ptr a) -> do
    -- fill the buffer
    for_ (zip [0..] xs) $ \(i, x) -> do
      pokeElemOff buffer i x

    -- the C arguments to qsort
    let c_buffer :: Ptr ()
        c_buffer = castPtr buffer

        c_nitems :: CSize
        c_nitems = fromIntegral nitems

        c_bytesPerItem :: CSize
        c_bytesPerItem = fromIntegral bytesPerItem

    c_compar :: FunPtr Compare
             <- mkCompare compar

    -- call qsort
    [C.block|
      void {
        qsort(
          $(void*  c_buffer),
          $(size_t c_nitems),
          $(size_t c_bytesPerItem),
          $(int (*c_compar)(const void*, const void*))
        );
      }
    |]

    -- read the buffer
    for (zip [0..] xs) $ \(i, _) -> do
      peekElemOff buffer i


------------------------------------------------------------------------------
-- PART 2: write ordinary Haskell tests                                     --
--                                                                          --
-- The reason we went through the trouble of writing part 1 is so we can    --
-- save time during part 2! qsort_wrapper is now an ordinary Haskell        --
-- function, so we can test it using ordinary Haskell testing frameworks,   --
-- e.g. QuickCheck. I assume you already know why QuickCheck is awesome :)  --
------------------------------------------------------------------------------


-- a property we expect to hold of qsort's output
isSorted :: Ord a
          => [a] -> Bool
isSorted xs = and $ zipWith (<=) xs (drop 1 xs)


-- we can finally write some tests!

-- |
-- >>> unitTest
-- [1,2,4,4,6,8,9]
-- [9,8,6,4,4,2,1]
unitTest :: IO ()
unitTest = do
  ys <- qsort_wrapper ([4,6,1,4,2,9,8] :: [CInt]) compare
  print ys
  zs <- qsort_wrapper ([4,6,1,4,2,9,8] :: [CInt]) (flip compare)
  print zs

-- |
-- >>> propertyTest
-- +++ OK, passed 100 tests.
propertyTest :: IO ()
propertyTest = quickCheck $ \xs -> monadicIO $ do
  ys <- run $ qsort_wrapper (xs :: [CInt]) compare
  assert $ isSorted ys

main :: IO ()
main = do
  unitTest
  propertyTest