call-haskell-from-anything (empty) → 0.1.0.2

raw patch · 13 files changed

+914/−0 lines, 13 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, call-haskell-from-anything, msgpack, mtl, template-haskell

Files

• Setup.hs +2/−0
• call-haskell-from-anything.cabal +81/−0
• configure +4/−0
• detect-ghc-buildinfo.py +27/−0
• src/FFI/Anything/Copied.hs +61/−0
• src/FFI/Anything/TH.hs +104/−0
• src/FFI/Anything/TypeUncurry.hs +30/−0
• src/FFI/Anything/TypeUncurry/DataKinds.hs +145/−0
• src/FFI/Anything/TypeUncurry/Legacy.hs +129/−0
• src/FFI/Anything/TypeUncurry/Msgpack.hs +175/−0
• src/FFI/Anything/TypeUncurry/ReturnResult.hs +48/−0
• src/FFI/Anything/Util.hs +13/−0
• test/Test1.hs +95/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,81 @@+name:          call-haskell-from-anything+version:       0.1.0.2+license:       MIT+author:        Niklas Hambüchen (mail@nh2.me)+maintainer:    Niklas Hambüchen (mail@nh2.me)+category:      Network+-- We use Configure to determine the `extra-libraries: HSrts-ghc*.*.*` field.+-- See the ./configure script.+build-type:    Configure+license:       MIT+synopsis:      Python-to-Haskell function calls+stability:     experimental+tested-with:   GHC==7.6.3, GHC==7.8.2+cabal-version: >= 1.10+homepage:      https://github.com/nh2/call-haskell-from-anything+bug-reports:   https://github.com/nh2/call-haskell-from-anything/issues+++extra-source-files:+  configure+  detect-ghc-buildinfo.py+++source-repository head+  type: git+  location: git://github.com/nh2/call-haskell-from-anything.git+++library+  default-language: Haskell2010+  hs-source-dirs:+    src+  exposed-modules:+    FFI.Anything.TH+    FFI.Anything.Copied+    FFI.Anything.TypeUncurry+    FFI.Anything.TypeUncurry.ReturnResult+    FFI.Anything.TypeUncurry.Legacy+    FFI.Anything.TypeUncurry.Msgpack+  if impl(ghc >= 7.6.0)+    exposed-modules:+      FFI.Anything.TypeUncurry.DataKinds+  other-modules:+    FFI.Anything.Util+  build-depends:+      base >= 4 && < 5+    , bytestring >= 0.10.0.0+    , msgpack >= 0.7.1.5 && < 1.0.0+    , template-haskell+    , mtl >= 2.1.2+    , attoparsec >= 0.10.3.0+  ghc-options:+    -Wall -fwarn-unused-imports+++executable call-haskell-from-anything.so+  default-language: Haskell2010+  hs-source-dirs:+    test+  main-is:+    Test1.hs+  build-depends:+      call-haskell-from-anything++    -- Packages that already have version bounds in the library:+    , base+    , bytestring+    , msgpack+    , mtl+  ghc-options:+    -- For building TemplateHaskell with cabal and -dynamic, we have to disable -dynamic sometimes+    -no-hs-main -fPIC -shared -dynamic++  -- If we don't specify the Haskell RTS as extra-libraries, we get errors like+  -- the following when calling from some other language:+  --   /usr/lib/ghc/ghc-prim-0.3.0.0/libHSghc-prim-0.3.0.0-ghc7.6.3.so: undefined symbol: stg_forkOnzh+  --+  -- The `build-type: Configure` with the `./configure` script makes sure that+  -- an `extra-libraries: HSrts-ghc*.*.*` field is added using cabal's .buildinfo infrastructure.+  -- See http://stackoverflow.com/questions/6034526/how-can-configuration-tools-like-sdl-config-be-used-with-a-cabalized-project+  -- and https://github.com/nh2/call-haskell-from-anything/pull/2#issuecomment-68638262.

@@ -0,0 +1,4 @@+#!/usr/bin/env sh++# Pass all arguments that cabal passes us to the python script.+python2 detect-ghc-buildinfo.py $@

