packages feed

call-haskell-from-anything 0.1.0.2 → 0.2.0.0

raw patch · 8 files changed

+52/−295 lines, 8 filesdep +vectordep −attoparsecdep ~basedep ~msgpacksetup-changed

Dependencies added: vector

Dependencies removed: attoparsec

Dependency ranges changed: base, msgpack

Files

Setup.hs view
@@ -1,2 +1,2 @@ import Distribution.Simple-main = defaultMain+main = defaultMainWithHooks autoconfUserHooks
call-haskell-from-anything.cabal view
@@ -1,5 +1,5 @@ name:          call-haskell-from-anything-version:       0.1.0.2+version:       0.2.0.0 license:       MIT author:        Niklas Hambüchen (mail@nh2.me) maintainer:    Niklas Hambüchen (mail@nh2.me)@@ -8,9 +8,10 @@ -- See the ./configure script. build-type:    Configure license:       MIT-synopsis:      Python-to-Haskell function calls+synopsis:      Call Haskell functions from other languages via serialization and dynamic libraries+description:   FFI via serialisation. See https://github.com/nh2/call-haskell-from-anything for details. stability:     experimental-tested-with:   GHC==7.6.3, GHC==7.8.2+tested-with:   GHC==7.10.3 cabal-version: >= 1.10 homepage:      https://github.com/nh2/call-haskell-from-anything bug-reports:   https://github.com/nh2/call-haskell-from-anything/issues@@ -32,23 +33,17 @@     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+    FFI.Anything.TypeUncurry.DataKinds   build-depends:-      base >= 4 && < 5+      base >= 4.8 && < 5     , bytestring >= 0.10.0.0-    , msgpack >= 0.7.1.5 && < 1.0.0+    , msgpack >= 1.0.0     , template-haskell     , mtl >= 2.1.2-    , attoparsec >= 0.10.3.0+    , vector   ghc-options:     -Wall -fwarn-unused-imports
− src/FFI/Anything/Copied.hs 
@@ -1,61 +0,0 @@--- | 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
src/FFI/Anything/TypeUncurry.hs view
@@ -1,30 +1,10 @@-{-# 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
− src/FFI/Anything/TypeUncurry/Legacy.hs 
@@ -1,129 +0,0 @@-{-# 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)
src/FFI/Anything/TypeUncurry/Msgpack.hs view
@@ -1,13 +1,6 @@-{-# 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.@@ -25,7 +18,7 @@ -- -- * Expose Haskell functions via a socket / the web module FFI.Anything.TypeUncurry.Msgpack (-  UnpackableRec (..)+  MessagePackRec (..) , getTypeListFromMsgpackArray , uncurryMsgpack , tryUncurryMsgpack@@ -37,61 +30,53 @@ , 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.ByteString.Lazy as BSL+import           Data.Maybe (fromMaybe) import qualified Data.MessagePack as MSG+import           Data.Vector (Vector)+import qualified Data.Vector as V 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.+-- | Helper to allow writing a 'MSG.MessagePack' 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)+-- 'MSG.MessagePack' instance, but not at each function argument step.+class MessagePackRec l where+  fromObjectRec :: Vector MSG.Object -> Maybe (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+instance MessagePackRec '[] where+  fromObjectRec v | V.null v = Just Nil+  fromObjectRec _            = Nothing  -- | 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--+instance (MSG.MessagePack a, MessagePackRec l) => MessagePackRec (a ': l) where+  fromObjectRec v | not (V.null v) = (:::) <$> MSG.fromObject (V.head v) <*> fromObjectRec (V.tail v)+  fromObjectRec _                  = Nothing  -- | 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+getTypeListFromMsgpackArray :: forall l . (MessagePackRec l, ParamLength l) => MSG.Object -> Maybe (TypeList l)+getTypeListFromMsgpackArray obj = case obj of+    MSG.ObjectArray v | V.length v == len -> fromObjectRec v+    _                                     -> Nothing   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 (MessagePackRec l, ParamLength l) => MSG.MessagePack (TypeList l) where+  fromObject = getTypeListFromMsgpackArray+  toObject = error "call-haskell-from-anything: Serialising a TypeList is not supported (and not needed)!" -instance (UnpackableRec l, ParamLength l) => MSG.Unpackable (TypeList l) where-  get = getTypeListFromMsgpackArray +-- | Standard error message when unpacking failed.+errorMsg :: String -> String+errorMsg locationStr = "call-haskell-from-anything: " ++ locationStr ++ ": got wrong number of function arguments or non-array"   -- | Translates a function of type @a -> b -> ... -> Identity r@ to@@ -103,32 +88,32 @@ -- -- 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)+uncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> ByteString)+uncurryMsgpack f = \bs -> BSL.toStrict . MSG.pack $ (translate f $ fromMaybe (error (errorMsg "uncurryMsgpack")) $ MSG.unpack $ BSL.fromStrict 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)+uncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> IO ByteString)+uncurryMsgpackIO f = \bs -> BSL.toStrict . MSG.pack <$> (translate f $ fromMaybe (error (errorMsg "uncurryMsgpackIO")) $ MSG.unpack $ BSL.fromStrict 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)+tryUncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> Maybe ByteString)+tryUncurryMsgpack f = \bs -> case MSG.unpack $ BSL.fromStrict bs of+  Nothing   -> Nothing+  Just args -> Just . BSL.toStrict . 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)+tryUncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> Maybe (IO ByteString))+tryUncurryMsgpackIO f = \bs -> case MSG.unpack $ BSL.fromStrict bs of+  Nothing   -> Nothing+  Just args -> Just $ BSL.toStrict . MSG.pack <$> (translate f $ args)   -- * Exporting@@ -159,7 +144,7 @@ -- -- 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 :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> CString -> IO CString export = byteStringToCStringFun . uncurryMsgpack  @@ -167,7 +152,7 @@ -- -- 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 :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> CString -> IO CString exportIO = byteStringToCStringFunIO . uncurryMsgpackIO
− src/FFI/Anything/Util.hs 
@@ -1,13 +0,0 @@--- | 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
test/Test1.hs view
@@ -24,11 +24,11 @@  -- To be translated to: f1' :: ByteString -> ByteString-f1' bs = mconcat . BSL.toChunks $ MSG.pack (uncurry f1 $ msg)+f1' bs = BSL.toStrict $ MSG.pack (uncurry f1 $ msg)   where-    msg = case MSG.tryUnpack bs of-      Left e  -> error $ "tryUnpack: " ++ e-      Right r -> r+    msg = case MSG.unpack (BSL.fromStrict bs) of+      Nothing -> error "could not unpack"+      Just r -> r   -- TODO check who deallocs - it seems to work magically!