Haskell <-> C using Function Pointer

ffi_qsort.hs

{-# LANGUAGE ForeignFunctionInterface #-}

import Foreign
import Foreign.C.Types
import Control.Applicative

foreign import ccall "stdlib.h qsort"
    c_qsort :: Ptr a
            -> CSize
            -> CSize
            -> FunPtr (Ptr a -> Ptr a -> CInt)
            -> IO ()

type CompPtr a = Ptr a -> Ptr a -> CInt
foreign import ccall "wrapper"
  wrap :: CompPtr a -> IO (FunPtr (CompPtr a))

lt :: Ptr Int -> Ptr Int -> CInt
lt p1 p2 = unsafePerformIO $ liftA2 cmp (peek p1) (peek p2)
    where cmp a b = case compare a b of
                      GT -> 1; EQ -> 0; LT -> -1

csize :: Int -> CSize
csize = fromIntegral


-- we need to serialize list to raw array
ffi_qsort_int :: [Int] -> [Int]
ffi_qsort_int lis = unsafePerformIO $ withArrayLen lis $ \len plis -> do
  ltW <- wrap lt
  c_qsort plis (csize len) (csize . sizeOf $ undefined `asTypeOf` head lis) ltW
  sorted <- peekArray len plis
  freeHaskellFunPtr ltW
  return sorted


-- TODO: work with any type implements Ord (using StablePtr?)
ffi_qsort :: (Ord a, Storable a)
          => (a -> a -> Ordering) -> [a] -> [a]
ffi_qsort cmp lis = unsafePerformIO $ withArrayLen lis $ \len plis -> do
  cmpW <- wrapCmp cmp
  c_qsort plis (csize len) (csize . sizeOf $ undefined `asTypeOf` head lis) cmpW
  sorted <- peekArray len plis
  freeHaskellFunPtr cmpW
  return sorted

wrapCmp :: (Storable a,Ord a) => (a -> a -> Ordering) -> IO (FunPtr (CompPtr a))
wrapCmp cmp = let pcmp p1 p2 = unsafePerformIO $ liftA2 ccmp (peek p1) (peek p2)
                  ccmp a1 a2 = case cmp a1 a2 of GT -> 1; EQ -> 0; LT -> -1
              in wrap pcmp