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