HaPy (empty) → 0.1.1.0

raw patch · 6 files changed

+223/−0 lines, 6 filesdep +basedep +template-haskelldep +th-liftsetup-changed

Dependencies added: base, template-haskell, th-lift

Files

Foreign/HaPy.hs +135/−0
Foreign/HaPy/Internal.hs +43/−0
HaPy.cabal +21/−0
HaPy_init.c +15/−0
LICENSE +7/−0
Setup.hs +2/−0

+ Foreign/HaPy.hs view

@@ -0,0 +1,135 @@+module Foreign.HaPy (+    initHaPy,+    pythonExport,+    __exportInfo,+    module Foreign.C+) where++import Foreign.HaPy.Internal ( peekList, copyList )+import Language.Haskell.TH+import Language.Haskell.TH.Syntax ( Lift(lift) )+import Language.Haskell.TH.Lift ( deriveLift )++import Foreign.C+    ( CInt(..),+      CDouble(..),+      CChar(..),+      castCharToCChar,+      castCCharToChar )+import Foreign.Ptr ( Ptr )+import Foreign.Marshal.Array ()+import Foreign.Marshal.Alloc ( free )++import Data.List ( intercalate )+import Control.Monad ( zipWithM, replicateM, ap )++data FType = FBool | FChar | FInt | FDouble | FList FType | FUnknown+  deriving (Eq, Ord, Show)++deriveLift ''FType++__exportInfo :: [FType] -> IO (Ptr [CChar])+__exportInfo ftypes = copyList $ map castCharToCChar typeString+  where typeString = intercalate ";" $ map toTypeString ftypes+        toTypeString (FList t) = "List " ++ toTypeString t+        toTypeString FBool     = "Bool"+        toTypeString FChar     = "Char"+        toTypeString FInt      = "Int"+        toTypeString FDouble   = "Double"+        toTypeString _         = "Unknown"+++-- Can't use e.g. ''Bool when pattern matching+fromHaskellType :: Type -> FType+fromHaskellType (ConT nm) | nm == ''Bool   = FBool+                          | nm == ''Char   = FChar+                          | nm == ''Int    = FInt+                          | nm == ''Double = FDouble+                          | nm == ''String = FList FChar+fromHaskellType (AppT ListT t) = FList (fromHaskellType t)+fromHaskellType _ = FUnknown++toForeignType :: FType -> Bool -> TypeQ+toForeignType t ret | ret       = [t| IO $(toF t) |]+                    | otherwise = toF t+  where toF FBool     = [t| Bool |]+        toF FChar     = [t| CChar |]+        toF FInt      = [t| CInt |]+        toF FDouble   = [t| CDouble |]+        toF (FList t) = [t| Ptr [$(toF t)] |]+        toF _         = error "unknown type - cannot convert!" -- TODO: catch error at an earlier stage+++-- Converts the type of a function to a list of the type of its args and return value+toTypeList :: Type -> [Type]+toTypeList (AppT (AppT ArrowT t) ts) = t : toTypeList ts+toTypeList t                         = [t]++-- Converts the a list of the types of a function's args and return value to the type of a function+fromTypeList :: [Type] -> Type+fromTypeList []     = error "type list empty!"+fromTypeList (t:[]) = t+fromTypeList (t:ts) = (AppT (AppT ArrowT t) (fromTypeList ts))+++fromForeignExp :: FType -> ExpQ -> ExpQ+fromForeignExp FBool     exp = [| return $ $exp |]+fromForeignExp FChar     exp = [| return $ castCCharToChar $exp |]+fromForeignExp FInt      exp = [| return $ fromIntegral $exp |]+fromForeignExp FDouble   exp = [| return $ realToFrac $exp |]+fromForeignExp (FList t) exp = [| peekList $exp >>= mapM (\x -> $(fromForeignExp t [|x|])) |]+fromForeignExp _         exp = fail "conversion failed: unknown type!"++toForeignExp :: FType -> ExpQ -> ExpQ+toForeignExp FBool     exp = [| return $ $exp |]+toForeignExp FChar     exp = [| return $ castCharToCChar $exp |]+toForeignExp FInt      exp = [| return $ fromIntegral $exp |]+toForeignExp FDouble   exp = [| return $ realToFrac $exp |]+toForeignExp (FList t) exp = [| mapM (\x -> $(toForeignExp t [|x|])) $exp >>= copyList |]+toForeignExp _         exp = fail "conversion failed: unknown type!"++makeFunction :: (String -> String) -> (Name -> [FType] -> ClauseQ) -> ([FType] -> TypeQ) -> Name -> DecsQ+makeFunction changeName makeClause makeType origName = do+  VarI _ t _ _ <- reify origName+  let types = map fromHaskellType $ toTypeList t+      name = mkName . changeName . nameBase $  origName+      cl   = makeClause origName types+      func = funD name [cl]++      typ  = makeType types+      dec = ForeignD `fmap` ExportF CCall (nameBase name) name `fmap` typ+  sequence [func, dec]++makeInfoFunction :: Name -> DecsQ+makeInfoFunction name = makeFunction makeName makeClause (const [t| IO (Ptr [CChar]) |]) name+    where makeName = (++ "__info")+          makeClause _ types = let body = normalB $ [| __exportInfo $(lift types) |] in+                                clause [] body []+++makeExportFunction :: Name -> DecsQ+makeExportFunction = makeFunction makeName makeClause makeType+    where makeName = (++ "__export")+          makeType ts = fmap fromTypeList $ zipWithM toForeignType ts (replicate (length ts - 1) False ++ [True])+          makeClause nm types = do+              vars <- replicateM (length types - 1) (newName "x")+              let args = map varP vars+                  convertedArgs = zipWith fromForeignExp types (map varE vars)+                  appliedFunction = foldl apArg [|return $(varE nm)|] convertedArgs+                  body = normalB $ [| $appliedFunction >>= \x -> $(toForeignExp (last types) [|x|]) |]+              clause args body []+          apArg :: ExpQ -> ExpQ -> ExpQ+          apArg f arg = [| ap $f $arg |]++pythonExport :: Name -> DecsQ+pythonExport nm = do+  info <- makeInfoFunction nm+  export <- makeExportFunction nm+  return $ info ++ export++initHaPy :: DecsQ+initHaPy = do+  exportType <- [t| Ptr () -> IO () |]+  let export = ForeignD $ ExportF CCall "__free" (mkName "__free") exportType+  func <- [d| __free = free |]+  return $ export:func

