FFI with exceptions

c.c

#include <stdio.h>

typedef void * CB(void);

void * u(CB * cb) {
  printf("calling cb\n");
  void* res = cb();
  if (res != NULL) {
    // exception
    return res;
  }

  printf("cb success\n");
  return NULL;
}

HS.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception
import Control.Concurrent
import Foreign.Ptr
import System.Exit
import System.IO
import Foreign.StablePtr

type CB = IO (Ptr ())

makeCB :: IO () -> CB
makeCB cb = catch act handle
  where
    handle :: SomeException -> IO (Ptr ())
    handle e = do
      ptr <- newStablePtr e
      pure (castStablePtrToPtr ptr)
    act = do
      cb
      pure nullPtr

foreign import ccall u :: FunPtr CB -> IO (Ptr ())

call :: IO (Ptr ()) -> IO ()
call ffi = do
  res <- ffi
  if res == nullPtr
    then pure ()
    else do
      putStrLn "ffi exception"
      exc :: SomeException <- deRefStablePtr (castPtrToStablePtr res)
      throwIO exc

main = do
  fbad <- funptr (makeCB bad)
  fgood <- funptr (makeCB good)
  call (u fgood)
  call (u fbad)

foreign import ccall "wrapper" funptr :: IO (Ptr ()) -> IO (FunPtr (IO (Ptr ())))

good :: IO ()
good = do
  putStrLn "OK"

bad :: IO ()
bad = do
  ioError (userError "hej")

Makefile

test: c.c HS.hs
	ghc -c c.c
	ghc -c HS.hs
	ghc c.o HS.o -o test