-- This file is part of Hoppy.
--
-- Copyright 2015-2024 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 -> ErrorMsg
show Callback
cb =
    [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ErrorMsg
"<Callback ", ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Callback -> ExtName
callbackExtName Callback
cb), ErrorMsg
" ", [Parameter] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Callback -> [Parameter]
callbackParams Callback
cb), ErrorMsg
" ",
            Type -> ErrorMsg
forall a. Show a => a -> ErrorMsg
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 }

instance HasAddendum Callback where
  getAddendum :: Callback -> Addendum
getAddendum = Callback -> Addendum
callbackAddendum
  setAddendum :: Addendum -> Callback -> Callback
setAddendum Addendum
addendum Callback
cb = Callback
cb { callbackAddendum = addendum }

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

makeConversion :: Callback -> ConversionSpec
makeConversion :: Callback -> ConversionSpec
makeConversion Callback
cb =
  (ErrorMsg -> ConversionSpecCpp -> ConversionSpec
makeConversionSpec (Callback -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Callback
cb) ConversionSpecCpp
cpp)
  { conversionSpecHaskell = hs }
  where reqsGen :: ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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
. ErrorMsg -> Include
includeLocal (ErrorMsg -> Include) -> (Module -> ErrorMsg) -> Module -> Include
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ErrorMsg
moduleHppPath (Module -> Reqs)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Module
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         ExtName -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 ErrorMsg)) Reqs
LC.typeReqs (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Callback -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Type
cppCallbackToTFn Callback
cb
          Reqs -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reqs -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs)
-> Reqs -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 =
          (ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
-> ConversionSpecCpp
makeConversionSpecCpp (Callback -> ErrorMsg
callbackClassName Callback
cb) ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
reqsGen)
          { conversionSpecCppConversionType = return $ Just $ ptrT callbackImplClassType
          , conversionSpecCppConversionToCppExpr = Just $ \Generator ()
fromVar Maybe (Generator ())
maybeToVar -> case Maybe (Generator ())
maybeToVar of
              Just Generator ()
toVar ->
                [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [Callback -> ErrorMsg
callbackClassName Callback
cb, ErrorMsg
" "] Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
toVar Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"(" Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                Generator ()
fromVar Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
");\n"
              Maybe (Generator ())
Nothing -> [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [Callback -> ErrorMsg
callbackClassName Callback
cb, ErrorMsg
"("] Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
fromVar Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
")"
            -- 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 ErrorMsg)) Type
-> Generator HsType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsTypeSide
-> Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) 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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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 ErrorMsg)) Type
-> Generator HsType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsTypeSide
-> Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) 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
$ ErrorMsg -> Generator ()
LH.sayLn (ErrorMsg -> Generator ())
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
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
$
          ErrorMsg -> ConversionSpecCpp -> ConversionSpec
makeConversionSpec ErrorMsg
implClass (ConversionSpecCpp -> ConversionSpec)
-> ConversionSpecCpp -> ConversionSpec
forall a b. (a -> b) -> a -> b
$
          ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
-> ConversionSpecCpp
makeConversionSpecCpp ErrorMsg
implClass ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
reqsGen

        implClass :: ErrorMsg
implClass = Callback -> ErrorMsg
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 -> ErrorMsg
callbackClassName = ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg)
-> (Callback -> ExtName) -> Callback -> ErrorMsg
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 -> ErrorMsg
callbackImplClassName = (ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_impl") ShowS -> (Callback -> ErrorMsg) -> Callback -> ErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtName -> ErrorMsg
fromExtName (ExtName -> ErrorMsg)
-> (Callback -> ExtName) -> Callback -> ErrorMsg
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 -> ErrorMsg
callbackFnName = ExtName -> ErrorMsg
LC.externalNameToCpp (ExtName -> ErrorMsg)
-> (Callback -> ExtName) -> Callback -> ErrorMsg
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 :: ErrorMsg
className = Callback -> ErrorMsg
callbackClassName Callback
cb
      implClassName :: ErrorMsg
implClassName = Callback -> ErrorMsg
callbackImplClassName Callback
cb
      fnName :: ErrorMsg
fnName = Callback -> ErrorMsg
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 a. [a] -> 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 ErrorMsg)) [Maybe Type]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
LC.typeToCType [Type]
paramTypes
  Type
