diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/call-haskell-from-anything.cabal b/call-haskell-from-anything.cabal new file mode 100644 --- /dev/null +++ b/call-haskell-from-anything.cabal @@ -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. diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,4 @@ +#!/usr/bin/env sh + +# Pass all arguments that cabal passes us to the python script. +python2 detect-ghc-buildinfo.py $@ diff --git a/detect-ghc-buildinfo.py b/detect-ghc-buildinfo.py new file mode 100644 --- /dev/null +++ b/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 + ])) diff --git a/src/FFI/Anything/Copied.hs b/src/FFI/Anything/Copied.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/Copied.hs @@ -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 diff --git a/src/FFI/Anything/TH.hs b/src/FFI/Anything/TH.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TH.hs @@ -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)) +-- [] +-- ] diff --git a/src/FFI/Anything/TypeUncurry.hs b/src/FFI/Anything/TypeUncurry.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TypeUncurry.hs @@ -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 diff --git a/src/FFI/Anything/TypeUncurry/DataKinds.hs b/src/FFI/Anything/TypeUncurry/DataKinds.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TypeUncurry/DataKinds.hs @@ -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) + diff --git a/src/FFI/Anything/TypeUncurry/Legacy.hs b/src/FFI/Anything/TypeUncurry/Legacy.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TypeUncurry/Legacy.hs @@ -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) diff --git a/src/FFI/Anything/TypeUncurry/Msgpack.hs b/src/FFI/Anything/TypeUncurry/Msgpack.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TypeUncurry/Msgpack.hs @@ -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) diff --git a/src/FFI/Anything/TypeUncurry/ReturnResult.hs b/src/FFI/Anything/TypeUncurry/ReturnResult.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/TypeUncurry/ReturnResult.hs @@ -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 + diff --git a/src/FFI/Anything/Util.hs b/src/FFI/Anything/Util.hs new file mode 100644 --- /dev/null +++ b/src/FFI/Anything/Util.hs @@ -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 diff --git a/test/Test1.hs b/test/Test1.hs new file mode 100644 --- /dev/null +++ b/test/Test1.hs @@ -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