pyfi (empty) → 0.4.0.2
raw patch · 6 files changed
+611/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, pureMD5, template-haskell
Files
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Russell Stewart ++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Python.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Python(+ module Str,+ defO,+ defV,+ defOO,+ defOV,+ defVO,+ defVV,+ defOOO,+ defOOV,+ defOVO,+ defOVV,+ defVOO,+ defVOV,+ defVVO,+ defVVV,+ defOOOO,+ defOOOV,+ defOOVO,+ defOOVV,+ defOVOO,+ defOVOV,+ defOVVO,+ defOVVV,+ defVOOO,+ defVOOV,+ defVOVO,+ defVOVV,+ defVVOO,+ defVVOV,+ defVVVO,+ defVVVV,+ PyObject,+ PythonException,+ exceptionType,+ )+where++import Str+import Data.Digest.Pure.MD5 (md5)+import Foreign.C+import Foreign (FunPtr, ForeignPtr)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.ForeignPtr (newForeignPtr, withForeignPtr)+import Foreign.Marshal.Alloc (free)+import Data.Aeson (FromJSON, ToJSON, toJSON, encode, decode)+import Data.ByteString.Lazy.Char8 (unpack, pack)+import Data.IORef (IORef, newIORef, writeIORef, readIORef)+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Data.List (elemIndex)+import Control.Exception (Exception, throw)+import Data.Typeable+import Data.Monoid (mconcat)++modules :: IORef (Map.Map String RawPyObject)+modules = unsafePerformIO $ newIORef (Map.empty)++data P+type RawPyObject = (Ptr P)+data PyObject a = PyObject (ForeignPtr P) deriving Show++data PythonException = PyException { exceptionType :: String, exceptionValue :: String } | DecodeException + deriving (Typeable)++instance Show PythonException where+ show DecodeException = "DecodeException"+ show x = exceptionType x ++ "\n" ++ exceptionValue x++instance Exception PythonException++foreign import ccall "getObject" c_getObject:: CString -> IO (RawPyObject)+foreign import ccall "getObjectInModule" c_getObjectInModule :: CString -> CString -> IO (RawPyObject)+foreign import ccall "execInModule" c_execInModule :: CString -> CString -> IO ()+foreign import ccall "PyRun_SimpleString" pyRun_SimpleString :: CString -> IO ()+foreign import ccall "Py_DecRef" py_DecRef :: RawPyObject -> IO ()+foreign import ccall "Py_Initialize" py_initialize :: IO ()+foreign import ccall "Py_Finalize" finalize :: IO ()+foreign import ccall "Py_BuildValue" py_BuildValueString :: CString -> CString -> IO (RawPyObject)+foreign import ccall "Py_BuildValue" py_BuildValueString2 :: CString -> CString -> CString -> IO (RawPyObject)+foreign import ccall "Py_BuildValue" py_BuildValueObject :: CString -> RawPyObject -> IO (RawPyObject)+foreign import ccall "Py_BuildValue" py_BuildValueObject2 :: CString -> RawPyObject -> RawPyObject -> IO (RawPyObject)+foreign import ccall "Py_BuildValue" py_BuildValueObject3 :: CString -> RawPyObject -> RawPyObject -> RawPyObject -> IO (RawPyObject)+foreign import ccall "Py_BuildValue" py_BuildValueObject4 :: CString -> RawPyObject -> RawPyObject -> RawPyObject -> RawPyObject -> IO (RawPyObject)+foreign import ccall "PyObject_CallObject" pyObject_CallObject :: RawPyObject -> RawPyObject -> IO (RawPyObject)+foreign import ccall "PyString_AsString" pyString_AsString :: RawPyObject -> IO CString+foreign import ccall unsafe "gimmeFunc" gimmeFunc :: CInt -> IO (FunPtr (RawPyObject -> IO ()))+foreign import ccall "checkError" c_checkError :: IO CString++exec :: String -> IO ()+exec s = withCString s pyRun_SimpleString++withCString2 :: String -> String -> (CString -> CString -> IO a) -> IO a+withCString2 s1 s2 f = withCString s1 f' where+ f' cs1 = withCString s2 (f cs1)++execInModule :: String -> String -> IO ()+execInModule moduleName payload = + withCString2 payload moduleName c_execInModule++parseException :: String -> PythonException+parseException s = let (t, v) = splitAt (fromJust $ (elemIndex ',' s)) s+ (_, t2) = splitAt (fromJust $ (elemIndex '\'' t)) t+ (t3, _) = splitAt (fromJust $ (elemIndex '\'' (tail t2 ))) (tail t2 )+ in PyException { exceptionType = t3, exceptionValue = tail v }++checkError :: String -> IO ()+checkError funcdef = do+ cs <- c_checkError+ if cs == nullPtr+ then return ()+ else do+ s <- peekCString cs+ free cs+ throw . parseException $ mconcat[s, "\n", take 70 $ cycle "-", "\n", funcdef]++initialize :: IO ()+initialize = do+ py_initialize++getObjectInModule :: String -> String -> IO (RawPyObject)+getObjectInModule moduleName objectName = + withCString2 objectName moduleName c_getObjectInModule++getObject :: String -> IO (RawPyObject)+getObject s = withCString s c_getObject++jsonfunc :: String+jsonfunc = [str|+def jsonfunc(argformats):+ def wrapper(f):+ import json+ import traceback+ def json_wrapper(*args):+ try:+ new_args = []+ for (x, format) in zip(args, argformats):+ if format == 'V':+ new_x = json.loads(x)+ new_args.append(new_x)+ else:+ new_args.append(x)+ result = f(*new_args)+ if argformats[-1] == 'V':+ result = json.dumps(result)+ return result+ except Exception as ex:+ assert("," not in str(type(ex)))+ ex.args = (traceback.format_exc(),)+ raise ex+ return json_wrapper+ return wrapper+|]++hash :: String -> String+hash contents = show . md5 $ pack contents++mydecode :: (FromJSON a) => String -> Maybe a+mydecode s = do+ x <- decode . pack . (\x -> "[" ++ x ++ "]") $ s+ return $ head x -- This code is dangerous. prelude's `head` isnt safe+++toPyObject :: (ToJSON a) => a -> IO (PyObject b)+toPyObject x = do+ y <- return . unpack . encode $ x+ p <- withCString "s" (\cs -> + withCString y (\cy -> + py_BuildValueString cs cy) )+ newForeignPyPtr p++fromPyObject :: (FromJSON a) => PyObject b -> IO a+fromPyObject (PyObject fr) = do+ r2 <- withForeignPtr fr $ \r -> peekCString =<< pyString_AsString r+ return $ case mydecode r2 of+ Just x -> x+ Nothing -> throw $ DecodeException++getFunc :: String -> String -> IO RawPyObject+getFunc s argTypes = do+ currentModules <- readIORef $ modules+ key <- return $ hash s+ if Map.member "initialized" currentModules then+ return ()+ else initialize+ case Map.lookup key currentModules of+ Just p -> return p+ Nothing -> do + execInModule key jsonfunc+ execInModule key s+ execInModule key $ "export = jsonfunc('" ++ argTypes ++ "')(export)"+ f' <- getObjectInModule key "export"+ if f' == nullPtr+ then error "NameError: name 'export' is not defined"+ else return ()+ writeIORef modules (Map.insert (hash s) f' currentModules)+ return f'++newForeignPyPtr :: RawPyObject -> IO (PyObject b)+newForeignPyPtr r = do+ finalizer <- gimmeFunc 0+ return . PyObject =<< newForeignPtr finalizer r++def1 :: String -> String -> IO (PyObject b)+def1 s argTypes = do+ f <- getFunc s argTypes+ r <- pyObject_CallObject f nullPtr+ checkError s+ newForeignPyPtr r++def2 :: String -> String -> (PyObject a) -> IO (PyObject b)+def2 s argTypes (PyObject fx1) = do+ f <- getFunc s argTypes+ p1 <- withForeignPtr fx1 $ \x1 -> withCString "(O)" (\cs -> py_BuildValueObject cs x1) + (PyObject fp) <- newForeignPyPtr p1+ r <- withForeignPtr fp $ \p -> pyObject_CallObject f p+ checkError s+ newForeignPyPtr r++def3 :: String -> String -> (PyObject a1) -> (PyObject a2) -> IO (PyObject b)+def3 s argTypes (PyObject fx1) (PyObject fx2) = do+ f <- getFunc s argTypes+ p1 <- withForeignPtr fx1 $ \x1 -> (+ withForeignPtr fx2 $ \x2 -> (+ withCString "(OO)" (\cs -> py_BuildValueObject2 cs x1 x2) + ))+ (PyObject fp) <- newForeignPyPtr p1+ r <- withForeignPtr fp $ \p -> pyObject_CallObject f p+ checkError s+ newForeignPyPtr r++def4 :: String -> String -> (PyObject a1) -> (PyObject a2) -> (PyObject a3) -> IO (PyObject b)+def4 s argTypes (PyObject fx1) (PyObject fx2) (PyObject fx3) = do+ f <- getFunc s argTypes+ p1 <- withForeignPtr fx1 $ \x1 -> (+ withForeignPtr fx2 $ \x2 -> (+ withForeignPtr fx3 $ \x3 -> (+ withCString "(OOO)" (\cs -> py_BuildValueObject3 cs x1 x2 x3) + )))+ (PyObject fp) <- newForeignPyPtr p1+ r <- withForeignPtr fp $ \p -> pyObject_CallObject f p+ checkError s+ newForeignPyPtr r++def5 :: String -> String -> (PyObject a1) -> (PyObject a2) -> (PyObject a3) -> (PyObject a4) -> IO (PyObject b)+def5 s argTypes (PyObject fx1) (PyObject fx2) (PyObject fx3) (PyObject fx4) = do+ f <- getFunc s argTypes+ p1 <- withForeignPtr fx1 $ \x1 -> (+ withForeignPtr fx2 $ \x2 -> (+ withForeignPtr fx3 $ \x3 -> (+ withForeignPtr fx4 $ \x4 -> (+ withCString "(OOOO)" (\cs -> py_BuildValueObject4 cs x1 x2 x3 x4) + ))))+ (PyObject fp) <- newForeignPyPtr p1+ r <- withForeignPtr fp $ \p -> pyObject_CallObject f p+ checkError s+ newForeignPyPtr r++defO :: String -> IO (PyObject b)+defO s = do+ fr <- def1 s "O" + return fr++defV :: (FromJSON b) => String -> IO b+defV s = do+ fr <- def1 s "V" + b <- fromPyObject fr+ return b++defOO :: String -> (PyObject a1) -> IO (PyObject b)+defOO s x1 = do+ fr <- def2 s "OO" x1+ return fr++defOV :: (FromJSON b) => String -> (PyObject a1) -> IO b+defOV s x1 = do+ fr <- def2 s "OV" x1+ b <- fromPyObject fr+ return b++defVO :: (ToJSON a1) => String -> a1 -> IO (PyObject b)+defVO s input1 = do+ x1 <- toPyObject input1+ fr <- def2 s "VO" x1+ return fr++defVV :: (ToJSON a1, FromJSON b) => String -> a1 -> IO b+defVV s input1 = do+ x1 <- toPyObject input1+ fr <- def2 s "VV" x1+ b <- fromPyObject fr+ return b++defOOO :: String -> (PyObject a1) -> (PyObject a2) -> IO (PyObject b)+defOOO s x1 x2 = do+ fr <- def3 s "OOO" x1 x2+ return fr++defOOV :: (FromJSON b) => String -> (PyObject a1) -> (PyObject a2) -> IO b+defOOV s x1 x2 = do+ fr <- def3 s "OOV" x1 x2+ b <- fromPyObject fr+ return b++defOVO :: (ToJSON a2) => String -> (PyObject a1) -> a2 -> IO (PyObject b)+defOVO s x1 input2 = do+ x2 <- toPyObject input2+ fr <- def3 s "OVO" x1 x2+ return fr++defOVV :: (ToJSON a2, FromJSON b) => String -> (PyObject a1) -> a2 -> IO b+defOVV s x1 input2 = do+ x2 <- toPyObject input2+ fr <- def3 s "OVV" x1 x2+ b <- fromPyObject fr+ return b++defVOO :: (ToJSON a1) => String -> a1 -> (PyObject a2) -> IO (PyObject b)+defVOO s input1 x2 = do+ x1 <- toPyObject input1+ fr <- def3 s "VOO" x1 x2+ return fr++defVOV :: (ToJSON a1, FromJSON b) => String -> a1 -> (PyObject a2) -> IO b+defVOV s input1 x2 = do+ x1 <- toPyObject input1+ fr <- def3 s "VOV" x1 x2+ b <- fromPyObject fr+ return b++defVVO :: (ToJSON a1, ToJSON a2) => String -> a1 -> a2 -> IO (PyObject b)+defVVO s input1 input2 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ fr <- def3 s "VVO" x1 x2+ return fr++defVVV :: (ToJSON a1, ToJSON a2, FromJSON b) => String -> a1 -> a2 -> IO b+defVVV s input1 input2 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ fr <- def3 s "VVV" x1 x2+ b <- fromPyObject fr+ return b++defOOOO :: String -> (PyObject a1) -> (PyObject a2) -> (PyObject a3) -> IO (PyObject b)+defOOOO s x1 x2 x3 = do+ fr <- def4 s "OOOO" x1 x2 x3+ return fr++defOOOV :: (FromJSON b) => String -> (PyObject a1) -> (PyObject a2) -> (PyObject a3) -> IO b+defOOOV s x1 x2 x3 = do+ fr <- def4 s "OOOV" x1 x2 x3+ b <- fromPyObject fr+ return b++defOOVO :: (ToJSON a3) => String -> (PyObject a1) -> (PyObject a2) -> a3 -> IO (PyObject b)+defOOVO s x1 x2 input3 = do+ x3 <- toPyObject input3+ fr <- def4 s "OOVO" x1 x2 x3+ return fr++defOOVV :: (ToJSON a3, FromJSON b) => String -> (PyObject a1) -> (PyObject a2) -> a3 -> IO b+defOOVV s x1 x2 input3 = do+ x3 <- toPyObject input3+ fr <- def4 s "OOVV" x1 x2 x3+ b <- fromPyObject fr+ return b++defOVOO :: (ToJSON a2) => String -> (PyObject a1) -> a2 -> (PyObject a3) -> IO (PyObject b)+defOVOO s x1 input2 x3 = do+ x2 <- toPyObject input2+ fr <- def4 s "OVOO" x1 x2 x3+ return fr++defOVOV :: (ToJSON a2, FromJSON b) => String -> (PyObject a1) -> a2 -> (PyObject a3) -> IO b+defOVOV s x1 input2 x3 = do+ x2 <- toPyObject input2+ fr <- def4 s "OVOV" x1 x2 x3+ b <- fromPyObject fr+ return b++defOVVO :: (ToJSON a2, ToJSON a3) => String -> (PyObject a1) -> a2 -> a3 -> IO (PyObject b)+defOVVO s x1 input2 input3 = do+ x2 <- toPyObject input2+ x3 <- toPyObject input3+ fr <- def4 s "OVVO" x1 x2 x3+ return fr++defOVVV :: (ToJSON a2, ToJSON a3, FromJSON b) => String -> (PyObject a1) -> a2 -> a3 -> IO b+defOVVV s x1 input2 input3 = do+ x2 <- toPyObject input2+ x3 <- toPyObject input3+ fr <- def4 s "OVVV" x1 x2 x3+ b <- fromPyObject fr+ return b++defVOOO :: (ToJSON a1) => String -> a1 -> (PyObject a2) -> (PyObject a3) -> IO (PyObject b)+defVOOO s input1 x2 x3 = do+ x1 <- toPyObject input1+ fr <- def4 s "VOOO" x1 x2 x3+ return fr++defVOOV :: (ToJSON a1, FromJSON b) => String -> a1 -> (PyObject a2) -> (PyObject a3) -> IO b+defVOOV s input1 x2 x3 = do+ x1 <- toPyObject input1+ fr <- def4 s "VOOV" x1 x2 x3+ b <- fromPyObject fr+ return b++defVOVO :: (ToJSON a1, ToJSON a3) => String -> a1 -> (PyObject a2) -> a3 -> IO (PyObject b)+defVOVO s input1 x2 input3 = do+ x1 <- toPyObject input1+ x3 <- toPyObject input3+ fr <- def4 s "VOVO" x1 x2 x3+ return fr++defVOVV :: (ToJSON a1, ToJSON a3, FromJSON b) => String -> a1 -> (PyObject a2) -> a3 -> IO b+defVOVV s input1 x2 input3 = do+ x1 <- toPyObject input1+ x3 <- toPyObject input3+ fr <- def4 s "VOVV" x1 x2 x3+ b <- fromPyObject fr+ return b++defVVOO :: (ToJSON a1, ToJSON a2) => String -> a1 -> a2 -> (PyObject a3) -> IO (PyObject b)+defVVOO s input1 input2 x3 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ fr <- def4 s "VVOO" x1 x2 x3+ return fr++defVVOV :: (ToJSON a1, ToJSON a2, FromJSON b) => String -> a1 -> a2 -> (PyObject a3) -> IO b+defVVOV s input1 input2 x3 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ fr <- def4 s "VVOV" x1 x2 x3+ b <- fromPyObject fr+ return b++defVVVO :: (ToJSON a1, ToJSON a2, ToJSON a3) => String -> a1 -> a2 -> a3 -> IO (PyObject b)+defVVVO s input1 input2 input3 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ x3 <- toPyObject input3+ fr <- def4 s "VVVO" x1 x2 x3+ return fr++defVVVV :: (ToJSON a1, ToJSON a2, ToJSON a3, FromJSON b) => String -> a1 -> a2 -> a3 -> IO b+defVVVV s input1 input2 input3 = do+ x1 <- toPyObject input1+ x2 <- toPyObject input2+ x3 <- toPyObject input3+ fr <- def4 s "VVVV" x1 x2 x3+ b <- fromPyObject fr+ return b
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Str.hs view
@@ -0,0 +1,6 @@+module Str(str) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++str = QuasiQuoter { quoteExp = stringE }
+ cdefs.c view
@@ -0,0 +1,93 @@+#include <stdio.h>+#include <Python.h>+#include <string.h>++void print_object(PyObject* object)+{+ PyObject_Print(object, stdout, 0);+}++PyObject* getObject(const char* string_name)+{+ PyObject *evalModule;+ PyObject *evalDict;+ PyObject *evalVal;+ evalModule = PyImport_AddModule( (char*)"__main__" );+ evalDict = PyModule_GetDict( evalModule );+ evalVal = PyDict_GetItemString( evalDict, string_name);+ if ( PyErr_Occurred() ) {+ PyErr_Print();PyErr_Clear(); return NULL;+ }+ else {+ return evalVal;+ }+}++PyObject* getObjectInModule(const char* objectName, const char* moduleName)+{+ PyObject *evalModule;+ PyObject *evalDict;+ PyObject *evalVal;+ evalModule = PyImport_AddModule( moduleName );+ evalDict = PyModule_GetDict( evalModule );+ evalVal = PyDict_GetItemString( evalDict, objectName );+ if ( PyErr_Occurred() ) {+ PyErr_Print();PyErr_Clear(); return evalVal;+ }+ else {+ return evalVal;+ }+}++char* checkError() {+ if ( PyErr_Occurred() ) {+ PyObject *exc_typ = NULL, *exc_val = NULL, *exc_tb = NULL;+ PyErr_Fetch( &exc_typ, &exc_val, &exc_tb);+ PyObject *exc_typ_string = PyObject_Str(exc_typ);+ PyObject *exc_val_string = PyObject_Str(exc_val);+ char *exc_typ_tmp = PyString_AsString(exc_typ_string);+ char *exc_val_tmp = PyString_AsString(exc_val_string);+ char *exc = malloc(strlen(exc_val_tmp) + strlen(exc_typ_tmp) + 1);+ strcpy(exc, exc_typ_tmp);+ strcat(exc, ",");+ strcat(exc, exc_val_tmp);+ Py_DECREF(exc_val_string);+ Py_DECREF(exc_typ_string);+ Py_XDECREF(exc_val);+ Py_XDECREF(exc_typ);+ Py_XDECREF(exc_tb);+ return exc;+ }+ else {+ return NULL;+ }+}++void execInModule(const char* payload, const char* moduleName) {+ PyObject *evalModule;+ PyObject *evalDict;+ PyObject *evalVal;+ evalModule = PyImport_AddModule(moduleName);+ PyObject *globals = PyModule_GetDict(evalModule);+ PyDict_SetItemString(globals, "__builtins__", PyEval_GetBuiltins());+ PyObject *locals = Py_BuildValue("{}");+ PyObject *result = PyRun_StringFlags(payload,+ Py_file_input,+ globals,+ globals,+ NULL);+ + if ( PyErr_Occurred() ) {PyErr_Print();PyErr_Clear();}+ return;+}++void finalizer(PyObject* p) {+ Py_DecRef(p);+}++typedef void funcType(PyObject*);+typedef funcType * pFuncType;++pFuncType gimmeFunc(int dummy) {+ return &finalizer;+}
+ pyfi.cabal view
@@ -0,0 +1,27 @@+-- Initial json-python.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: pyfi+version: 0.4.0.2+synopsis: Call python inline from haskell+description: WARNING: Project in alpha. Call python from haskell with ease.+homepage: http://github.com/Russell91/json-python+license: MIT+license-file: LICENSE+author: Russell Stewart+maintainer: russell.s.stewart@gmail.com+-- copyright:+category: Language+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ -- main-is: Main.hs+ exposed-modules: Python, Str+ other-extensions: TemplateHaskell, ForeignFunctionInterface, QuasiQuotes, OverloadedStrings+ build-depends: base >=4.6 && < 4.8, template-haskell >=2.8, aeson >=0.8 && <0.9, bytestring >=0.10 && <0.11, containers >= 0.5, pureMD5 >= 2.0+ -- hs-source-dirs:+ default-language: Haskell2010+ PkgConfig-Depends: python+ c-sources: cdefs.c