Haskell Polyvariadic Function With IO

Question

Is it possible to have a function that takes a foreign function call where some of the foreign function's arguments are CString and return a function that accepts String instead?

Here's an example of what I'm looking for:

 foreign_func_1 :: (CDouble -> CString -> IO())
 foreign_func_2 :: (CDouble -> CDouble -> CString -> IO ())

 externalFunc1 :: (Double -> String -> IO())
 externalFunc1 = myFunc foreign_func_1

 externalFunc2 :: (Double -> Double -> String -> IO())
 externalFunc2 = myFunc foreign_func_2

I figured out how to do this with the C numeric types. However, I can't figure out a way to do it that can allow string conversion.

The problem seems to be fitting in IO functions, since everything that converts to CStrings such as newCString or withCString are IO.

Here is what the code looks like to just handle converting doubles.

class CConvertable interiorArgs exteriorArgs where
   convertArgs :: (Ptr OtherIrrelevantType -> interiorArgs) -> exteriorArgs

instance CConvertable (IO ()) (Ptr OtherIrrelevantType -> IO ()) where
   convertArgs = doSomeOtherThingsThatArentCausingProblems
instance (Real b, Fractional a, CConvertable intArgs extArgs) => CConvertable (a->intArgs) (b->extArgs) where
    convertArgs op x= convertArgs (\ctx -> op ctx (realToFrac x))

Answer 1

Is it possible to have a function that takes a foreign function call where some of the foreign function's arguments are CString and return a function that accepts String instead?

Is it possible, you ask?

<lambdabot> The answer is: Yes! Haskell can do that.

Ok. Good thing we got that cleared up.

Warming up with a few tedious formalities:

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

Ah, it's not so bad though. Look, ma, no overlaps!

The problem seems to be fitting in IO functions, since everything that converts to CStrings such as newCString or withCString are IO.

Right. The thing to observe here is that there are two somewhat interrelated matters with which to concern ourselves: A correspondence between two types, allowing conversions; and any extra context introduced by performing a conversion. To deal with this fully, we'll make both parts explicit and shuffle them around appropriately. We also need to take heed of variance; lifting an entire function requires working with types in both covariant and contravariant position, so we'll need conversions going in both directions.

Now, given a function we wish to translate, the plan goes something like this:

• Convert the function's argument, receiving a new type and some context.
• Defer the context onto the function's result, to get the argument how we want it.
• Collapse redundant contexts where possible
• Recursively translate the function's result, to deal with multi-argument functions

Well, that doesn't sound too difficult. First, explicit contexts:

class (Functor f, Cxt t ~ f) => Context (f :: * -> *) t where
    type Collapse t :: *
    type Cxt t :: * -> *
    collapse :: t -> Collapse t

This says we have a context f, and some type t with that context. The Cxt type function extracts the plain context from t, and Collapse tries to combine contexts if possible. The collapse function lets us use the result of the type function.

For now, we have pure contexts, and IO:

newtype PureCxt a = PureCxt { unwrapPure :: a }

instance Context IO (IO (PureCxt a)) where
    type Collapse (IO (PureCxt a)) = IO a
    type Cxt (IO (PureCxt a)) = IO
    collapse = fmap unwrapPure

{- more instances here... -}

Simple enough. Handling various combinations of contexts is a bit tedious, but the instances are obvious and easy to write.

We'll also need a way to determine the context given a type to convert. Currently the context is the same going in either direction, but it's certainly conceivable for it to be otherwise, so I've treated them separately. Thus, we have two type families, supplying the new outermost context for an import/export conversion:

type family ExpCxt int :: * -> *
type family ImpCxt ext :: * -> *

Some example instances:

type instance ExpCxt () = PureCxt
type instance ImpCxt () = PureCxt

type instance ExpCxt String = IO
type instance ImpCxt CString = IO

Next up, converting individual types. We'll worry about recursion later. Time for another type class:

class (Foreign int ~ ext, Native ext ~ int) => Convert ext int where
    type Foreign int :: *
    type Native ext :: *
    toForeign :: int -> ExpCxt int ext
    toNative :: ext -> ImpCxt ext int

This says that two types ext and int are uniquely convertible to each other. I realize that it might not be desirable to always have only one mapping for each type, but I didn't feel like complicating things further (at least, not right now).