@@ -0,0 +1,27 @@+import argparse+import subprocess+++# Get the compiler binary from cabal.+# Enables use of cabal's -w/--with-compiler option.+parser = argparse.ArgumentParser()+parser.add_argument(+  '--with-compiler', default="ghc", type=str,+  help='the compiler passed to cabal configure'+)+args, _unknown = parser.parse_known_args()  # ignore unknown arguments from cabal++ghc_binary = args.with_compiler+++print "Determining GHC version:",+ghc_version = subprocess.check_output([ghc_binary, "--numeric-version"]).strip()+print ghc_version+++with open("call-haskell-from-anything.buildinfo", "w") as f:+  f.writelines('\n'.join([+    "executable: call-haskell-from-anything.so",+    "extra-libraries: HSrts-ghc{0}".format(ghc_version),+    "",  # newline at end of file+  ]))

@@ -0,0 +1,61 @@+-- | Contains some functions needed from the msgpack package+-- that are unfortunately not yet exposed.+--+-- See https://github.com/msgpack/msgpack-haskell/pull/34.+module FFI.Anything.Copied where++import           Data.ByteString.Lazy.Builder+import qualified Data.Attoparsec.ByteString as A+import           Data.Bits+import           Data.Monoid+import           Data.Word+import           Text.Printf+++-- Copied from Data.MessagePack.Pack+fromArray :: (a -> Int) -> (a -> Builder) -> a -> Builder+fromArray lf pf arr = do+  case lf arr of+    len | len <= 15 ->+      word8 $ 0x90 .|. fromIntegral len+    len | len < 0x10000 ->+      word8 0xDC <>+      word16BE (fromIntegral len)+    len ->+      word8 0xDD <>+      word32BE (fromIntegral len)+  <> pf arr+++-- Copied from Data.MessagePack.Unpack+parseArray :: (Int -> A.Parser a) -> A.Parser a+parseArray aget = do+  c <- A.anyWord8+  case c of+    _ | c .&. 0xF0 == 0x90 ->+      aget . fromIntegral $ c .&. 0x0F+    0xDC ->+      aget . fromIntegral =<< parseUint16+    0xDD ->+      aget . fromIntegral =<< parseUint32+    _ ->+      fail $ printf "invalid array tag: 0x%02X" c+++parseUint16 :: A.Parser Word16+parseUint16 = do+  b0 <- A.anyWord8+  b1 <- A.anyWord8+  return $ (fromIntegral b0 `shiftL` 8) .|. fromIntegral b1+++parseUint32 :: A.Parser Word32+parseUint32 = do+  b0 <- A.anyWord8+  b1 <- A.anyWord8+  b2 <- A.anyWord8+  b3 <- A.anyWord8+  return $ (fromIntegral b0 `shiftL` 24) .|.+           (fromIntegral b1 `shiftL` 16) .|.+           (fromIntegral b2 `shiftL` 8) .|.+           fromIntegral b3