retCType <- Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
retType (Maybe Type -> Type)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (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 ErrorMsg)) [Reqs]
-> Generator ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs)
-> [Type] -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Reqs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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, ErrorMsg
sharedPtrStr) <- Interface -> (Reqs, ErrorMsg)
interfaceSharedPtr (Interface -> (Reqs, ErrorMsg))
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Reqs, ErrorMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
forall (m :: * -> *). MonadReader Env m => m Interface
LC.askInterface
      Reqs -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => Reqs -> m ()
LC.addReqsM Reqs
sharedPtrReqs

      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"\nclass ", ErrorMsg
implClassName, ErrorMsg
" {\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"public:\n"
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    explicit ", ErrorMsg
implClassName, ErrorMsg
"("] Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [ErrorMsg] -> Type -> m ()
LC.sayType Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
fnPtrCType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
", void(*)(void(*)()), bool);\n"
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    ~", ErrorMsg
implClassName, ErrorMsg
"();\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"operator()" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
fnType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"private:\n"
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    ", ErrorMsg
implClassName, ErrorMsg
"(const ", ErrorMsg
implClassName, ErrorMsg
"&);\n"]
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    ", ErrorMsg
implClassName, ErrorMsg
"& operator=(const ", ErrorMsg
implClassName, ErrorMsg
"&);\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"f_" Maybe [ErrorMsg]
forall a. Maybe a
Nothing (Type -> Type
constT Type
fnPtrCType) Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    void (*const release_)(void(*)());\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    const bool releaseRelease_;\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"};\n"

      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"\nclass ", ErrorMsg
className, ErrorMsg
" {\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"public:\n"
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    ", ErrorMsg
className, ErrorMsg
"() {}\n"]
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    explicit ", ErrorMsg
className, ErrorMsg
"(", ErrorMsg
implClassName, ErrorMsg
"* impl) : impl_(impl) {}\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"operator()" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
fnType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    operator bool() const;\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"private:\n"
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"    ", ErrorMsg
sharedPtrStr, ErrorMsg
"<", ErrorMsg
implClassName, ErrorMsg
"> impl_;\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"};\n"

    SayExportMode
LC.SaySource -> do
      -- Render the classes' methods into the source file.  First render the
      -- impl class's constructor.
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"\n", ErrorMsg
implClassName, ErrorMsg
"::", ErrorMsg
implClassName, ErrorMsg
"("] Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"f" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
fnPtrCType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
", void (*release)(void(*)()), bool releaseRelease) :\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    f_(f), release_(release), releaseRelease_(releaseRelease) {}\n"

      -- Then render the destructor.
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"\n", ErrorMsg
implClassName, ErrorMsg
"::~", ErrorMsg
implClassName, ErrorMsg
"() {\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    if (release_) {\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"        release_(reinterpret_cast<void(*)()>(f_));\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"        if (releaseRelease_) {\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"            release_(reinterpret_cast<void(*)()>(release_));\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"        }\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"    }\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"}\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
 -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type))
-> [Type]
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
LC.typeToCType [Type]
paramTypes
      Maybe Type