+ Foreign/HaPy/Internal.hs view

@@ -0,0 +1,43 @@+module Foreign.HaPy.Internal (+  sizeOfList,+  peekList,+  pokeList,+  copyList+) where++import Foreign.C ( CInt )+import Foreign.Marshal.Array ( pokeArray, peekArray )+import Foreign.Marshal.Alloc ( mallocBytes )+import Foreign.Storable ( Storable(..) )+import Foreign.Ptr ( Ptr, plusPtr, castPtr, alignPtr )++cInt :: CInt+cInt = undefined++lenPtr :: Storable a => Ptr [a] -> Ptr CInt+lenPtr = castPtr++arrPtr :: Storable a => Ptr [a] -> Ptr a+arrPtr ptr = castPtr $ (ptr `plusPtr` sizeOf cInt) `alignPtr` alignment (ptrElem ptr)+  where ptrElem :: Ptr [a] -> a+        ptrElem = undefined++sizeOfList :: Storable a => [a] -> Int+sizeOfList xs = alignedIntSize + length xs * sizeOf (head xs)+  where alignedIntSize = max (sizeOf cInt) (alignment $ head xs)++peekList :: Storable a => Ptr [a] -> IO [a]+peekList ptr = do+  len <- peek $ lenPtr ptr+  peekArray (fromIntegral len) $ arrPtr ptr++pokeList :: Storable a => Ptr [a] -> [a] -> IO ()+pokeList ptr xs = do+  poke (lenPtr ptr) (fromIntegral $ length xs)+  pokeArray (arrPtr ptr) xs++copyList :: Storable a => [a] -> IO (Ptr [a])+copyList xs = do+  ptr <- mallocBytes $ sizeOfList xs+  pokeList ptr xs+  return ptr

+ HaPy.cabal view

@@ -0,0 +1,21 @@+name:                HaPy+version:             0.1.1.0+synopsis:            Haskell bindings for Python+description:         Call Haskell functions from Python!+homepage:            https://github.com/sakana/HaPy+license:             MIT+license-file:        LICENSE+author:              David Fisher+maintainer:          ddf1991@gmail.com+category:            Foreign+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     +      Foreign.HaPy+  other-modules:+      Foreign.HaPy.Internal+  extensions: TemplateHaskell+  c-sources:           HaPy_init.c+  build-depends:       base >=4.5 && < 4.8, th-lift ==0.5.*, template-haskell >=2.7.0.0

+ HaPy_init.c view

@@ -0,0 +1,15 @@+#include "HsFFI.h"++static void initialize() __attribute__((constructor));+static void initialize() {+	static char *argv[] = {"HaPy", 0};+	static char **argv_ = argv;+	static int argc = 1;+	+	hs_init(&argc, &argv_);+}++static void finalize() __attribute__((destructor));+static void finalize() {+    hs_exit();+}

+ LICENSE view

@@ -0,0 +1,7 @@+Copyright (C) 2013 David Fisher++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.

+ Setup.hs view

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