@@ -0,0 +1,104 @@+module FFI.Anything.TH where++import Language.Haskell.TH++import Debug.Trace+++++parameters :: Type -> [Type]  -- Result list are "ground" types+parameters t = case t of+  AppT t1 t2 -> parameters t1 ++ parameters t2+  ArrowT     -> []+  ConT name  -> [ConT name]+  -- TODO handle ListT, TupleT and so on+  _          -> error $ "parameters: unhandled Type " ++ show t+++-- TODO better use custom data type, tuples are quite finite+argTypesToTuple :: [Type] -> Type+argTypesToTuple types = foldl f (TupleT n) types+  where+    f a next = AppT a next+    n = length types+++debug :: (Show a, Monad m) => a -> m ()+debug x = trace ("\n" ++ show x ++ "\n") $ return ()+++deriveCallable :: Name -> String -> Q [Dec]+deriveCallable funName exportedName = do+  info <- reify funName+  case info of+    VarI name typ _mDec _fixity -> do+      let _nameString   = nameBase name+          signatureList = parameters typ+          paramTypes    = init signatureList+          returnType    = last signatureList++          typ' = [ SigD+                     (mkName exportedName)+                     (AppT+                       (AppT+                         ArrowT+                         (argTypesToTuple paramTypes)+                       )+                       returnType+                     )+                 ]++      debug typ'+      debug $ pprint typ'+      return []++    _ -> error "deriveCallable: can only derive functions"+++-- Example:+--+--   VarI+--     -- Name+--     FFI.Anything.f+--     -- Type+--     (AppT (AppT ArrowT (ConT GHC.Types.Int)) (AppT (AppT ArrowT (ConT GHC.Types.Double)) (ConT GHC.Base.String)))+--     -- Maybe Dec+--     Nothing+--     -- Fixity+--     (Fixity 9 InfixL)+--+-- Where the type "f :: Int -> Double -> String" is:+--+--   AppT+--     (AppT ArrowT (ConT GHC.Types.Int))+--     (AppT+--       (AppT ArrowT (ConT GHC.Types.Double))+--       (ConT GHC.Base.String)+--     )+--+--+-- The target is: runQ f_hs :: (Int, Double) -> String+-- so e.g.:+--+--   runQ [d| f_hs :: (Int, Double) -> String; f_hs = f_hs |]+--+-- which is:+--+--   [ SigD  -- This is the type+--       f_hs+--       (AppT+--         (AppT+--           ArrowT+--           (AppT+--             (AppT (TupleT 2) (ConT GHC.Types.Int))+--             (ConT GHC.Types.Double)+--           )+--         )+--         (ConT GHC.Base.String)+--       )+--   , ValD  -- This is the unimportant `f_hs = f_hs` part needed for the quasiquoter to complile+--       (VarP f_hs_2)+--       (NormalB (VarE f_hs_2))+--       []+--   ]

@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}++#if MIN_VERSION_base(4,6,0)+#define USE_DATA_KINDS 1+#endif++#if USE_DATA_KINDS+{-# LANGUAGE DataKinds, TypeOperators #-}+#endif+{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-}++-- | For GHC 7.6 or newer, we use (and re-export) "FFI.Anything.TypeUncurry.DataKinds" which uses DataKinds for TypeList to be kind-safe.+--+-- For all other versions, use (and re-export) "FFI.Anything.TypeUncurry.Legacy" which uses a simpler model of TypeList.+module FFI.Anything.TypeUncurry (+#if USE_DATA_KINDS+  -- | You see this because your compiler supports DataKinds.+  module FFI.Anything.TypeUncurry.DataKinds+#else+  -- | You see this because your compiler does not support DataKinds.+  module FFI.Anything.TypeUncurry.Legacy+#endif+) where+++#if USE_DATA_KINDS+import FFI.Anything.TypeUncurry.DataKinds+#else+import FFI.Anything.TypeUncurry.Legacy+#endif

