Automatic type-safe binding generation sketch (GHC HEAD)

marshal.hs

{-# LANGUAGE TypeFamilies, GADTs, DataKinds, TypeOperators, FlexibleInstances, OverlappingInstances, ConstraintKinds, MultiParamTypeClasses, ForeignFunctionInterface #-}

import Control.Applicative
import Foreign
import Foreign.C

-- heterogenous list
data HList (ts :: [ * ]) where
  E :: HList '[]
  (:.) :: t -> HList ts -> HList (t ': ts)

-- type-level list of function arguments
type family Input f where
  Input (a -> b) = a ': Input b
  Input x = '[]

-- function result
type family Output f where
  Output (a -> b) = Output b
  Output x = x

-- uncurried function
type i =-> o = HList i -> o

-- convert curried to uncurried
-- not actually used here, included for completeness
class GUncurry f where
  guncurry :: f -> (Input f =-> Output f)

instance GUncurry b => GUncurry (a -> b) where
  guncurry f (x :. xs) = guncurry (f x) xs

instance (Input r ~ '[], Output r ~ r) => GUncurry r where
  guncurry f E = f

-- convert uncurried to curried
class GCurry (ts :: [ * ]) where
  type GCurried ts a :: *
  gcurry :: (ts =-> a) -> GCurried ts a

instance GCurry '[] where
  type GCurried '[] a = a
  gcurry c = c E

instance GCurry ts => GCurry (t ': ts) where
  type GCurried (t ': ts) a = t -> GCurried ts a
  gcurry c x = gcurry (\xs -> c (x :. xs))

-- rules for marshalling arguments
type family MarshalIn (f :: *) :: [ * ] where
  MarshalIn (CString -> b) = (String ': MarshalIn b)
  MarshalIn (a -> b) = (a ': MarshalIn b)
  MarshalIn x = '[]

-- rules for marshalling results
type family MarshalOut (f :: *) :: * where
  MarshalOut (a -> b) = MarshalOut b
  MarshalOut (IO CInt) = IO Int
  MarshalOut x = x

-- convert curried foreign import to uncurried binding
class Marshal f where
  marshal' :: f -> (MarshalIn f =-> MarshalOut f)

instance (Marshal b, MarshalOut b ~ IO a) => Marshal (CString -> b) where
  marshal' f (s :. as) = withCString s $ \cs -> marshal' (f cs) as

instance (Marshal b, MarshalIn (a -> b) ~ ( a ': MarshalIn b)) => Marshal (a -> b) where
  marshal' f (x :. as) = marshal' (f x) as

instance Marshal (IO CInt) where
  marshal' m E = fromIntegral <$> m

instance (MarshalOut a ~ a) => Marshal a where
  marshal' x E = x

-- convert curried foreign import to curried binding
marshal :: (Marshal f, MarshalIn f ~ i, GCurry i)
               => f -> GCurried (MarshalIn f) (MarshalOut f)
marshal = gcurry . marshal'

-- demo!
foreign import ccall "puts"
  puts_ :: CString -> IO CInt

puts = marshal puts_ -- type inference works

puts_' :: CString -> CString -> IO CInt
puts_' = const puts_
puts' = marshal puts_' -- multiple arguments work

main :: IO ()
main = do
 puts "oh baby"
 puts' "leap of faith" "ka-ching"
 return ()