Marshal.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Marshal where
import Control.Applicative
import Control.Exception (bracket)
import Foreign
import Foreign.C
import GHC.Exts (RealWorld, unsafeCoerce#)
import GHC.IO (IO(..))
import System.IO.Unsafe


class Marshal a where
  type Haskell a
  toHaskell   :: a -> IO (Haskell a)
  fromHaskell :: Haskell a -> IO a
  withHaskell :: Haskell a -> (a -> IO b) -> IO b
  withHaskell x f = bracket (fromHaskell x) cleanup f
  cleanup :: a -> IO ()
  cleanup _ = return ()

instance Marshal CInt where
  type Haskell CInt = Int
  toHaskell   = return . fromIntegral
  fromHaskell = return . fromIntegral

instance Marshal CString where
  type Haskell CString = String
  toHaskell   = peekCString
  fromHaskell = newCString
  withHaskell = withCString
  cleanup     = free

type family MarshalEach f where
  MarshalEach (a -> b) = Haskell a -> MarshalEach b
  MarshalEach (IO b)   = IO (Haskell b)

class Marshals f where
  marshals' :: f -> IO (MarshalEach f)

instance (Marshal a, Marshals b) => Marshals (a -> b) where
  {-# INLINE marshals' #-}
  marshals' f = return $!
    \x -> unsafePerformIO (withHaskell x $ \y -> marshals' $ f y)

instance Marshal a => Marshals (IO a) where
  {-# INLINE marshals' #-}
  marshals' f = return $ toHaskell =<< f

marshals :: Marshals f => f -> IO (MarshalEach f)
marshals f = marshals' f


foreign import ccall puts :: CString -> IO CInt

main :: IO ()
main = do
  nicePuts <-  marshals puts
  nicePuts "hello"
  nicePuts "world"
  return ()