-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- | Interface for defining foreign language callbacks.
module Foreign.Hoppy.Generator.Spec.Callback (
  -- * Data type
  Callback, callbackT,
  -- * Construction
  makeCallback,
  -- * Properties
  callbackExtName,
  callbackParams,
  callbackReturn,
  callbackReqs,
  callbackAddendum,
  -- ** Exceptions
  callbackThrows,
  callbackSetThrows,
  -- * C++ generator
  cppCallbackToTFn,
  -- ** Names
  callbackClassName,
  callbackImplClassName,
  callbackFnName,
  -- * Haskell generator
  hsCallbackToTFn,
  -- ** Names
  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),
  )

-- | A non-C++ function that can be invoked via a C++ functor or function
-- pointer.
--
-- Use this data type's 'HasReqs' instance to add extra requirements, however
-- manually adding requirements for parameter and return types is not necessary.
data Callback = Callback
  { Callback -> ExtName
callbackExtName :: ExtName
    -- ^ The callback's external name.
  , Callback -> [Parameter]
callbackParams :: [Parameter]
    -- ^ The callback's parameters.
  , Callback -> Type
callbackReturn :: Type
    -- ^ The callback's return type.
  , Callback -> Maybe Bool
callbackThrows :: Maybe Bool
    -- ^ Whether the callback supports throwing C++ exceptions from Haskell into
    -- C++ during its execution.  When absent, the value is inherited from
    -- 'moduleCallbacksThrow' and 'interfaceCallbacksThrow'.
  , Callback -> Reqs
callbackReqs :: Reqs
    -- ^ Extra requirements for the callback.
  , Callback -> Addendum
callbackAddendum :: Addendum
    -- ^ The callback's 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 }

-- | Creates a binding for constructing callbacks into foreign code.
makeCallback :: IsParameter p
             => ExtName
             -> [p]  -- ^ Parameter types.
             -> Type  -- ^ Return 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

-- | Sets whether a callback supports handling thrown C++ exceptions and passing
-- them into C++.
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
          -- TODO Should this be includeStd?
          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)
          -- TODO Is the right 'ReqsType' being used recursively here?
          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
")"
            -- No from-C++ conversion; we don't support passing callbacks back out again.
          }

        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  -- Can't receive a callback from C++.

        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

-- | Constructs a type value for a callback.
callbackT :: Callback -> Type
-- (Keep docs in sync with hs-boot.)
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

-- | Returns the name of the outer, copyable C++ class for a callback.
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

-- | Returns the name of the internal, non-copyable implementation C++ class for
-- a callback.
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

-- | Returns the name of the C++ binding function that creates a C++ callback
-- wrapper object from a function pointer to foreign code.
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

  -- The function pointer we receive from foreign code will work with C-types,
  -- so determine what that function looks like.
  [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

  -- Add requirements specified manually by the callback, and for its parameter
  -- and return types.
  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
      -- Render the class declarations into the header file.
      (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
      -- Render the classes' methods into the source file.  First render the
      -- impl class's constructor.
      [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"

      -- Then render the destructor.
      [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"

      -- Render the impl operator() method, which does argument decoding and
      -- return value encoding and passes C++ values to underlying function
      -- poiner.
      --
      -- TODO Abstract the duplicated code here and in sayExportFn.
      [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 ->
                                  -- TManual needs special handling to determine whether a
                                  -- conversion is necessary.  'typeToCType' doesn't suffice
                                  -- because for TManual this check relies on the direction of
                                  -- the call.  See the special case in 'sayCppArgRead' as
                                  -- well.
                                  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
        -- Convert arguments that aren't passed in directly.
        ((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"]

          -- Add an include for the exception support module to be able to call the
          -- C++ rethrow function.
          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
$
                -- TODO Should this be includeStd?
                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."

        -- Invoke the function pointer into foreign code.
        let -- | Generates the call to the foreign language function pointer.
            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
")"

            -- | Generates code to check whether an exception was thrown by the
            -- callback, and rethrows it in C++ if so.
            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
"."]

      -- Render the non-impl operator() method, which simply passes C++ values
      -- along to the impl object.
      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"

      -- Render "operator bool", which detects whether the callback was not
      -- default-constructed with no actual impl object.
      [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"

      -- Render the function that creates a new callback object.
      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"]

-- | Prints \"foreign import\" statements and an internal callback construction
-- function for a given 'Callback' specification.  For example, for a callback
-- of 'LH.HsHsSide' type @Int -> String -> IO Int@, we will generate the
-- following bindings:
--
-- > foreign import ccall "wrapper" name'newFunPtr
-- >   :: (CInt -> Ptr CChar -> IO CInt)
-- >   -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt))
-- >
-- > -- (This is an ad-hoc generated binding for C++ callback impl class constructor.)
-- > foreign import ccall "genpop__name_impl" name'newCallback
-- >   :: FunPtr (CInt -> Ptr CChar -> IO CInt)
-- >   -> FunPtr (FunPtr (IO ()) -> IO ())
-- >   -> Bool
-- >   -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))
-- >
-- > name_newFunPtr :: (Int -> String -> IO Int) -> IO (FunPtr (CInt -> Ptr CChar -> IO CInt))
-- > name_newFunPtr f'hs = name'newFunPtr $ \excIdPtr excPtrPtr arg1 arg2 ->
-- >   internalHandleCallbackExceptions excIdPtr excPtrPtr $
-- >   coerceIntegral arg1 >>= \arg1' ->
-- >   (...decode the C string) >>= \arg2' ->
-- >   fmap coerceIntegral
-- >   (f'hs arg1' arg2')
-- >
-- > name_new :: (Int -> String -> IO Int) -> IO (CCallback (CInt -> Ptr CChar -> IO CInt))
-- > name_new f = do
-- >   f'p <- name_newFunPtr f
-- >   name'newCallback f'p freeHaskellFunPtrFunPtr False
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]

        -- Generate the *_newFunPtr function.
        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'

        -- Generate the *_new function.
        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]

-- | The name of the function that takes a Haskell function and wraps it in a
-- callback object.  This is internal to the binding; normal users can pass
-- Haskell functions to be used as callbacks inplicitly.
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

-- | Pure version of 'toHsCallbackCtorName' that doesn't create a qualified
-- name.
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"

-- | The name of the function that takes a Haskell function with Haskell-side
-- types and wraps it in a 'Foreign.Ptr.FunPtr' that does appropriate
-- conversions to and from C-side types.
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

-- | Pure version of 'toHsCallbackNewFunPtrFnName' that doesn't create a qualified
-- name.
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

-- | Constructs the function type for a callback.  A callback that throws has
-- additional parameters.
--
-- Keep this in sync with 'hsCallbackToTFn'.
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])

-- | Constructs the function type for a callback.  For Haskell, the type depends
-- on the side; the C++ side has additional parameters.
--
-- Keep this in sync with 'cppCallbackToTFn'.
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])