Marshal.hs

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

-- see acme-realworld
getWorld :: IO RealWorld
getWorld = IO (\s -> (# s, unsafeCoerce# s #))

evalIO :: IO a -> RealWorld -> (a, RealWorld)
evalIO (IO f) w = case f (unsafeCoerce# w) of
  (# w', a #) -> (a, unsafeCoerce# w')

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 = fromHaskell x >>= 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' :: IO () -> RealWorld -> f -> IO (MarshalEach f)

instance (Marshal a, Marshals b) => Marshals (a -> b) where
  {-# INLINE marshals' #-}
  marshals' clean w f = return $! \x -> case evalIO (fromHaskell x) w of
    (x', w') -> fst . evalIO (marshals' (clean >> cleanup x') w' (f x')) $ w'

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

marshals :: Marshals f => f -> IO (MarshalEach f)
marshals f = do
  w <- getWorld
  marshals' (return ()) w f

foreign import ccall puts :: CString -> IO CInt

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