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"
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!"
toTypeList :: Type -> [Type]
toTypeList (AppT (AppT ArrowT t) ts) = t : toTypeList ts
toTypeList t = [t]
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