retCTypeMaybe <- Type
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Type)
LC.typeToCType Type
retType

      ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (ErrorMsg
implClassName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"::operator()")
                     ((Type -> Maybe Type -> Int -> ErrorMsg)
-> [Type] -> [Maybe Type] -> [Int] -> [ErrorMsg]
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 ConversionSpec
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 -> ErrorMsg
LC.toArgNameAlt else Int -> ErrorMsg
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
          [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"int ", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
" = 0;\n"]
          [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"void *", ErrorMsg
LC.exceptionPtrArgName, ErrorMsg
" = 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 ErrorMsg)) Interface
forall (m :: * -> *). MonadReader Env m => m Interface
LC.askInterface
          Module
currentModule <- ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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
$ ErrorMsg -> Include
includeLocal (ErrorMsg -> Include) -> ErrorMsg -> Include
forall a b. (a -> b) -> a -> b
$ Module -> ErrorMsg
moduleHppPath Module
exceptionSupportModule
            Maybe Module
Nothing -> ErrorMsg -> Generator ()
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"sayExportCallback: " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ Interface -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show Interface
iface ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++
                       ErrorMsg
" uses exceptions, so it needs an exception support " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++
                       ErrorMsg
"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
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"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
$ ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
", "
                [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"&", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
", &", ErrorMsg
LC.exceptionPtrArgName]
              ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
")"

            -- | 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
              [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"if (", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
" != 0) { ",
                       ErrorMsg
LC.exceptionRethrowFnName, ErrorMsg
"(", ErrorMsg
LC.exceptionIdArgName, ErrorMsg
", ",
                       ErrorMsg
LC.exceptionPtrArgName, ErrorMsg
"); }\n"]

        case (Type
retType, Maybe Type
retCTypeMaybe) of
          (Type
Internal_TVoid, Maybe Type
Nothing) -> do
            Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
            Generator ()
sayExceptionCheck
          (Type
_, Maybe Type
Nothing) -> do
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"result" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
retType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
" = " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
            Generator ()
sayExceptionCheck
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"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
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"resultPtr" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
retCType' Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
" = " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
            Generator ()
sayExceptionCheck
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"result" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
retType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
" = *resultPtr;\n"
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"delete resultPtr;\n"
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"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
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"resultPtr" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
retCType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
" = " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
            Generator ()
sayExceptionCheck
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"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
            ErrorMsg -> Maybe [ErrorMsg] -> Type -> Generator ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
ErrorMsg -> Maybe [ErrorMsg] -> Type -> m ()
LC.sayVar ErrorMsg
"resultPtr" Maybe [ErrorMsg]
forall a. Maybe a
Nothing Type
retCType Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
" = " Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Generator ()
sayCall Generator () -> Generator () -> Generator ()
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
";\n"
            Generator ()
sayExceptionCheck
            ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return *resultPtr;\n"
          (Type, Maybe Type)
ts -> ErrorMsg -> Generator ()
forall a. ErrorMsg -> Generator a
LC.abort (ErrorMsg -> Generator ()) -> ErrorMsg -> Generator ()
forall a b. (a -> b) -> a -> b
$ [ErrorMsg] -> ErrorMsg
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ErrorMsg
"sayExportCallback: Unexpected return types ", (Type, Maybe Type) -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show (Type, Maybe Type)
ts, ErrorMsg
"."]

      -- Render the non-impl operator() method, which simply passes C++ values
      -- along to the impl object.
      ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction (ErrorMsg
className ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"::operator()")
                     ((Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
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 -> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"(*impl_)("
          Type
_ -> ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return (*impl_)("
        Int -> Generator ()
Function.sayCppArgNames Int
paramCount
        ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
");\n"

      -- Render "operator bool", which detects whether the callback was not
      -- default-constructed with no actual impl object.
      [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
className, ErrorMsg
"::operator bool() const {\n"]
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"return static_cast<bool>(impl_);\n"
      ErrorMsg -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => ErrorMsg -> m ()
LC.say ErrorMsg
"}\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
$
                              ErrorMsg -> ConversionSpecCpp -> ConversionSpec
makeConversionSpec (ErrorMsg
"<Internal " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
implClassName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
" pointer>") (ConversionSpecCpp -> ConversionSpec)
-> ConversionSpecCpp -> ConversionSpec
forall a b. (a -> b) -> a -> b
$
                              ErrorMsg
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
-> ConversionSpecCpp
makeConversionSpecCpp (ErrorMsg
implClassName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"*") (Reqs -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Reqs
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Reqs
forall a. Monoid a => a
mempty)
      ErrorMsg
-> [ErrorMsg] -> Type -> Maybe (Generator ()) -> Generator ()
LC.sayFunction ErrorMsg
fnName [ErrorMsg
"f", ErrorMsg
"release", ErrorMsg
"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
$
        [ErrorMsg] -> Generator ()
forall (m :: * -> *). MonadWriter [Chunk] m => [ErrorMsg] -> m ()
LC.says [ErrorMsg
"return new ", ErrorMsg
implClassName, ErrorMsg
"(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 =
  ErrorMsg -> Generator () -> Generator ()
forall a. ErrorMsg -> Generator a -> Generator a
LH.withErrorContext (ErrorMsg
"generating callback " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ExtName -> ErrorMsg
forall a. Show a => a -> ErrorMsg
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
    ErrorMsg
hsNewFunPtrFnName <- Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsCallbackNewFunPtrFnName Callback
cb
    ErrorMsg
hsCtorName <- Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
toHsCallbackCtorName Callback
cb
    let hsCtorName'newCallback :: ErrorMsg
hsCtorName'newCallback = ErrorMsg
hsCtorName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"'newCallback"
        hsCtorName'newFunPtr :: ErrorMsg
hsCtorName'newFunPtr = ErrorMsg
hsCtorName ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"'newFunPtr"

    HsType
hsFnCType <- HsTypeSide -> Type -> Generator HsType
LH.cppTypeToHsTypeAndUse HsTypeSide
LH.HsCSide (Type -> Generator HsType)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Type
-> Generator HsType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsTypeSide
-> Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) 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 ErrorMsg)) Type
-> Generator HsType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsTypeSide
-> Callback -> ReaderT Env (WriterT Output (Except ErrorMsg)) 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"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
$ ErrorMsg -> HsName
HsIdent ErrorMsg
"HoppyFHR.CCallback") HsType
hsFnCType

        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"foreign import ccall \"wrapper\" ", ErrorMsg
hsCtorName'newFunPtr, ErrorMsg
" :: ",
                   HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
hsFunPtrImportType]
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"foreign import ccall \"", ExtName -> ErrorMsg
LC.externalNameToCpp ExtName
name, ErrorMsg
"\" ",
                   ErrorMsg
hsCtorName'newCallback, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
hsCallbackCtorImportType]

      SayExportMode
LH.SayExportDecls -> do
        [ErrorMsg] -> Generator ()
LH.addExports [ErrorMsg
hsNewFunPtrFnName, ErrorMsg
hsCtorName]

        -- Generate the *_newFunPtr function.
        HsType
wholeNewFunPtrFnType <- Generator HsType
getWholeNewFunPtrFnType
        let paramCount :: Int
paramCount = [Parameter] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Parameter]
params
            argNames :: [ErrorMsg]