@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds, GADTs, TypeOperators, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, PolyKinds, ScopedTypeVariables #-}++-- | Converts function arguments to tuple-like types.+--+-- For example, take @f :: a -> b -> c -> r@.+-- This module can convert it to @f' :: (a, b, c) -> r@, at compile time.+--+-- This is especially useful for (de)serialization.+-- Suppose you have a function that takes multiple arguments+-- and you want to obtain all of its arguments from some serialized data.+-- The serialization library will make it very easy to unpack types+-- like tuples/lists, but de-serializing *fuction arguments* is not that simple.+--+-- Using this module, you can write an instance how to unpack the 'TypeList' type,+-- and then use 'translateCall' to make any function take such a single 'TypeList'+-- instead of multiple function arguments.+--+-- There is currently a technical limitation:+-- The result type must be wrapped in the 'Identity' monad.+--+-- Example:+--+-- >-- Assume your library provides some unpack function, e.g. it allows you to write:+-- >unpack someBytestring :: (Int, String, Double)+-- >+-- >-- and you have a function+-- >f :: Int -> String -> Double -> Identity Char+-- >+-- >-- then you can use:+-- >f' :: (Int, String, Double) -> Identity Char+-- >f' = translateCall f+-- >+-- >result = f' (unpack someBytestring)+module FFI.Anything.TypeUncurry.DataKinds where++import           Control.Monad.Identity+++-- * Type-level lists (containing types)++-- NOTE: GHC 7.4 cannot deal with DataKinds+-- (see http://hackage.haskell.org/trac/ghc/ticket/5881)+--+-- This is why we have two separate implementations:+-- - one with DataKinds for GHC >= 7.6+-- - one with a standard Nil / Cons type-level list for older+--   compilers which is not kind-safe++-- | Type-level list that can contain arbitrarily mixed types.+--+-- Example:+--+-- >1 ::: "hello" ::: 2.3 :: TypeList '[Int, String, Double]+data TypeList l where+  Nil :: TypeList '[] -- TODO make singleton list, not empty list, base type?+  (:::) :: a -> TypeList l -> TypeList (a ': l)++-- Right-associativity, like (->)+infixr :::++-- Example: You can write:+--+-- exampleTypeList :: TypeList '[String, Int]+-- exampleTypeList = "a" ::: 3 ::: Nil+++-- * \"Uncurrying\" functions++{- In the following, we try to not use Template Haskell,+   using an instance of (a -> ...) to convert functions to TypeLists automatically+   (similar to how you make variadic functions).+-}++-- | Arguments to a function, e.g. @[String, Int]@ for @String -> Int -> r@.+type family Param f :: [*]+-- | For pure functions, we need an 'Identity' monad wrapper here to not conflict with @a -> f@.+type instance Param (Identity r) = '[]+type instance Param (IO r) = '[]+type instance Param (a -> f) = a ': Param f++-- | The result of a function, e.g. @r@ for @String -> Int -> r@.+type family Result f :: *+-- | For pure functions, we need an 'Identity' monad wrapper here to not conflict with @a -> f@.+type instance Result (Identity r) = r+type instance Result (IO r) = IO r+type instance Result (a -> f) = Result f+++-- | Function f can be translated to 'TypeList' l with result type r.+class (Param f ~ l, Result f ~ r) => ToTypeList f l r where+  -- | Translates a function taking multiple arguments to a function+  -- taking a single 'TypeList' containing the types of all arguments.+  --+  -- Example: @t1 -> ... -> tn -> r@ becomes @TypeList [t1, ..., tn] -> r@.+  translate :: f -> TypeList l -> r++-- | Recursive case: A function of type @a -> ... -> r@+-- can be translated to @TypeList [a, ...] -> r@.+instance ToTypeList (Identity r) '[] r where+  translate (Identity r) Nil = r++-- | Base case: A "pure" function without arguments (just @Identity r@)+-- can be translated to @TypeList Nil -> r@.+instance (ToTypeList f l r) => ToTypeList (a -> f) (a ': l) r where+  translate f (a ::: l) = translate (f a) l++-- | Base case: An IO function without arguments (just @Identity r@)+-- can be translated to @TypeList Nil -> r@.+instance ToTypeList (IO r) '[] (IO r) where+  translate ior Nil = ior+++-- Now an example:+--+-- someFunction :: Int -> Double -> Identity String+-- someFunction _i _d = return "asdf"+--+-- exampleAutoTranslate = translate someFunction+--+-- -- ghci would give as type for this: TypeList ((:) * Int ((:) * Double ([] *))) -> [Char]+++-- * Length of type-level lists++-- | A proxy type that can contain an arbitrary type.+--+-- Needed for some type-level computations, like 'paramLength'.+data Proxy k = Proxy+++-- | Allows to calculate the length of a 'TypeList', at compile time.+--+-- We need to use a 'Proxy' for this.+class ParamLength (l :: [*]) where+  -- | Calculates the length of a type list, put into a proxy. Usage:+  --+  -- >paramLength (undefined :: Proxy l)+  paramLength :: Proxy l -> Int++instance ParamLength '[] where+  paramLength _ = 0++instance (ParamLength l) => ParamLength (a ': l) where+  paramLength _ = succ $ paramLength (undefined :: Proxy l)+

