module Foreign.Hoppy.Generator.Spec.Callback (
Callback, callbackT,
makeCallback,
callbackExtName,
callbackParams,
callbackReturn,
callbackReqs,
callbackAddendum,
callbackThrows,
callbackSetThrows,
cppCallbackToTFn,
callbackClassName,
callbackImplClassName,
callbackFnName,
hsCallbackToTFn,
toHsCallbackCtorName, toHsCallbackCtorName',
toHsCallbackNewFunPtrFnName, toHsCallbackNewFunPtrFnName',
) where
import Control.Monad (forM_, when)
import Data.Function (on)
import Data.Maybe (fromMaybe, isJust)
import qualified Foreign.Hoppy.Generator.Language.Cpp as LC
import qualified Foreign.Hoppy.Generator.Language.Haskell as LH
import Foreign.Hoppy.Generator.Spec.Base
import qualified Foreign.Hoppy.Generator.Spec.Function as Function
import Foreign.Hoppy.Generator.Types (boolT, constT, fnT, fnT', intT, manualT, ptrT, voidT)
import Language.Haskell.Syntax (
HsName (HsIdent),
HsQName (Special, UnQual),
HsSpecialCon (HsUnitCon),
HsType (HsTyApp, HsTyCon, HsTyFun),
)
data Callback = Callback
{ callbackExtName :: ExtName
, callbackParams :: [Parameter]
, callbackReturn :: Type
, callbackThrows :: Maybe Bool
, callbackReqs :: Reqs
, callbackAddendum :: Addendum
}
instance Eq Callback where
(==) = (==) `on` callbackExtName
instance Show Callback where
show cb =
concat ["<Callback ", show (callbackExtName cb), " ", show (callbackParams cb), " ",
show (callbackReturn cb)]
instance Exportable Callback where
sayExportCpp = sayCppExport
sayExportHaskell = sayHsExport
instance HasExtNames Callback where
getPrimaryExtName = callbackExtName
instance HasReqs Callback where
getReqs = callbackReqs
setReqs reqs cb = cb { callbackReqs = reqs }
instance HasAddendum Callback where
getAddendum = callbackAddendum
setAddendum addendum cb = cb { callbackAddendum = addendum }
makeCallback :: IsParameter p
=> ExtName
-> [p]
-> Type
-> Callback
makeCallback extName paramTypes retType =
Callback extName (toParameters paramTypes) retType Nothing mempty mempty
callbackSetThrows :: Bool -> Callback -> Callback
callbackSetThrows value cb = cb { callbackThrows = Just value }
makeConversion :: Callback -> ConversionSpec
makeConversion cb =
(makeConversionSpec (show cb) cpp)
{ conversionSpecHaskell = hs }
where reqsGen = do
cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$>
LC.findExportModule (callbackExtName cb)
fnTypeReqs <- LC.typeReqs =<< cppCallbackToTFn cb
return $ cbClassReqs `mappend` fnTypeReqs
cpp =
(makeConversionSpecCpp (callbackClassName cb) reqsGen)
{ conversionSpecCppConversionType = return $ Just $ ptrT callbackImplClassType
, conversionSpecCppConversionToCppExpr = Just $ \fromVar maybeToVar -> case maybeToVar of
Just toVar ->
LC.says [callbackClassName cb, " "] >> toVar >> LC.say "(" >>
fromVar >> LC.say ");\n"
Nothing -> LC.says [callbackClassName cb, "("] >> fromVar >> LC.say ")"
}
hs =
Just $ makeConversionSpecHaskell
(LH.cppTypeToHsTypeAndUse LH.HsHsSide =<< hsCallbackToTFn LH.HsHsSide cb)
(Just $ do
LH.addImports hsImportForRuntime
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") <$>
(LH.cppTypeToHsTypeAndUse LH.HsCSide =<< hsCallbackToTFn LH.HsCSide cb))
(CustomConversion $ LH.sayLn =<< toHsCallbackCtorName cb)
ConversionUnsupported
callbackImplClassType =
manualT $
makeConversionSpec implClass $
makeConversionSpecCpp implClass reqsGen
implClass = callbackImplClassName cb
callbackT :: Callback -> Type
callbackT = manualT . makeConversion
callbackClassName :: Callback -> String
callbackClassName = fromExtName . callbackExtName
callbackImplClassName :: Callback -> String
callbackImplClassName = (++ "_impl") . fromExtName . callbackExtName
callbackFnName :: Callback -> String
callbackFnName = LC.externalNameToCpp . callbackExtName
sayCppExport :: LC.SayExportMode -> Callback -> LC.Generator ()
sayCppExport mode cb = do
throws <- cppGetEffectiveCallbackThrows cb
let className = callbackClassName cb
implClassName = callbackImplClassName cb
fnName = callbackFnName cb
params = callbackParams cb
paramTypes = map parameterType params
paramCount = length params
retType = callbackReturn cb
fnType = fnT' params retType
paramCTypes <- zipWith fromMaybe paramTypes <$> mapM LC.typeToCType paramTypes
retCType <- fromMaybe retType <$> LC.typeToCType retType
LC.addReqsM . mconcat . (callbackReqs cb:) =<< mapM LC.typeReqs (retType:paramTypes)
let fnCType = fnT ((if throws then (++ [ptrT intT, ptrT $ ptrT voidT]) else id)
paramCTypes)
retCType
fnPtrCType = ptrT fnCType
case mode of
LC.SayHeader -> do
(sharedPtrReqs, sharedPtrStr) <- interfaceSharedPtr <$> LC.askInterface
LC.addReqsM sharedPtrReqs
LC.says ["\nclass ", implClassName, " {\n"]
LC.say "public:\n"
LC.says [" explicit ", implClassName, "("] >> LC.sayType Nothing fnPtrCType >>
LC.say ", void(*)(void(*)()), bool);\n"
LC.says [" ~", implClassName, "();\n"]
LC.say " " >> LC.sayVar "operator()" Nothing fnType >> LC.say ";\n"
LC.say "private:\n"
LC.says [" ", implClassName, "(const ", implClassName, "&);\n"]
LC.says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"]
LC.say "\n"
LC.say " " >> LC.sayVar "f_" Nothing (constT fnPtrCType) >> LC.say ";\n"
LC.say " void (*const release_)(void(*)());\n"
LC.say " const bool releaseRelease_;\n"
LC.say "};\n"
LC.says ["\nclass ", className, " {\n"]
LC.say "public:\n"
LC.says [" ", className, "() {}\n"]
LC.says [" explicit ", className, "(", implClassName, "* impl) : impl_(impl) {}\n"]
LC.say " " >> LC.sayVar "operator()" Nothing fnType >> LC.say ";\n"
LC.say " operator bool() const;\n"
LC.say "private:\n"
LC.says [" ", sharedPtrStr, "<", implClassName, "> impl_;\n"]
LC.say "};\n"
LC.SaySource -> do
LC.says ["\n", implClassName, "::", implClassName, "("] >> LC.sayVar "f" Nothing fnPtrCType >>
LC.say ", void (*release)(void(*)()), bool releaseRelease) :\n"
LC.say " f_(f), release_(release), releaseRelease_(releaseRelease) {}\n"
LC.says ["\n", implClassName, "::~", implClassName, "() {\n"]
LC.say " if (release_) {\n"
LC.say " release_(reinterpret_cast<void(*)()>(f_));\n"
LC.say " if (releaseRelease_) {\n"
LC.say " release_(reinterpret_cast<void(*)()>(release_));\n"
LC.say " }\n"
LC.say " }\n"
LC.say "}\n"
paramCTypeMaybes <- mapM LC.typeToCType paramTypes
retCTypeMaybe <- LC.typeToCType retType
LC.sayFunction (implClassName ++ "::operator()")
(zipWith3 (\pt ctm ->
let hasConversion = case pt of
Internal_TManual s ->
isJust $ conversionSpecCppConversionToCppExpr $
conversionSpecCpp s
_ -> isJust ctm
in if hasConversion then LC.toArgNameAlt else LC.toArgName)
paramTypes
paramCTypeMaybes
[1..paramCount])
fnType $ Just $ do
mapM_ (Function.sayCppArgRead Function.FromCpp) $
zip3 [1..] paramTypes paramCTypeMaybes
when throws $ do
LC.says ["int ", LC.exceptionIdArgName, " = 0;\n"]
LC.says ["void *", LC.exceptionPtrArgName, " = 0;\n"]
iface <- LC.askInterface
currentModule <- LC.askModule
case interfaceExceptionSupportModule iface of
Just exceptionSupportModule ->
when (exceptionSupportModule /= currentModule) $
LC.addReqsM $ reqInclude $ includeLocal $ moduleHppPath exceptionSupportModule
Nothing -> LC.abort $ "sayExportCallback: " ++ show iface ++
" uses exceptions, so it needs an exception support " ++
"module. Please use interfaceSetExceptionSupportModule."
let
sayCall :: LC.Generator ()
sayCall = do
LC.say "f_("
Function.sayCppArgNames paramCount
when throws $ do
when (paramCount /= 0) $ LC.say ", "
LC.says ["&", LC.exceptionIdArgName, ", &", LC.exceptionPtrArgName]
LC.say ")"
sayExceptionCheck :: LC.Generator ()
sayExceptionCheck = when throws $ do
LC.says ["if (", LC.exceptionIdArgName, " != 0) { ",
LC.exceptionRethrowFnName, "(", LC.exceptionIdArgName, ", ",
LC.exceptionPtrArgName, "); }\n"]
case (retType, retCTypeMaybe) of
(Internal_TVoid, Nothing) -> do
sayCall >> LC.say ";\n"
sayExceptionCheck
(_, Nothing) -> do
LC.sayVar "result" Nothing retType >> LC.say " = " >> sayCall >> LC.say ";\n"
sayExceptionCheck
LC.say "return result;\n"
(Internal_TObj cls1,
Just retCType'@(Internal_TPtr (Internal_TConst (Internal_TObj cls2))))
| cls1 == cls2 -> do
LC.sayVar "resultPtr" Nothing retCType' >> LC.say " = " >> sayCall >> LC.say ";\n"
sayExceptionCheck
LC.sayVar "result" Nothing retType >> LC.say " = *resultPtr;\n"
LC.say "delete resultPtr;\n"
LC.say "return result;\n"
(Internal_TRef (Internal_TConst (Internal_TObj cls1)),
Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do
LC.sayVar "resultPtr" Nothing retCType >> LC.say " = " >> sayCall >> LC.say ";\n"
sayExceptionCheck
LC.say "return *resultPtr;\n"
(Internal_TRef (Internal_TObj cls1),
Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do
LC.sayVar "resultPtr" Nothing retCType >> LC.say " = " >> sayCall >> LC.say ";\n"
sayExceptionCheck
LC.say "return *resultPtr;\n"
ts -> LC.abort $ concat
["sayExportCallback: Unexpected return types ", show ts, "."]
LC.sayFunction (className ++ "::operator()")
(map LC.toArgName [1..paramCount])
fnType $ Just $ do
case retType of
Internal_TVoid -> LC.say "(*impl_)("
_ -> LC.say "return (*impl_)("
Function.sayCppArgNames paramCount
LC.say ");\n"
LC.says [className, "::operator bool() const {\n"]
LC.say "return static_cast<bool>(impl_);\n"
LC.say "}\n"
let newCallbackFnType = fnT [ fnPtrCType
, ptrT (fnT [ptrT $ fnT [] voidT] voidT)
, boolT
] $
Internal_TManual $
makeConversionSpec ("<Internal " ++ implClassName ++ " pointer>") $
makeConversionSpecCpp (implClassName ++ "*") (return mempty)
LC.sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $
LC.says ["return new ", implClassName, "(f, release, releaseRelease);\n"]
sayHsExport :: LH.SayExportMode -> Callback -> LH.Generator ()
sayHsExport mode cb =
LH.withErrorContext ("generating callback " ++ show (callbackExtName cb)) $ do
let name = callbackExtName cb
params = callbackParams cb
retType = callbackReturn cb
hsNewFunPtrFnName <- toHsCallbackNewFunPtrFnName cb
hsCtorName <- toHsCallbackCtorName cb
let hsCtorName'newCallback = hsCtorName ++ "'newCallback"
hsCtorName'newFunPtr = hsCtorName ++ "'newFunPtr"
hsFnCType <- LH.cppTypeToHsTypeAndUse LH.HsCSide =<< hsCallbackToTFn LH.HsCSide cb
hsFnHsType <- LH.cppTypeToHsTypeAndUse LH.HsHsSide =<< hsCallbackToTFn LH.HsHsSide cb
let getWholeNewFunPtrFnType = do
LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude]
return $
HsTyFun hsFnHsType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType
getWholeCtorType = do
LH.addImports $ mconcat [hsImportForPrelude, hsImportForRuntime]
return $
HsTyFun hsFnHsType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType
case mode of
LH.SayExportForeignImports -> do
LH.addImports $ mconcat [hsImportForForeign, hsImportForPrelude, hsImportForRuntime]
let hsFunPtrType = HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") hsFnCType
hsFunPtrImportType =
HsTyFun hsFnCType $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") hsFunPtrType
hsCallbackCtorImportType =
HsTyFun hsFunPtrType $
HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $
HsTyFun (HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyF.FunPtr") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyCon $ Special HsUnitCon) $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyCon $ Special HsUnitCon) $
HsTyFun (HsTyCon $ UnQual $ HsIdent "HoppyP.Bool") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyP.IO") $
HsTyApp (HsTyCon $ UnQual $ HsIdent "HoppyFHR.CCallback") hsFnCType
LH.saysLn ["foreign import ccall \"wrapper\" ", hsCtorName'newFunPtr, " :: ",
LH.prettyPrint hsFunPtrImportType]
LH.saysLn ["foreign import ccall \"", LC.externalNameToCpp name, "\" ",
hsCtorName'newCallback, " :: ", LH.prettyPrint hsCallbackCtorImportType]
LH.SayExportDecls -> do
LH.addExports [hsNewFunPtrFnName, hsCtorName]
wholeNewFunPtrFnType <- getWholeNewFunPtrFnType
let paramCount = length params
argNames = map LH.toArgName [1..paramCount]
argNames' = map (++ "'") argNames
throws <- hsGetEffectiveCallbackThrows cb
LH.addImports $ mconcat [hsImport1 "Prelude" "($)",
hsImportForRuntime]
LH.ln
LH.saysLn [hsNewFunPtrFnName, " :: ", LH.prettyPrint wholeNewFunPtrFnType]
LH.saysLn $ hsNewFunPtrFnName : " f'hs = " : hsCtorName'newFunPtr : " $" :
case (if throws then (++ ["excIdPtr", "excPtrPtr"]) else id) argNames of
[] -> []
argNames'' -> [" \\", unwords argNames'', " ->"]
LH.indent $ do
when throws $ LH.sayLn "HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $"
forM_ (zip3 params argNames argNames') $ \(p, argName, argName') ->
Function.sayHsArgProcessing Function.FromCpp (parameterType p) argName argName'
Function.sayHsCallAndProcessReturn Function.FromCpp retType $
"f'hs" : map (' ':) argNames'
wholeCtorType <- getWholeCtorType
LH.ln
LH.saysLn [hsCtorName, " :: ", LH.prettyPrint wholeCtorType]
LH.saysLn [hsCtorName, " f'hs = do"]
LH.indent $ do
LH.saysLn ["f'p <- ", hsNewFunPtrFnName, " f'hs"]
LH.saysLn [hsCtorName'newCallback, " f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]
LH.SayExportBoot -> do
LH.addExports [hsNewFunPtrFnName, hsCtorName]
wholeNewFunPtrFnType <- getWholeNewFunPtrFnType
wholeCtorType <- getWholeCtorType
LH.ln
LH.saysLn [hsNewFunPtrFnName, " :: ", LH.prettyPrint wholeNewFunPtrFnType]
LH.ln
LH.saysLn [hsCtorName, " :: ", LH.prettyPrint wholeCtorType]
toHsCallbackCtorName :: Callback -> LH.Generator String
toHsCallbackCtorName callback =
LH.inFunction "toHsCallbackCtorName" $
LH.addExtNameModule (callbackExtName callback) $ toHsCallbackCtorName' callback
toHsCallbackCtorName' :: Callback -> String
toHsCallbackCtorName' callback =
LH.toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_new"
toHsCallbackNewFunPtrFnName :: Callback -> LH.Generator String
toHsCallbackNewFunPtrFnName callback =
LH.inFunction "toHsCallbackNewFunPtrFnName" $
LH.addExtNameModule (callbackExtName callback) $ toHsCallbackNewFunPtrFnName' callback
toHsCallbackNewFunPtrFnName' :: Callback -> String
toHsCallbackNewFunPtrFnName' callback =
LH.toHsFnName' $ toExtName $ fromExtName (callbackExtName callback) ++ "_newFunPtr"
cppGetEffectiveCallbackThrows :: Callback -> LC.Generator Bool
cppGetEffectiveCallbackThrows cb = case callbackThrows cb of
Just b -> return b
Nothing -> moduleCallbacksThrow <$> LC.askModule >>= \case
Just b -> return b
Nothing -> interfaceCallbacksThrow <$> LC.askInterface
hsGetEffectiveCallbackThrows :: Callback -> LH.Generator Bool
hsGetEffectiveCallbackThrows cb = case callbackThrows cb of
Just b -> return b
Nothing -> moduleCallbacksThrow <$> LH.askModule >>= \case
Just b -> return b
Nothing -> interfaceCallbacksThrow <$> LH.askInterface
cppCallbackToTFn :: Callback -> LC.Generator Type
cppCallbackToTFn cb = do
throws <- mayThrow
return $ Internal_TFn ((if throws then addExcParams else id) $ callbackParams cb)
(callbackReturn cb)
where mayThrow = case callbackThrows cb of
Just t -> return t
Nothing -> moduleCallbacksThrow <$> LC.askModule >>= \mt -> case mt of
Just t -> return t
Nothing -> interfaceCallbacksThrow <$> LC.askInterface
addExcParams = (++ [toParameter $ ptrT intT, toParameter $ ptrT $ ptrT voidT])
hsCallbackToTFn :: LH.HsTypeSide -> Callback -> LH.Generator Type
hsCallbackToTFn side cb = do
needsExcParams <- case side of
LH.HsCSide -> mayThrow
LH.HsHsSide -> return False
return $ Internal_TFn ((if needsExcParams then addExcParams else id) $ callbackParams cb)
(callbackReturn cb)
where mayThrow = case callbackThrows cb of
Just t -> return t
Nothing -> moduleCallbacksThrow <$> LH.askModule >>= \mt -> case mt of
Just t -> return t
Nothing -> interfaceCallbacksThrow <$> LH.askInterface
addExcParams = (++ [toParameter $ ptrT intT, toParameter $ ptrT $ ptrT voidT])