argNames = (Int -> ErrorMsg) -> [Int] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ErrorMsg
LH.toArgName [Int
1..Int
paramCount]
            argNames' :: [ErrorMsg]
argNames' = ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"'") [ErrorMsg]
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 [ErrorMsg -> ErrorMsg -> HsImportSet
hsImport1 ErrorMsg
"Prelude" ErrorMsg
"($)",
                                 HsImportSet
hsImportForRuntime]
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsNewFunPtrFnName, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
wholeNewFunPtrFnType]
        [ErrorMsg] -> Generator ()
LH.saysLn ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$ ErrorMsg
hsNewFunPtrFnName ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
" f'hs = " ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
hsCtorName'newFunPtr ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ErrorMsg
" $" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:
          case (if Bool
throws then ([ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg
"excIdPtr", ErrorMsg
"excPtrPtr"]) else [ErrorMsg] -> [ErrorMsg]
forall a. a -> a
id) [ErrorMsg]
argNames of
            [] -> []
            [ErrorMsg]
argNames'' -> [ErrorMsg
" \\", [ErrorMsg] -> ErrorMsg
unwords [ErrorMsg]
argNames'', ErrorMsg
" ->"]
        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
$ ErrorMsg -> Generator ()
LH.sayLn ErrorMsg
"HoppyFHR.internalHandleCallbackExceptions excIdPtr excPtrPtr $"
          [(Parameter, ErrorMsg, ErrorMsg)]
