├── HaPy-haskell ├── Setup.hs ├── HaPy_init.c ├── HaPy.cabal ├── LICENSE └── Foreign │ ├── HaPy │ └── Internal.hs │ └── HaPy.hs ├── HaPy-python ├── MANIFEST ├── setup.py └── HaPy.py ├── example ├── python │ ├── Makefile │ └── Example.py ├── haskell │ ├── Export.hs │ ├── ExampleModule.hs │ ├── update_libghc_version.sh │ ├── ExampleModule.cabal │ └── Makefile └── Makefile ├── .gitignore ├── LICENSE └── README.md /HaPy-haskell/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /HaPy-python/MANIFEST: -------------------------------------------------------------------------------- 1 | # file GENERATED by distutils, do NOT edit 2 | HaPy.py 3 | setup.py 4 | -------------------------------------------------------------------------------- /example/python/Makefile: -------------------------------------------------------------------------------- 1 | run: 2 | @echo === Running Python Project === 3 | python Example.py 4 | 5 | clean: 6 | @echo === Cleaning Python Project === 7 | rm -f *.so 8 | rm -f *.dylib 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *.swo 3 | HaPy-ffi-haskell/dist/ 4 | example/haskell/dist/ 5 | build/ 6 | dist/ 7 | .cabal-sandbox 8 | cabal.sandbox.config 9 | .DS_Store 10 | *.dylib 11 | *.so 12 | -------------------------------------------------------------------------------- /HaPy-python/setup.py: -------------------------------------------------------------------------------- 1 | from distutils.core import setup 2 | setup(name='HaPy-ffi', 3 | version='0.1.3', 4 | description='Haskell bindings for Python', 5 | author='David Fisher', 6 | author_email='ddf1991@gmail.com', 7 | url='https://github.com/sakana/HaPy', 8 | py_modules=['HaPy'], 9 | ) 10 | -------------------------------------------------------------------------------- /HaPy-haskell/HaPy_init.c: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | 3 | static void initialize() __attribute__((constructor)); 4 | static void initialize() { 5 | static char *argv[] = {"HaPy", 0}; 6 | static char **argv_ = argv; 7 | static int argc = 1; 8 | 9 | hs_init(&argc, &argv_); 10 | } 11 | 12 | static void finalize() __attribute__((destructor)); 13 | static void finalize() { 14 | hs_exit(); 15 | } 16 | -------------------------------------------------------------------------------- /example/haskell/Export.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, TemplateHaskell #-} 2 | 3 | module Export where 4 | import Foreign.HaPy 5 | import ExampleModule 6 | 7 | initHaPy 8 | 9 | pythonExport 'foo 10 | pythonExport 'bar 11 | pythonExport 'baz 12 | 13 | pythonExport 'arr_arg 14 | pythonExport 'arr_ret 15 | pythonExport 'arr_complex 16 | 17 | pythonExport 'string_fun 18 | pythonExport 'char_test 19 | -------------------------------------------------------------------------------- /example/haskell/ExampleModule.hs: -------------------------------------------------------------------------------- 1 | module ExampleModule where 2 | 3 | import Data.Char 4 | 5 | foo :: Double -> Double -> Double 6 | foo = (*) 7 | 8 | bar :: Int -> Int 9 | bar i = sum [1..i] 10 | 11 | baz :: Int -> Bool 12 | baz = (> 5) 13 | 14 | arr_arg :: [Int] -> Int 15 | arr_arg = sum 16 | 17 | arr_ret :: Int -> [Int] 18 | arr_ret i = [1..i] 19 | 20 | arr_complex :: [[Int]] -> [[Int]] 21 | arr_complex = map (map (* 2)) 22 | 23 | string_fun :: String -> String 24 | string_fun str = str ++ reverse str 25 | 26 | char_test :: Char -> Int 27 | char_test = ord 28 | -------------------------------------------------------------------------------- /example/haskell/update_libghc_version.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # My applogies for this file; the differences in sed between OS X and Linux are 4 | # minor but significant. I would have liked to put this in the Makefile, but 5 | # could not find any reasonable way to get newlines in a string. 6 | NEWLINE=$'\n' 7 | 8 | if [ $(uname) == Darwin ]; then 9 | sed -i '' "/extra-libraries/ c \\${NEWLINE}\ 10 | \ extra-libraries: HSrts-ghc$(ghc --numeric-version)" ExampleModule.cabal 11 | else 12 | sed -i "/extra-libraries/ c \\${NEWLINE}\ 13 | \ extra-libraries: HSrts-ghc$(ghc --numeric-version)" ExampleModule.cabal 14 | fi 15 | -------------------------------------------------------------------------------- /example/python/Example.py: -------------------------------------------------------------------------------- 1 | from HaPy import ExampleModule 2 | 3 | print "3 * 7 is", ExampleModule.foo(3,7) 4 | print "sum from 1 to 10 is", ExampleModule.bar(10) 5 | print "3 > 5 is", ExampleModule.baz(3) 6 | 7 | print "sum from 1 to 100 is", ExampleModule.arr_arg(range(101)) 8 | print "numbers from 1 to 10 are", ExampleModule.arr_ret(10) 9 | 10 | print "complex array passing:", ExampleModule.arr_complex([range(3), [], range(100)]) 11 | print "string fun:", ExampleModule.string_fun("This isn't really a palindrome.") 12 | 13 | s = ExampleModule.string_fun("abc\000def") 14 | print "string fun with nulls:", s, 15 | for c in s: 16 | print ord(c), 17 | print 18 | 19 | print "char test:", ExampleModule.char_test("t") 20 | -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | UNAME := $(shell uname) 2 | APT_EXISTS := $(shell command -v apt-get > /dev/null && echo "Y" || echo "N") 3 | all: 4 | @echo === Installing Dependencies === 5 | ifeq ($(UNAME),Linux) 6 | ifeq ($(APT_EXISTS),Y) 7 | @echo '>>> sudo apt-get install ghc-dynamic' 8 | @sudo apt-get install ghc-dynamic 9 | else 10 | @echo 'UNKNOWN LINUX DISTRO: please make sure you have dynamic Haskell base libraries installed.' 11 | endif 12 | @echo 13 | endif 14 | @echo '>>> sudo pip install hapy-ffi' 15 | @sudo pip install hapy-ffi 16 | @echo 17 | @$(MAKE) -C haskell all 18 | @echo 19 | 20 | clean: 21 | @$(MAKE) -C haskell clean 22 | @echo 23 | @$(MAKE) -C python clean 24 | 25 | run: all 26 | @$(MAKE) -C python run 27 | -------------------------------------------------------------------------------- /HaPy-haskell/HaPy.cabal: -------------------------------------------------------------------------------- 1 | name: HaPy 2 | version: 0.1.1.1 3 | synopsis: Haskell bindings for Python 4 | description: Call Haskell functions from Python! 5 | homepage: https://github.com/sakana/HaPy 6 | license: MIT 7 | license-file: LICENSE 8 | author: David Fisher 9 | maintainer: ddf1991@gmail.com 10 | category: Foreign 11 | build-type: Simple 12 | cabal-version: >=1.8 13 | 14 | library 15 | exposed-modules: 16 | Foreign.HaPy 17 | other-modules: 18 | Foreign.HaPy.Internal 19 | extensions: TemplateHaskell 20 | c-sources: HaPy_init.c 21 | build-depends: base >= 4.5 && < 4.9, 22 | th-lift >= 0.5 && < 0.8, 23 | template-haskell >= 2.7.0.0 && < 2.11.0.0 24 | -------------------------------------------------------------------------------- /example/haskell/ExampleModule.cabal: -------------------------------------------------------------------------------- 1 | -- Initial example.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: ExampleModule 5 | version: 0.1.0.0 6 | synopsis: simple example module for HaPy 7 | license: MIT 8 | author: David Fisher 9 | maintainer: ddf1991@gmail.com 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | library 14 | exposed-modules: ExampleModule, Export 15 | other-extensions: ForeignFunctionInterface, TemplateHaskell 16 | build-depends: base >=4.6 && <4.8, HaPy == 0.1.* 17 | default-language: Haskell2010 18 | 19 | -- *** change this to your GHC version *** 20 | -- the make script will do this automatically 21 | extra-libraries: HSrts-ghc7.8.2 22 | -------------------------------------------------------------------------------- /example/haskell/Makefile: -------------------------------------------------------------------------------- 1 | UNAME := $(shell uname) 2 | SED_COMMAND := $(shell printf '/extra-libraries/ c \\\n extra-libraries: HSrts-ghc$(GHC_VERSION)') 3 | all: 4 | @echo === Building Haskell ExampleModule === 5 | @echo '>>> ./update_libghc_version.sh' 6 | @./update_libghc_version.sh 7 | @echo '>>> cabal sandbox init' 8 | @cabal sandbox init 9 | @echo 10 | @echo '>>> cabal install --enable-shared' 11 | @cabal install --enable-shared 12 | @echo 13 | ifeq ($(UNAME),Linux) 14 | @echo '>>> cp dist/dist-sandbox-*/build/*.so ../python' 15 | @cp dist/dist-sandbox-*/build/*.so ../python 16 | else ifeq ($(UNAME),Darwin) 17 | @echo '>>> cp dist/dist-sandbox-*/build/*.dylib ../python' 18 | @cp dist/dist-sandbox-*/build/*.dylib ../python 19 | else 20 | @echo 'Unsupported OS!' 21 | endif 22 | 23 | clean: 24 | @echo === Cleaning Haskell Build === 25 | rm -f cabal.sandbox.config 26 | rm -rf .cabal-sandbox 27 | rm -rf dist 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2014 David Fisher 2 | 3 | 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: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | 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. 8 | -------------------------------------------------------------------------------- /HaPy-haskell/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2014 David Fisher 2 | 3 | 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: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | 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. 8 | -------------------------------------------------------------------------------- /HaPy-haskell/Foreign/HaPy/Internal.hs: -------------------------------------------------------------------------------- 1 | module Foreign.HaPy.Internal ( 2 | sizeOfList, 3 | peekList, 4 | pokeList, 5 | copyList 6 | ) where 7 | 8 | import Foreign.C ( CInt ) 9 | import Foreign.Marshal.Array ( pokeArray, peekArray ) 10 | import Foreign.Marshal.Alloc ( mallocBytes ) 11 | import Foreign.Storable ( Storable(..) ) 12 | import Foreign.Ptr ( Ptr, plusPtr, castPtr, alignPtr ) 13 | 14 | cInt :: CInt 15 | cInt = undefined 16 | 17 | lenPtr :: Storable a => Ptr [a] -> Ptr CInt 18 | lenPtr = castPtr 19 | 20 | arrPtr :: Storable a => Ptr [a] -> Ptr a 21 | arrPtr ptr = castPtr $ (ptr `plusPtr` sizeOf cInt) `alignPtr` alignment (ptrElem ptr) 22 | where ptrElem :: Ptr [a] -> a 23 | ptrElem = undefined 24 | 25 | sizeOfList :: Storable a => [a] -> Int 26 | sizeOfList xs = alignedIntSize + length xs * sizeOf (head xs) 27 | where alignedIntSize = max (sizeOf cInt) (alignment $ head xs) 28 | 29 | peekList :: Storable a => Ptr [a] -> IO [a] 30 | peekList ptr = do 31 | len <- peek $ lenPtr ptr 32 | peekArray (fromIntegral len) $ arrPtr ptr 33 | 34 | pokeList :: Storable a => Ptr [a] -> [a] -> IO () 35 | pokeList ptr xs = do 36 | poke (lenPtr ptr) (fromIntegral $ length xs) 37 | pokeArray (arrPtr ptr) xs 38 | 39 | copyList :: Storable a => [a] -> IO (Ptr [a]) 40 | copyList xs = do 41 | ptr <- mallocBytes $ sizeOfList xs 42 | pokeList ptr xs 43 | return ptr 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | HaPy 2 | ==== 3 | 4 | Call Haskell functions from Python! HaPy is set of Haskell bindings for Python. Initially written in 2011 as a final project for Stanford's CS240H Haskell class by Ashwin Siripurapu, William Rowan, and David Fisher. Now rewritten mostly from scratch by David Fisher with different tradeoffs (gaining far more stability at the expense of initial setup). 5 | 6 | **Table of Contents** 7 | 8 | - [Ubuntu Installation and Usage](#ubuntu-installation-and-usage) 9 | - [OS X/General Installation and Usage](#os-xgeneral-installation-and-usage) 10 | - [Common Errors](#common-errors) 11 | - [FAQ](#faq) 12 | - [Caveats](#caveats) 13 | - [Future development](#future-development) 14 | 15 | Ubuntu Installation and Usage: 16 | ------------------ 17 | * Install the dynamic base libraries with `sudo apt-get install ghc-dynamic`. 18 | * Follow the steps of the OS X/General Installation below. 19 | 20 | OS X/General Installation and Usage: 21 | -------------------------- 22 | * Pre-installation assumptions: (if you don't meet these, please consult the appropriate project's documentation for more information) 23 | * You have [pip](https://pypi.python.org/pypi/pip) installed. 24 | * You are using [cabal](http://www.haskell.org/cabal/) as your Haskell build tool. You are running cabal 1.18 or above. 25 | * You are using [GHC](http://www.haskell.org/ghc/) version 7.6 or above. (This project might work with earlier versions, but this has not been tested.) 26 | * In the directory of your Haskell project: 27 | * Update your cabal file: 28 | * Add HaPy to your build-depends. You should have a line that looks like this: `build-depends: [other haskell dependencies, if any], HaPy == 0.1.*`. 29 | * Add the GHC RTS library to your extra-libraries. The line should look like this: `extra-libraries: HSrts-ghc7.6.3`. *IMPORTANT*: You must update this line to refer to your current version of GHC. (This is slightly annoying, but I haven't been able to find a better way to do this.) 30 | * Make a FFI export Haskell module. Due to Template Haskell restrictions, this must be in a different module from any functions you are exporting. See: `example/haskell/Export.hs`. 31 | * If you're not already using one, create a [cabal sandbox](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html) with `cabal sandbox init`. 32 | * Build and install your Haskell module to your local sanbox with `cabal install --enable-shared`. 33 | * Copy the compiled .so (on Linux) or .dylib (on OS X) file from `dist/dist-sandbox-*/build/` to your Python project directory. 34 | * In your Python project: 35 | * Install the Python library with `sudo pip install hapy-ffi`. 36 | * Import your Haskell module with `from HaPy import HASKELL_MODULE_NAME`. 37 | * Call Haskell functions from Python, just like you would any other Python module. 38 | 39 | Common Errors: 40 | ------------- 41 | * During cabal install: 42 | * Error: `cabal: Could not resolve dependencies` --> HaPy might not be in your local package index; run `cabal update` and try again. If this doesn't help, the problem probably isn't HaPy related. 43 | * Error: `Missing C library: HSrts-ghc7.8.2` (or similar) --> The version of the GHC RTS library that you specified in your cabal file doesn't match the version of GHC you're running. 44 | * When running your Python project: 45 | * `Symbol not found: _stg_IND_STATIC_info` or `undefined symbol: stg_forkOnzh` --> The GHC RTS library isn't specified as one of the extra-libraries in the cabal file of your Haskell project. See the [General Installation and Usage](#os-xgeneral-installation-and-usage) section above. 46 | * Anything else: please make an issue and I'll take a look! 47 | 48 | 49 | FAQ: 50 | ----- 51 | None yet! Feel free to start an issue if there's something you don't understand. 52 | 53 | Caveats: 54 | ------------- 55 | * Only functions of certain types can be exported. Currently supported types: 56 | * Bool 57 | * Char 58 | * Int 59 | * Double 60 | * String 61 | * Lists (at any level of nesting) of all the above types (e.g. [Int], [[Int]], etc.) 62 | * The FFI adds some overhead: all values are copied twice (e.g. from the Python representation to the C representation to the Haskell representation). 63 | 64 | Future development: 65 | ------------------- 66 | * Near term: 67 | * Allow the compiled Haskell binary to be in appropriate other directories 68 | * Under consideration: 69 | * Automatically compile Haskell library from Python 70 | * Automatically generate Template Haskell export file in Python 71 | * Add support for passing Python functions 72 | * Add support for tuples 73 | -------------------------------------------------------------------------------- /HaPy-haskell/Foreign/HaPy.hs: -------------------------------------------------------------------------------- 1 | module Foreign.HaPy ( 2 | initHaPy, 3 | pythonExport, 4 | __exportInfo, 5 | module Foreign.C 6 | ) where 7 | 8 | import Foreign.HaPy.Internal ( peekList, copyList ) 9 | import Language.Haskell.TH 10 | import Language.Haskell.TH.Syntax ( Lift(lift) ) 11 | import Language.Haskell.TH.Lift ( deriveLift ) 12 | 13 | import Foreign.C 14 | ( CInt(..), 15 | CDouble(..), 16 | CChar(..), 17 | castCharToCChar, 18 | castCCharToChar ) 19 | import Foreign.Ptr ( Ptr ) 20 | import Foreign.Marshal.Array () 21 | import Foreign.Marshal.Alloc ( free ) 22 | 23 | import Data.List ( intercalate ) 24 | import Control.Monad ( zipWithM, replicateM, ap ) 25 | 26 | data FType = FBool | FChar | FInt | FDouble | FList FType | FUnknown 27 | deriving (Eq, Ord, Show) 28 | 29 | deriveLift ''FType 30 | 31 | __exportInfo :: [FType] -> IO (Ptr [CChar]) 32 | __exportInfo ftypes = copyList $ map castCharToCChar typeString 33 | where typeString = intercalate ";" $ map toTypeString ftypes 34 | toTypeString (FList t) = "List " ++ toTypeString t 35 | toTypeString FBool = "Bool" 36 | toTypeString FChar = "Char" 37 | toTypeString FInt = "Int" 38 | toTypeString FDouble = "Double" 39 | toTypeString _ = "Unknown" 40 | 41 | 42 | -- Can't use e.g. ''Bool when pattern matching 43 | fromHaskellType :: Type -> FType 44 | fromHaskellType (ConT nm) | nm == ''Bool = FBool 45 | | nm == ''Char = FChar 46 | | nm == ''Int = FInt 47 | | nm == ''Double = FDouble 48 | | nm == ''String = FList FChar 49 | fromHaskellType (AppT ListT t) = FList (fromHaskellType t) 50 | fromHaskellType _ = FUnknown 51 | 52 | toForeignType :: FType -> Bool -> TypeQ 53 | toForeignType t ret | ret = [t| IO $(toF t) |] 54 | | otherwise = toF t 55 | where toF FBool = [t| Bool |] 56 | toF FChar = [t| CChar |] 57 | toF FInt = [t| CInt |] 58 | toF FDouble = [t| CDouble |] 59 | toF (FList t) = [t| Ptr [$(toF t)] |] 60 | toF _ = error "unknown type - cannot convert!" -- TODO: catch error at an earlier stage 61 | 62 | 63 | -- Converts the type of a function to a list of the type of its args and return value 64 | toTypeList :: Type -> [Type] 65 | toTypeList (AppT (AppT ArrowT t) ts) = t : toTypeList ts 66 | toTypeList t = [t] 67 | 68 | -- Converts the a list of the types of a function's args and return value to the type of a function 69 | fromTypeList :: [Type] -> Type 70 | fromTypeList [] = error "type list empty!" 71 | fromTypeList (t:[]) = t 72 | fromTypeList (t:ts) = (AppT (AppT ArrowT t) (fromTypeList ts)) 73 | 74 | 75 | fromForeignExp :: FType -> ExpQ -> ExpQ 76 | fromForeignExp FBool exp = [| return $ $exp |] 77 | fromForeignExp FChar exp = [| return $ castCCharToChar $exp |] 78 | fromForeignExp FInt exp = [| return $ fromIntegral $exp |] 79 | fromForeignExp FDouble exp = [| return $ realToFrac $exp |] 80 | fromForeignExp (FList t) exp = [| peekList $exp >>= mapM (\x -> $(fromForeignExp t [|x|])) |] 81 | fromForeignExp _ exp = fail "conversion failed: unknown type!" 82 | 83 | toForeignExp :: FType -> ExpQ -> ExpQ 84 | toForeignExp FBool exp = [| return $ $exp |] 85 | toForeignExp FChar exp = [| return $ castCharToCChar $exp |] 86 | toForeignExp FInt exp = [| return $ fromIntegral $exp |] 87 | toForeignExp FDouble exp = [| return $ realToFrac $exp |] 88 | toForeignExp (FList t) exp = [| mapM (\x -> $(toForeignExp t [|x|])) $exp >>= copyList |] 89 | toForeignExp _ exp = fail "conversion failed: unknown type!" 90 | 91 | makeFunction :: (String -> String) -> (Name -> [FType] -> ClauseQ) -> ([FType] -> TypeQ) -> Name -> DecsQ 92 | makeFunction changeName makeClause makeType origName = do 93 | VarI _ t _ _ <- reify origName 94 | let types = map fromHaskellType $ toTypeList t 95 | name = mkName . changeName . nameBase $ origName 96 | cl = makeClause origName types 97 | func = funD name [cl] 98 | 99 | typ = makeType types 100 | dec = ForeignD `fmap` ExportF CCall (nameBase name) name `fmap` typ 101 | sequence [func, dec] 102 | 103 | makeInfoFunction :: Name -> DecsQ 104 | makeInfoFunction name = makeFunction makeName makeClause (const [t| IO (Ptr [CChar]) |]) name 105 | where makeName = (++ "__info") 106 | makeClause _ types = let body = normalB $ [| __exportInfo $(lift types) |] in 107 | clause [] body [] 108 | 109 | 110 | makeExportFunction :: Name -> DecsQ 111 | makeExportFunction = makeFunction makeName makeClause makeType 112 | where makeName = (++ "__export") 113 | makeType ts = fmap fromTypeList $ zipWithM toForeignType ts (replicate (length ts - 1) False ++ [True]) 114 | makeClause nm types = do 115 | vars <- replicateM (length types - 1) (newName "x") 116 | let args = map varP vars 117 | convertedArgs = zipWith fromForeignExp types (map varE vars) 118 | appliedFunction = foldl apArg [|return $(varE nm)|] convertedArgs 119 | body = normalB $ [| $appliedFunction >>= \x -> $(toForeignExp (last types) [|x|]) |] 120 | clause args body [] 121 | apArg :: ExpQ -> ExpQ -> ExpQ 122 | apArg f arg = [| ap $f $arg |] 123 | 124 | pythonExport :: Name -> DecsQ 125 | pythonExport nm = do 126 | info <- makeInfoFunction nm 127 | export <- makeExportFunction nm 128 | return $ info ++ export 129 | 130 | initHaPy :: DecsQ 131 | initHaPy = do 132 | exportType <- [t| Ptr () -> IO () |] 133 | let export = ForeignD $ ExportF CCall "__free" (mkName "__free") exportType 134 | func <- [d| __free = free |] 135 | return $ export:func 136 | -------------------------------------------------------------------------------- /HaPy-python/HaPy.py: -------------------------------------------------------------------------------- 1 | from ctypes import * 2 | import sys 3 | import glob 4 | 5 | class HaPyImporter: 6 | def find_module(self, fullname, path=None): 7 | if (fullname.split('.'))[0] == "HaPy": 8 | return self 9 | else: 10 | return None 11 | 12 | def load_module(self, fullname): 13 | module_name = '.'.join((fullname.split('.'))[1:]) 14 | already_loaded = fullname in sys.modules 15 | if not already_loaded: 16 | mod = HaskellModule(module_name) 17 | sys.modules[fullname] = mod 18 | mod.__file__ = "<%s>" % self.__class__.__name__ 19 | mod.__loader__ = self 20 | mod.__package__ = fullname.rpartition('.')[0] 21 | mod.__path__ = None 22 | return mod 23 | 24 | class HaskellModule: 25 | def __init__(self, module_name): 26 | self.module_name = module_name 27 | self.__str__ = module_name 28 | self.__path__ = [] 29 | 30 | module_paths = (glob.glob("./" + module_name + ".so") 31 | + glob.glob("./" + module_name + ".dylib") 32 | + glob.glob("./libHS" + module_name + "*.so") 33 | + glob.glob("./libHS" + module_name + "*.dylib")) 34 | if not module_paths: 35 | raise RuntimeError("Haskell module '" + module_name + "' not found!") 36 | module_path = module_paths[0] 37 | self.__lib = cdll.LoadLibrary(module_path) 38 | self.__funcs = {} 39 | self.__ftype_map = { "Bool" : c_bool 40 | , "Char" : c_char 41 | , "Int" : c_int 42 | , "Double" : c_double 43 | } 44 | self.__free = self.__lib["free"] 45 | self.__free.argtypes = [c_void_p] 46 | self.__free.restype = None 47 | 48 | def __getattr__(self, name): 49 | def fun(*args): 50 | return self.__call_function(name, *args) 51 | return fun 52 | 53 | def __get_types(self, info_str): 54 | def convert_type(type_str): 55 | container_strs = type_str.split() 56 | basic_type_str = container_strs.pop() 57 | basic_type = self.__ftype_map.get(basic_type_str) 58 | if not basic_type: 59 | raise TypeError("Unknown type: " + basic_type_str) 60 | # Lists are currently the only supported container 61 | for c in container_strs: 62 | if c != "List": 63 | raise TypeError("Unknown container type: " + c) 64 | if not container_strs: 65 | return SimpleType(basic_type) 66 | else: 67 | return ListType(basic_type, len(container_strs), self.__free) 68 | 69 | types = info_str.split(";") 70 | types = map(convert_type, types) 71 | return_type = types.pop() 72 | return (types, return_type) 73 | 74 | def __func_info(self, name): 75 | info = HaskellFunction(self.__lib[name + "__info"], 76 | [], 77 | ListType(c_char, 1, self.__free)) 78 | return self.__get_types(info()) 79 | 80 | def __init_function(self, name): 81 | func = self.__lib[name + "__export"] 82 | arg_types, ret_type = self.__func_info(name) 83 | return HaskellFunction(func, arg_types, ret_type) 84 | 85 | def __call_function(self, name, *args): 86 | if name not in self.__funcs: 87 | self.__funcs[name] = self.__init_function(name) 88 | return self.__funcs[name](*args) 89 | 90 | class HaskellFunction: 91 | def __init__(self, func, arg_types, ret_type): 92 | func.argtypes = map(lambda t: t.ctype(), arg_types) 93 | func.restype = ret_type.ctype() 94 | 95 | self.__func = func 96 | self.__arg_types = arg_types 97 | self.__ret_type = ret_type 98 | 99 | def __call__(self, *args): 100 | if len(args) != len(self.__arg_types): 101 | raise TypeError("this function takes exactly " 102 | + str(len(func.argtypes)) 103 | + " arguments (" + str(len(args)) + " given)") 104 | conv_args = [t.convert_arg(a) for (t, a) in zip(self.__arg_types, args)] 105 | ret = self.__func(*conv_args) 106 | return self.__ret_type.convert_ret(ret) 107 | 108 | __path__ = [] 109 | sys.meta_path.append(HaPyImporter()) 110 | 111 | 112 | def list_struct_t(typ, length): 113 | class ListStruct(Structure): 114 | _fields_ = [ ("length", c_int) 115 | , ("array", typ * length) 116 | ] 117 | return ListStruct 118 | 119 | def extract_array(struct, typ): 120 | length = cast(struct, POINTER(c_int)).contents.value 121 | if typ == c_char: 122 | # handle strings separately because otherwise they'll be NULL terminated 123 | # (which isn't correct in this case as we have the exact length) 124 | contents = string_at(struct + sizeof(c_int), length) 125 | else: 126 | contents = cast(struct, POINTER(list_struct_t(typ, length))).contents.array 127 | return contents 128 | 129 | def list_to_struct(lst, depth, base_type): 130 | length = len(lst) 131 | StructT = list_struct_t(base_type if depth == 1 else c_void_p, length) 132 | struct = StructT() 133 | struct.length = length 134 | if depth == 1: 135 | # For reasons unknown, ctypes changes arrays of c_chars into strings when 136 | # they're in structs. Strings are immutable, so we cannot assign to their 137 | # indices: we replace them whole instead. Furthermore, we need to copy 138 | # the string byte for byte - otherwise NULL characters will cause the string 139 | # copy to terminate early. 140 | if base_type == c_char: 141 | memmove(byref(struct, sizeof(c_int)), create_string_buffer(lst, length), length) 142 | else: 143 | for i in range(length): 144 | struct.array[i] = lst[i] 145 | else: 146 | for i in range(length): 147 | struct.array[i] = cast(list_to_struct(lst[i], depth - 1, base_type), c_void_p) 148 | return pointer(struct) 149 | 150 | def struct_to_list(struct, depth, base_type): 151 | if depth == 1: 152 | return list(extract_array(struct, base_type)) 153 | else: 154 | return map(lambda s: struct_to_list(s, depth - 1, base_type), 155 | extract_array(struct, c_void_p)) 156 | 157 | def free_struct(struct, depth, free): 158 | if depth == 1: 159 | free(struct) 160 | else: 161 | for s in extract_array(struct, c_void_p): 162 | free_struct(s, depth - 1, free) 163 | free(struct) 164 | 165 | class SimpleType: 166 | def __init__(self, typ): 167 | self.__type = typ 168 | 169 | def ctype(self): 170 | return self.__type 171 | 172 | def convert_arg(self, arg): 173 | return arg 174 | 175 | def convert_ret(self, ret): 176 | return ret 177 | 178 | class ListType: 179 | def __init__(self, base_type, depth, free): 180 | self.__base_type = base_type 181 | self.__depth = depth 182 | self.__free = free 183 | 184 | def ctype(self): 185 | return c_void_p 186 | 187 | def convert_arg(self, arg): 188 | return list_to_struct(arg, self.__depth, self.__base_type) 189 | 190 | def convert_ret(self, ret_struct): 191 | ret = struct_to_list(ret_struct, self.__depth, self.__base_type) 192 | free_struct(ret_struct, self.__depth, self.__free) 193 | if self.__base_type == c_char and self.__depth >= 1: 194 | return self.__fix_string_list(ret) 195 | else: 196 | return ret 197 | 198 | def __fix_string_list(self, lst): 199 | def wrap(f): 200 | return lambda x: map(f, x) 201 | def conv(lst): 202 | return "".join(lst) 203 | c = conv 204 | for i in range(self.__depth - 1): 205 | c = wrap(c) 206 | return c(lst) 207 | --------------------------------------------------------------------------------