@@ -0,0 +1,129 @@+{-# LANGUAGE GADTs, TypeOperators, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, ScopedTypeVariables, FlexibleContexts #-}++-- | Converts function arguments to tuple-like types.+--+-- This module is the LEGACY module not using DataKinds.+-- Compilers supporting DataKinds (e.g. GHC >= 7.6) should use "FFI.Anything.TypeUncurry".+--+-- For example, take @f :: a -> b -> c -> r@.+-- This module can convert it to @f' :: (a, b, c) -> r@, at compile time.+--+-- This is especially useful for (de)serialization.+-- Suppose you have a function that takes multiple arguments+-- and you want to obtain all of its arguments from some serialized data.+-- The serialization library will make it very easy to unpack types+-- like tuples/lists, but de-serializing *fuction arguments* is not that simple.+--+-- Using this module, you can write an instance how to unpack the 'TypeList' type,+-- and then use 'translateCall' to make any function take such a single 'TypeList'+-- instead of multiple function arguments.+--+-- There is currently a technical limitation:+-- The result type must be wrapped in the 'Identity' monad.+--+-- Example:+--+-- >-- Assume your library provides some unpack function, e.g. it allows you to write:+-- >unpack someBytestring :: (Int, String, Double)+-- >+-- >-- and you have a function+-- >f :: Int -> String -> Double -> Identity Char+-- >+-- >-- then you can use:+-- >f' :: (Int, String, Double) -> Identity Char+-- >f' = translateCall f+-- >+-- >result = f' (unpack someBytestring)+module FFI.Anything.TypeUncurry.Legacy where++import           Control.Monad.Identity+++-- * Type-level lists (containing types)++-- | The empty type-level type list+data Nil+-- | A type attached to a type-level type list+data a ::: b++-- | Type-level list that can contain arbitrarily mixed types.+--+-- Example:+--+-- >1 ::: "hello" ::: 2.3 :: TypeList (Int ::: String ::: Double ::: Nil)+data TypeList l where+  Nil :: TypeList Nil+  (:::) :: a -> TypeList l -> TypeList (a ::: l)++-- Right-associativity, like (->)+infixr :::+++-- * \"Uncurrying\" functions++{- In the following, we try to not use Template Haskell,+   using an instance of (a -> ...) to convert functions to TypeLists automatically+   (similar to how you make variadic functions).+-}++-- | Arguments to a function, e.g. @[String, Int]@ for @String -> Int -> r@.+type family Param f+-- | For pure functions, we need an 'Identity' monad wrapper here to not conflict with @a -> f@.+type instance Param (Identity r) = Nil+type instance Param (IO r) = Nil+type instance Param (a -> f) = a ::: Param f++-- | The result of a function, e.g. @r@ for @String -> Int -> r@.+type family Result f+-- | For pure functions, we need an 'Identity' monad wrapper here to not conflict with @a -> f@.+type instance Result (Identity r) = r+type instance Result (IO r) = IO r+type instance Result (a -> f) = Result f+++-- | Function f can be translated to 'TypeList' l with result type r.+class (Param f ~ l, Result f ~ r) => ToTypeList f l r where+  -- | Translates a function taking multiple arguments to a function+  -- taking a single 'TypeList' containing the types of all arguments.+  --+  -- Example: @t1 -> ... -> tn -> r@ becomes @TypeList (t1 ::: ... ::: tn ::: Nil) -> r@.+  translate :: f -> TypeList l -> r++-- | Recursive case: A "pure" function of type @a -> ... -> r@+-- can be translated to @TypeList (a ::: ...) -> r@.+instance (ToTypeList f l r) => ToTypeList (a -> f) (a ::: l) r where+  translate f (a ::: l) = translate (f a) l++-- | Base case: A "pure" function without arguments (just @Identity r@)+-- can be translated to @TypeList Nil -> r@.+instance ToTypeList (Identity r) Nil r where+  translate (Identity r) Nil = r++-- | Base case: An IO function without arguments (just @Identity r@)+-- can be translated to @TypeList Nil -> r@.+instance ToTypeList (IO r) Nil (IO r) where+  translate ior Nil = ior+++-- * Length of type-level lists++-- | A proxy type that can contain an arbitrary type.+--+-- Needed for some type-level computations, like 'paramLength'.+data Proxy k = Proxy+++-- | Allows to calculate the length of a 'TypeList', at compile time.+--+-- We need to use a 'Proxy' for this.+class ParamLength l where+  -- | Calculates the length of a type list, put into a proxy. Usage:+  --+  -- >paramLength (undefined :: Proxy l)+  paramLength :: Proxy l -> Int++instance ParamLength Nil where+  paramLength _ = 0++instance (ParamLength l) => ParamLength (a ::: l) where+  paramLength _ = succ $ paramLength (undefined :: Proxy l)

@@ -0,0 +1,175 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if MIN_VERSION_base(4,6,0)+#define USE_DATA_KINDS 1+#endif++#if USE_DATA_KINDS+{-# LANGUAGE DataKinds, TypeOperators #-}+#endif+{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-}++-- | Easy FFI via MessagePack.+--+-- You can use this module to expose any Haskell function to other Programming languages.+--+-- It allows to convert functions that take multiple arguments+-- into functions that take one argument:+-- A 'ByteString' which contains all arguments encoded as a MessagePack array.+--+-- Common use cases:+--+-- * Write functions in fast native Haskell code, compile them into a dynamic.+--   library (@.so@ \/ @.dll@) and call them via C\/Python\/Ruby\/whatever via @dlopen()@ or equivalents.+--+-- * Expose Haskell functions via a socket / the web+module FFI.Anything.TypeUncurry.Msgpack (+  UnpackableRec (..)+, getTypeListFromMsgpackArray+, uncurryMsgpack+, tryUncurryMsgpack+, tryUncurryMsgpackIO+, byteStringToCStringFun+, byteStringToCStringFunIO+, export+, exportIO+, module FFI.Anything.TypeUncurry.ReturnResult+) where++import           Control.Applicative+import qualified Data.Attoparsec.ByteString as A+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.MessagePack as MSG+import           Foreign.C+import           Text.Printf++import FFI.Anything.Copied+import FFI.Anything.Util+import FFI.Anything.TypeUncurry.ReturnResult++-- For GHC 7.6 or newer, this imports a TypeUncurry that uses DataKinds for TypeList to be kind-safe.+-- For older versions, it imports TypeUncurryLegacy which uses a weaker model of TypeList.+import FFI.Anything.TypeUncurry+++-- | Helper to allow writing a 'MSG.Unpackable' instance for 'TypeList's.+--+-- We need this because we have to call 'parseArray' at the top-level+-- 'MSG.Unpackable' instance, but not at each function argument step.+class UnpackableRec l where+  getRec :: A.Parser (TypeList l)++-- | When no more types need to be unpacked, we are done.+#if USE_DATA_KINDS+instance UnpackableRec '[] where -- For GHC 7.6 or newer, use DataKinds.+#else+instance UnpackableRec Nil where+#endif+  getRec = return Nil++-- | Unpack one type by just parsing the next element.+#if USE_DATA_KINDS+instance (MSG.Unpackable a, UnpackableRec l) => UnpackableRec (a ': l) where  -- For GHC 7.6 or newer, use DataKinds.+#else+instance (MSG.Unpackable a, UnpackableRec l) => UnpackableRec (a ::: l) where+#endif+  getRec = (:::) <$> MSG.get <*> getRec++++-- | Parses a tuple of arbitrary size ('TypeList's) from a MessagePack array.+getTypeListFromMsgpackArray :: forall l . (UnpackableRec l, ParamLength l) => A.Parser (TypeList l)+getTypeListFromMsgpackArray = parseArray f+  where+    len = paramLength (Proxy :: Proxy l)+    f n | n == len  = getRec+        -- TODO also print function name+        | otherwise = fail $ printf "getTypeListFromMsgpackArray: wrong number of function arguments: expected %d but got %d" len n+++instance (UnpackableRec l, ParamLength l) => MSG.Unpackable (TypeList l) where+  get = getTypeListFromMsgpackArray++++-- | Translates a function of type @a -> b -> ... -> Identity r@ to+-- a function that:+--+-- * takes as a single argument a 'ByteString' containing all arguments serialized in a MessagePack array+--+-- * returns its result serialized in a 'ByteString' via MessagePack 'MSG.pack'+--+-- This function throws an 'error' if the de-serialization of the arguments fails!+-- It is recommended to use 'tryUncurryMsgpack' instead.+uncurryMsgpack :: (MSG.Unpackable (TypeList l), ToTypeList f l r, MSG.Packable r) => f -> (ByteString -> ByteString)+uncurryMsgpack f = \bs -> lazyToStrictBS . MSG.pack $ (translate f $ MSG.unpack bs)+++-- | Like 'uncurryMsgpack', but for 'IO' functions.+--+-- This function throws an 'error' if the de-serialization of the arguments fails!+-- It is recommended to use 'tryUncurryMsgpackIO' instead.+uncurryMsgpackIO :: (MSG.Unpackable (TypeList l), ToTypeList f l (IO r), MSG.Packable r) => f -> (ByteString -> IO ByteString)+uncurryMsgpackIO f = \bs -> lazyToStrictBS . MSG.pack <$> (translate f $ MSG.unpack bs)+++-- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing+-- the function arguments does not contain the right number/types of arguments.+tryUncurryMsgpack :: (MSG.Unpackable (TypeList l), ToTypeList f l r, MSG.Packable r) => f -> (ByteString -> Either String ByteString)+tryUncurryMsgpack f = \bs -> case MSG.tryUnpack bs of+  Left e     -> Left e+  Right args -> Right . lazyToStrictBS . MSG.pack $ (translate f $ args)+++-- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing+-- the function arguments does not contain the right number/types of arguments.+tryUncurryMsgpackIO :: (MSG.Unpackable (TypeList l), ToTypeList f l (IO r), MSG.Packable r) => f -> (ByteString -> Either String (IO ByteString))+tryUncurryMsgpackIO f = \bs -> case MSG.tryUnpack bs of+  Left e     -> Left e+  Right args -> Right $ lazyToStrictBS . MSG.pack <$> (translate f $ args)+++-- * Exporting++-- TODO implement via byteStringToCStringFunIO?+-- | Transforms a 'ByteString'-mapping function to 'CString'-mapping function+-- for use in the FFI.+byteStringToCStringFun :: (ByteString -> ByteString) -> CString -> IO CString+byteStringToCStringFun f cs = do+  cs_bs <- BS.packCString cs+  let res_bs = f cs_bs+  res_cs <- BS.useAsCString res_bs return+  return res_cs+++-- | Transforms a 'ByteString'-mapping 'IO' function to 'CString'-mapping function+-- for use in the FFI.+byteStringToCStringFunIO :: (ByteString -> IO ByteString) -> CString -> IO CString+byteStringToCStringFunIO f cs = do+  cs_bs <- BS.packCString cs+  res_bs <- f cs_bs+  res_cs <- BS.useAsCString res_bs return+  return res_cs+++-- | Exports a "pure" function (usually it has to be wrapped in the Identity monad)+-- to an FFI function that takes its arguments as a serialized MessagePack message.+--+-- Calling this function throws an 'error' if the de-serialization of the arguments fails!+-- Use 'tryExport' if you want to handle this case.+export :: (MSG.Unpackable (TypeList l), ToTypeList f l r, MSG.Packable r) => f -> CString -> IO CString+export = byteStringToCStringFun . uncurryMsgpack+++-- | Exports an 'IO' function to an FFI function that takes its arguments as a serialized MessagePack message.+--+-- Calling this function throws an 'error' if the de-serialization of the arguments fails!+-- Use 'tryExportIO' if you want to handle this case.+exportIO :: (MSG.Unpackable (TypeList l), ToTypeList f l (IO r), MSG.Packable r) => f -> CString -> IO CString+exportIO = byteStringToCStringFunIO . uncurryMsgpackIO+++-- TODO make equivalent using tryUncurryMsgpack (tryExport)+-- TODO make equivalent using tryUncurryMsgpackIO (tryExport)

@@ -0,0 +1,48 @@+module FFI.Anything.TypeUncurry.ReturnResult where++import Control.Monad.Identity+++return1 :: (Monad m) => r -> m r+return1 = return++return2 :: (Monad m) => (a -> r) -> a -> m r+return2 f a = return $ f a++return3 :: (Monad m) => (a -> b -> r) -> a -> b -> m r+return3 f a b = return $ f a b++return4 :: (Monad m) => (a -> b -> c -> r) -> a -> b -> c -> m r+return4 f a b c = return $ f a b c++return5 :: (Monad m) => (a -> b -> c -> d -> r) -> a -> b -> c -> d -> m r+return5 f a b c d = return $ f a b c d++return6 :: (Monad m) => (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> m r+return6 f a b c d e = return $ f a b c d e++return7 :: (Monad m) => (a -> b -> c -> d -> e -> f -> r) -> a -> b -> c -> d -> e -> f -> m r+return7 f a b c d e = return . f a b c d e -- We don't want to use f again, haha!+++returnId1 :: r -> Identity r+returnId1 = return1++returnId2 :: (a -> r) -> a -> Identity r+returnId2 = return2++returnId3 :: (a -> b -> r) -> a -> b -> Identity r+returnId3 = return3++returnId4 :: (a -> b -> c -> r) -> a -> b -> c -> Identity r+returnId4 = return4++returnId5 :: (a -> b -> c -> d -> r) -> a -> b -> c -> d -> Identity r+returnId5 = return5++returnId6 :: (a -> b -> c -> d -> e -> r) -> a -> b -> c -> d -> e -> Identity r+returnId6 = return6++returnId7 :: (a -> b -> c -> d -> e -> f -> r) -> a -> b -> c -> d -> e -> f -> Identity r+returnId7 = return7+

@@ -0,0 +1,13 @@+-- | Contains some helper functions.+module FFI.Anything.Util (+  lazyToStrictBS+) where++import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import           Data.Monoid+++-- | Could use Data.ByteString.Lazy.toStrict starting from bytestring 0.10.0.0+lazyToStrictBS :: BSL.ByteString -> ByteString+lazyToStrictBS = mconcat . BSL.toChunks

@@ -0,0 +1,95 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TemplateHaskell #-}++module Test1 where++import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import           Data.Monoid+import qualified Data.MessagePack as MSG+import           Control.Monad.Identity++import Foreign.C++-- import FFI.Anything.TH (deriveCallable)+import FFI.Anything.TypeUncurry.Msgpack++++-- | Example function to be called from Python.+f1 :: Int -> Double -> String+f1 i f = "Called with params: " ++ show i ++ ", " ++ show f+++-- To be translated to:+f1' :: ByteString -> ByteString+f1' bs = mconcat . BSL.toChunks $ MSG.pack (uncurry f1 $ msg)+  where+    msg = case MSG.tryUnpack bs of+      Left e  -> error $ "tryUnpack: " ++ e+      Right r -> r+++-- TODO check who deallocs - it seems to work magically!+foreign export ccall f1_hs :: CString -> IO CString+f1_hs :: CString -> IO CString+f1_hs cs = do+    cs_bs <- BS.packCString cs+    let res_bs = f1' cs_bs+    res_cs <- BS.useAsCString res_bs return+    return res_cs+++f1_identity :: Int -> Double -> Identity String+f1_identity a b = return $ f1 a b+++-- Only works in GHC 7.6+-- f1_t :: CString -> IO CString+-- f1_t :: ByteString -> ByteString+-- f1_t = translateCall f1_identity++f1_t :: ByteString -> ByteString+f1_t = uncurryMsgpack f1_identity++foreign export ccall f1_t_export :: CString -> IO CString+f1_t_export :: CString -> IO CString+f1_t_export = byteStringToCStringFun f1_t++++fib :: Int -> Int+fib 0 = 1+fib 1 = 1+fib n = fib (n-1) + fib (n-2)+++fib_print :: Int -> IO Int+fib_print x = putStrLn ("fib_print: " ++ show f) >> return f+  where+    f = fib x+++foreign export ccall fib_export :: CString -> IO CString+fib_export :: CString -> IO CString+fib_export = export . returnId2 $ fib+++-- TODO the sole *presence* of this function seems to make the calls in Python slower+-- foreign export ccall fib_print_export :: CString -> IO CString+-- fib_print_export :: CString -> IO CString+-- fib_print_export = exportIO fib_print++-- -- TODO the sole *presence* of this function seems to make the calls in Python slower+-- foreign export ccall fib_print_export2 :: CString -> IO CString+-- fib_print_export2 :: CString -> IO CString+-- fib_print_export2 = exportIO fib_print+++-- $(deriveCallable 'f1 "f1_hs")+++foreign export ccall fib_export_ffi :: CInt -> CInt+fib_export_ffi :: CInt -> CInt+fib_export_ffi = fromIntegral . fib . fromIntegral