-> ((Parameter, ErrorMsg, ErrorMsg) -> Generator ())
-> Generator ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Parameter]
-> [ErrorMsg] -> [ErrorMsg] -> [(Parameter, ErrorMsg, ErrorMsg)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Parameter]
params [ErrorMsg]
argNames [ErrorMsg]
argNames') (((Parameter, ErrorMsg, ErrorMsg) -> Generator ()) -> Generator ())
-> ((Parameter, ErrorMsg, ErrorMsg) -> Generator ())
-> Generator ()
forall a b. (a -> b) -> a -> b
$ \(Parameter
p, ErrorMsg
argName, ErrorMsg
argName') ->
            CallDirection -> Type -> ErrorMsg -> ErrorMsg -> Generator ()
Function.sayHsArgProcessing CallDirection
Function.FromCpp (Parameter -> Type
parameterType Parameter
p) ErrorMsg
argName ErrorMsg
argName'
          CallDirection -> Type -> [ErrorMsg] -> Generator ()
Function.sayHsCallAndProcessReturn CallDirection
Function.FromCpp Type
retType ([ErrorMsg] -> Generator ()) -> [ErrorMsg] -> Generator ()
forall a b. (a -> b) -> a -> b
$
            ErrorMsg
"f'hs" ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
: ShowS -> [ErrorMsg] -> [ErrorMsg]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [ErrorMsg]
argNames'

        -- Generate the *_new function.
        HsType
wholeCtorType <- Generator HsType
getWholeCtorType
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCtorName, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
wholeCtorType]
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCtorName, ErrorMsg
" 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
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
"f'p <- ", ErrorMsg
hsNewFunPtrFnName, ErrorMsg
" f'hs"]
          [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCtorName'newCallback, ErrorMsg
" f'p HoppyFHR.freeHaskellFunPtrFunPtr HoppyP.False"]

      SayExportMode
LH.SayExportBoot -> do
        [ErrorMsg] -> Generator ()
LH.addExports [ErrorMsg
hsNewFunPtrFnName, ErrorMsg
hsCtorName]
        HsType
wholeNewFunPtrFnType <- Generator HsType
getWholeNewFunPtrFnType
        HsType
wholeCtorType <- Generator HsType
getWholeCtorType
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsNewFunPtrFnName, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
LH.prettyPrint HsType
wholeNewFunPtrFnType]
        Generator ()
LH.ln
        [ErrorMsg] -> Generator ()
LH.saysLn [ErrorMsg
hsCtorName, ErrorMsg
" :: ", HsType -> ErrorMsg
forall a. Pretty a => a -> ErrorMsg
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 ErrorMsg)) ErrorMsg
toHsCallbackCtorName Callback
callback =
  ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsCallbackCtorName" (ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
LH.addExtNameModule (Callback -> ExtName
callbackExtName Callback
callback) (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$ Callback -> ErrorMsg
toHsCallbackCtorName' Callback
callback

-- | Pure version of 'toHsCallbackCtorName' that doesn't create a qualified
-- name.
toHsCallbackCtorName' :: Callback -> String
toHsCallbackCtorName' :: Callback -> ErrorMsg
toHsCallbackCtorName' Callback
callback =
  ExtName -> ErrorMsg
LH.toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Callback -> ExtName
callbackExtName Callback
callback) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_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 ErrorMsg)) ErrorMsg
toHsCallbackNewFunPtrFnName Callback
callback =
  ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a. ErrorMsg -> Generator a -> Generator a