As noted, I've also put off handling recursive conversions here; probably they could be combined, but I felt it would be clearer this way. Non-recursive conversions have simple, well-defined mappings that introduce a corresponding context, while recursive conversions need to propagate and merge contexts and deal with distinguishing recursive steps from the base case.

Oh, and you may have noticed by now the funny wiggly tilde business going on up there in the class contexts. That indicates a constraint that the two types must be equal; in this case it ties each type function to the opposite type parameter, which gives the bidirectional nature mentioned above. Er, you probably want to have a fairly recent GHC, though. On older GHCs, this would need functional dependencies instead, and would be written as something like class Convert ext int | ext -> int, int -> ext.

The term-level conversion functions are pretty simple--note the type function application in their result; application is left-associative as always, so that's just applying the context from the earlier type families. Also note the cross-over in names, in that the export context comes from a lookup using the native type.

So, we can convert types that don't need IO:

instance Convert CDouble Double where
    type Foreign Double = CDouble
    type Native CDouble = Double
    toForeign = pure . realToFrac
    toNative = pure . realToFrac

...as well as types that do:

instance Convert CString String where
    type Foreign String = CString
    type Native CString = String
    toForeign = newCString
    toNative = peekCString

Now to strike at the heart of the matter, and translate whole functions recursively. It should come as no surprise that I've introduced yet another type class. Actually, two, as I've separated import/export conversions this time.

class FFImport ext where
    type Import ext :: *
    ffImport :: ext -> Import ext

class FFExport int where
    type Export int :: *
    ffExport :: int -> Export int

Nothing interesting here. You may be noticing a common pattern by now--we're doing roughly equal amounts of computing at both the term and type level, and we're doing them in tandem, even to the point of mimicking names and expression structure. This is pretty common if you're doing type-level calculation for things involving real values, since GHC gets fussy if it doesn't understand what you're doing. Lining things up like this reduces headaches significantly.

Anyway, for each of these classes, we need one instance for each possible base case, and one for the recursive case. Alas, we can't easily have a generic base case, due to the usual bothersome nonsense with overlapping. It could be done using fundeps and type equality conditionals, but... ugh. Maybe later. Another option would be to parameterize the conversion function by a type-level number giving the desired conversion depth, which has the downside of being less automatic, but gains some benefit from being explicit as well, such as being less likely to stumble on polymorphic or ambiguous types.

For now, I'm going to assume that every function ends with something in IO, since IO a is distinguishable from a -> b without overlap.

First, the base case:

instance ( Context IO (IO (ImpCxt a (Native a)))
         , Convert a (Native a)
         ) => FFImport (IO a) where
    type Import (IO a) = Collapse (IO (ImpCxt a (Native a)))
    ffImport x = collapse $ toNative <$> x

The constraints here assert a specific context using a known instance, and that we have some base type with a conversion. Again, note the parallel structure shared by the type function Import and term function ffImport. The actual idea here should be pretty obvious--we map the conversion function over IO, creating a nested context of some sort, then use Collapse/collapse to clean up afterwards.

The recursive case is similar, but more elaborate:

instance ( FFImport b, Convert a (Native a)
         , Context (ExpCxt (Native a)) (ExpCxt (Native a) (Import b))
         ) => FFImport (a -> b) where
    type Import (a -> b) = Native a -> Collapse (ExpCxt (Native a) (Import b))
    ffImport f x = collapse $ ffImport . f <$> toForeign x

We've added an FFImport constraint for the recursive call, and the context wrangling has gotten more awkward because we don't know exactly what it is, merely specifying enough to make sure we can deal with it. Note also the contravariance here, in that we're converting the function to native types, but converting the argument to a foreign type. Other than that, it's still pretty simple.

Now, I've left out some instances at this point, but everything else follows the same patterns as the above, so let's just skip to the end and scope out the goods. Some imaginary foreign functions:

foreign_1 :: (CDouble -> CString -> CString -> IO ())
foreign_1 = undefined

foreign_2 :: (CDouble -> SizedArray a -> IO CString)
foreign_2 = undefined

And conversions:

imported1 = ffImport foreign_1
imported2 = ffImport foreign_2

What, no type signatures? Did it work?

> :t imported1
imported1 :: Double -> String -> [Char] -> IO ()
> :t imported2
imported2 :: Foreign.Storable.Storable a => Double -> AsArray a -> IO [Char]

Yep, that's the inferred type. Ah, that's what I like to see.

Edit: For anyone who wants to try this out, I've taken the full code for the demonstration here, cleaned it up a bit, and uploaded it to github.