LH.inFunction ErrorMsg
"toHsCallbackNewFunPtrFnName" (ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$
  ExtName
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
LH.addExtNameModule (Callback -> ExtName
callbackExtName Callback
callback) (ErrorMsg
 -> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg)
-> ErrorMsg
-> ReaderT Env (WriterT Output (Except ErrorMsg)) ErrorMsg
forall a b. (a -> b) -> a -> b
$ Callback -> ErrorMsg
toHsCallbackNewFunPtrFnName' Callback
callback

-- | Pure version of 'toHsCallbackNewFunPtrFnName' that doesn't create a qualified
-- name.
toHsCallbackNewFunPtrFnName' :: Callback -> String
toHsCallbackNewFunPtrFnName' :: Callback -> ErrorMsg
toHsCallbackNewFunPtrFnName' Callback
callback =
  ExtName -> ErrorMsg
LH.toHsFnName' (ExtName -> ErrorMsg) -> ExtName -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ HasCallStack => ErrorMsg -> ExtName
ErrorMsg -> ExtName
toExtName (ErrorMsg -> ExtName) -> ErrorMsg -> ExtName
forall a b. (a -> b) -> a -> b
$ ExtName -> ErrorMsg
fromExtName (Callback -> ExtName
callbackExtName Callback
callback) ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorMsg
"_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 a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
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 ErrorMsg)) Module
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Module
forall (m :: * -> *). MonadReader Env m => m Module
LC.askModule ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Bool)
-> (Maybe Bool -> Generator Bool) -> Generator Bool
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> (a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Bool
b -> Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
    Maybe Bool
Nothing -> Interface -> Bool
interfaceCallbacksThrow (Interface -> Bool)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
-> Generator Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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 ErrorMsg)) Module
-> ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT Output (Except ErrorMsg)) Module
LH.askModule ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe Bool)
-> (Maybe Bool -> Generator Bool) -> Generator Bool
forall a b.
ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> (a -> ReaderT Env (WriterT Output (Except ErrorMsg)) b)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Bool
b -> Bool -> Generator Bool
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
    Maybe Bool
Nothing -> Interface -> Bool
interfaceCallbacksThrow (Interface -> Bool)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Interface
-> Generator Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT Output (Except ErrorMsg)) 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 ErrorMsg)) Type
cppCallbackToTFn Callback
cb = do
  Bool
throws <- Generator Bool
mayThrow
  Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Type
forall a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Type)
-> Type -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
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 ErrorMsg)) Module
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Module
forall (m :: * -> *). MonadReader Env m => m Module
LC.askModule ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) (Maybe Bool)
-> (Maybe Bool -> Generator Bool) -> Generator Bool
forall a b.
ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
-> (a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) b
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 a. a -> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
t
            Maybe Bool
Nothing -> Interface -> Bool
interfaceCallbacksThrow (Interface -> Bool)
-> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) Interface
-> Generator Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT [Chunk] (Either ErrorMsg)) 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 ErrorMsg)) 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Type -> ReaderT Env (WriterT Output (Except ErrorMsg)) Type
forall a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ReaderT Env (WriterT Output (Except ErrorMsg)) Type)
-> Type -> ReaderT Env (WriterT Output (Except ErrorMsg)) 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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
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 ErrorMsg)) Module
-> ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT Output (Except ErrorMsg)) Module
LH.askModule ReaderT Env (WriterT Output (Except ErrorMsg)) (Maybe Bool)
-> (Maybe Bool -> Generator Bool) -> Generator Bool
forall a b.
ReaderT Env (WriterT Output (Except ErrorMsg)) a
-> (a -> ReaderT Env (WriterT Output (Except ErrorMsg)) b)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) b
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 a. a -> ReaderT Env (WriterT Output (Except ErrorMsg)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
t
            Maybe Bool
Nothing -> Interface -> Bool
interfaceCallbacksThrow (Interface -> Bool)
-> ReaderT Env (WriterT Output (Except ErrorMsg)) Interface
-> Generator Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (WriterT Output (Except ErrorMsg)) 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])