module Data.GI.CodeGen.Signal
    ( genSignal
    , genCallback
    , signalHaskellName
    ) where

import Control.Monad (forM, forM_, when, unless)

import Data.Maybe (catMaybes)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Bool (bool)
import qualified Data.Text as T
import Data.Text (Text)

import Text.Show.Pretty (ppShow)

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Callable (hOutType, wrapMaybe,
                                 fixupCallerAllocates,
                                 genDynamicCallableWrapper,
                                 callableHInArgs, callableHOutArgs)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Haddock (deprecatedPragma,
                                RelativeDocPosition(..), writeHaddock,
                                writeDocumentation,
                                writeArgDocumentation, writeReturnDocumentation)
import Data.GI.CodeGen.SymbolNaming
import Data.GI.CodeGen.Transfer (freeContainerType)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror,
                             lcFirst, ucFirst, prime)
import Data.GI.GIR.Documentation (Documentation)

-- | The prototype of the callback on the Haskell side (what users of
-- the binding will see)
genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures ->
                               Documentation -> ExcCodeGen ()
genHaskellCallbackPrototype :: Text
-> Callable
-> Text
-> ExposeClosures
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype subsec :: Text
subsec cb :: Callable
cb htype :: Text
htype expose :: ExposeClosures
expose doc :: Documentation
doc = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    let name' :: Text
name' = case ExposeClosures
expose of
                  WithClosures -> Text -> Text
callbackHTypeWithClosures Text
htype
                  WithoutClosures -> Text
htype
        (hInArgs :: [Arg]
hInArgs, _) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
expose
        inArgsWithArrows :: [(Text, Arg)]
inArgsWithArrows = [Text] -> [Arg] -> [(Text, Arg)]
forall a b. [a] -> [b] -> [(a, b)]
zip ("" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
forall a. a -> [a]
repeat "-> ") [Arg]
hInArgs
        hOutArgs :: [Arg]
hOutArgs = Callable -> [Arg]
callableHOutArgs Callable
cb

    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
name'
    RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol Documentation
doc
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ="
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
      [(Text, Arg)] -> ((Text, Arg) -> ExcCodeGen ()) -> ExcCodeGen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Arg)]
inArgsWithArrows (((Text, Arg) -> ExcCodeGen ()) -> ExcCodeGen ())
-> ((Text, Arg) -> ExcCodeGen ()) -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ \(arrow :: Text
arrow, arg :: Arg
arg) -> do
        TypeRep
ht <- Type -> CodeGen TypeRep
isoHaskellType (Arg -> Type
argType Arg
arg)
        Bool
isMaybe <- Arg -> CodeGen Bool
wrapMaybe Arg
arg
        let formattedType :: Text
formattedType = if Bool
isMaybe
                            then TypeRep -> Text
typeShow (TypeRep -> TypeRep
maybeT TypeRep
ht)
                            else TypeRep -> Text
typeShow TypeRep
ht
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
arrow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
formattedType
        Arg -> CodeGen ()
writeArgDocumentation Arg
arg
      TypeRep
ret <- Callable -> [Arg] -> BaseCodeGen CGError TypeRep
hOutType Callable
cb [Arg]
hOutArgs
      let returnArrow :: Text
returnArrow = if [Arg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg]
hInArgs
                        then ""
                        else "-> "
      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
returnArrow Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow (TypeRep -> TypeRep
io TypeRep
ret)
      Callable -> Bool -> CodeGen ()
writeReturnDocumentation Callable
cb Bool
False

    ExcCodeGen ()
CodeGen ()
blank

    -- For optional parameters, in case we want to pass Nothing.
    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) ("no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name')
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text -> Text
noCallbackDoc Text
name')
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = Nothing"

  where noCallbackDoc :: Text -> Text
        noCallbackDoc :: Text -> Text
noCallbackDoc typeName :: Text
typeName =
          "A convenience synonym for @`Nothing` :: `Maybe` `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "`@."

-- | Generate the type synonym for the prototype of the callback on
-- the C side. Returns the name given to the type synonym.
genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen Text
genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen Text
genCCallbackPrototype subsec :: Text
subsec cb :: Callable
cb name' :: Text
name' isSignal :: Bool
isSignal = BaseCodeGen e Text -> BaseCodeGen e Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e Text -> BaseCodeGen e Text)
-> BaseCodeGen e Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
    let ctypeName :: Text
ctypeName = Text -> Text
callbackCType Text
name'

    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
ctypeName
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
ccallbackDoc

    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ctypeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ="
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSignal (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
withComment "Ptr () ->" "object"
      [Arg] -> (Arg -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Callable -> [Arg]
args Callable
cb) ((Arg -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Arg -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \arg :: Arg
arg -> do
        TypeRep
ht <- Type -> BaseCodeGen e TypeRep
Type -> CodeGen TypeRep
foreignType (Type -> BaseCodeGen e TypeRep) -> Type -> BaseCodeGen e TypeRep
forall a b. (a -> b) -> a -> b
$ Arg -> Type
argType Arg
arg
        let ht' :: TypeRep
ht' = if Arg -> Direction
direction Arg
arg Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
/= Direction
DirectionIn
                  then TypeRep -> TypeRep
ptr TypeRep
ht
                  else TypeRep
ht
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
typeShow TypeRep
ht' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ->"
      Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Callable -> Bool
callableThrows Callable
cb) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
        Text -> CodeGen ()
line "Ptr (Ptr GError) ->"
      Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSignal (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
withComment "Ptr () ->" "user_data"
      TypeRep
ret <- TypeRep -> TypeRep
io (TypeRep -> TypeRep)
-> BaseCodeGen e TypeRep -> BaseCodeGen e TypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Callable -> Maybe Type
returnType Callable
cb of
                      Nothing -> TypeRep -> BaseCodeGen e TypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeRep -> BaseCodeGen e TypeRep)
-> TypeRep -> BaseCodeGen e TypeRep
forall a b. (a -> b) -> a -> b
$ Text -> TypeRep
con0 "()"
                      Just t :: Type
t -> Type -> CodeGen TypeRep
foreignType Type
t
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
typeShow TypeRep
ret
    Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ctypeName

  where
    ccallbackDoc :: Text
    ccallbackDoc :: Text
ccallbackDoc = "Type for the callback on the (unwrapped) C side."

-- | Generator for wrappers callable from C
genCallbackWrapperFactory :: Text -> Text -> CodeGen ()
genCallbackWrapperFactory :: Text -> Text -> CodeGen ()
genCallbackWrapperFactory subsec :: Text
subsec name' :: Text
name' = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    let factoryName :: Text
factoryName = Text -> Text
callbackWrapperAllocator Text
name'
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
factoryDoc
    Text -> CodeGen ()
line "foreign import ccall \"wrapper\""
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
factoryName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
name'
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> IO (FunPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
factoryName

  where factoryDoc :: Text
        factoryDoc :: Text
factoryDoc = "Generate a function pointer callable from C code, from a `"
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`."

-- | Wrap the Haskell `cb` callback into a foreign function of the
-- right type. Returns the name of the wrapped value.
genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text
genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text
genWrappedCallback cb :: Callable
cb cbArg :: Text
cbArg callback :: Text
callback isSignal :: Bool
isSignal = do
  Text
drop <- if Callable -> Bool
callableHasClosures Callable
cb
          then do
            let arg' :: Text
arg' = Text -> Text
prime Text
cbArg
            Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = "
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackDropClosures Text
callback Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cbArg
            Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
arg'
          else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
cbArg
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
prime Text
drop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackHaskellToForeign Text
callback Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
       if Bool
isSignal
       then " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
drop
       else " Nothing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
drop
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
prime Text
drop)

-- | Generator of closures
genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen ()
genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen ()
genClosure subsec :: Text
subsec cb :: Callable
cb callback :: Text
callback name :: Text
name isSignal :: Bool
isSignal = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  let closure :: Text
closure = Text -> Text
callbackClosureGenerator Text
name
  HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
closure
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
closureDoc
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
closure Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: MonadIO m => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
callback Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m (GClosure "
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
callback Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
closure Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " cb = liftIO $ do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
            Text
wrapped <- Callable -> Text -> Text -> Bool -> CodeGen Text
genWrappedCallback Callable
cb "cb" Text
callback Bool
isSignal
            Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
callbackWrapperAllocator Text
callback Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wrapped
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " >>= B.GClosure.newGClosure"
  where
    closureDoc :: Text
    closureDoc :: Text
closureDoc = "Wrap the callback into a `GClosure`."

-- Wrap a conversion of a nullable object into "Maybe" object, by
-- checking whether the pointer is NULL.
convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text
convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text
convertNullable aname :: Text
aname c :: BaseCodeGen e Text
c = do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
aname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <-"
  BaseCodeGen e Text -> BaseCodeGen e Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e Text -> BaseCodeGen e Text)
-> BaseCodeGen e Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "if " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " == nullPtr"
    Text -> CodeGen ()
line   "then return Nothing"
    Text -> CodeGen ()
line   "else do"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
             Text
unpacked <- BaseCodeGen e Text
c
             Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return $ Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unpacked
    Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
aname

-- Convert a non-zero terminated out array, stored in a variable
-- named "aname", into the corresponding Haskell object.
convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text
convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text
convertCallbackInCArray callable :: Callable
callable arg :: Arg
arg t :: Type
t@(TCArray False (-1) length :: Int
length _) aname :: Text
aname =
  if Int
length Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1
  then Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExcCodeGen Text -> ExcCodeGen Text -> Bool -> ExcCodeGen Text
forall a. a -> a -> Bool -> a
bool ExcCodeGen Text
convertAndFree
                         (Text -> ExcCodeGen Text -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Text -> BaseCodeGen e Text
convertNullable Text
aname ExcCodeGen Text
convertAndFree)
  else
    -- Not much we can do, we just pass the pointer along, and let
    -- the callback deal with it.
    Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
aname
  where
    lname :: Text
lname = Arg -> Text
escapedArgName (Arg -> Text) -> Arg -> Text
forall a b. (a -> b) -> a -> b
$ Callable -> [Arg]
args Callable
callable [Arg] -> Int -> Arg
forall a. [a] -> Int -> a
!! Int
length

    convertAndFree :: ExcCodeGen Text
    convertAndFree :: ExcCodeGen Text
convertAndFree = do
      Text
unpacked <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
aname (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Text -> Type -> Transfer -> BaseCodeGen CGError Converter
unpackCArray Text
lname Type
t (Arg -> Transfer
transfer Arg
arg)
      -- Free the memory associated with the array
      Transfer -> Type -> Text -> Text -> ExcCodeGen ()
freeContainerType (Arg -> Transfer
transfer Arg
arg) Type
t Text
aname Text
lname
      Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
unpacked

-- Remove the warning, this should never be reached.
convertCallbackInCArray _ t :: Arg
t _ _ =
    Text -> ExcCodeGen Text
forall a. Text -> a
terror (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "convertOutCArray : unexpected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Arg -> Text
forall a. Show a => a -> Text
tshow Arg
t

-- Prepare an argument for passing into the Haskell side.
prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text
prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text
prepareArgForCall cb :: Callable
cb arg :: Arg
arg = case Arg -> Direction
direction Arg
arg of
  DirectionIn -> Callable -> Arg -> ExcCodeGen Text
prepareInArg Callable
cb Arg
arg
  DirectionInout -> Arg -> ExcCodeGen Text
prepareInoutArg Arg
arg
  DirectionOut -> Text -> ExcCodeGen Text
forall a. Text -> a
terror "Unexpected DirectionOut!"

prepareInArg :: Callable -> Arg -> ExcCodeGen Text
prepareInArg :: Callable -> Arg -> ExcCodeGen Text
prepareInArg cb :: Callable
cb arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
  case Arg -> Type
argType Arg
arg of
    t :: Type
t@(TCArray False _ _ _) -> Callable -> Arg -> Type -> Text -> ExcCodeGen Text
convertCallbackInCArray Callable
cb Arg
arg Type
t Text
name
    _ -> do
      let c :: ExcCodeGen Text
c = Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
name (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
transientToH (Arg -> Type
argType Arg
arg) (Arg -> Transfer
transfer Arg
arg)
      Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExcCodeGen Text -> ExcCodeGen Text -> Bool -> ExcCodeGen Text
forall a. a -> a -> Bool -> a
bool ExcCodeGen Text
c (Text -> ExcCodeGen Text -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Text -> BaseCodeGen e Text
convertNullable Text
name ExcCodeGen Text
c)

prepareInoutArg :: Arg -> ExcCodeGen Text
prepareInoutArg :: Arg -> ExcCodeGen Text
prepareInoutArg arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
  Text
name' <- Text -> Converter -> CodeGen Text
genConversion Text
name (Converter -> ExcCodeGen Text) -> Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Constructor -> Converter
apply (Constructor -> Converter) -> Constructor -> Converter
forall a b. (a -> b) -> a -> b
$ Text -> Constructor
M "peek"
  Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
name' (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Arg -> Type
argType Arg
arg) (Arg -> Transfer
transfer Arg
arg)

saveOutArg :: Arg -> ExcCodeGen ()
saveOutArg :: Arg -> ExcCodeGen ()
saveOutArg arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
      name' :: Text
name' = "out" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Arg -> Transfer
transfer Arg
arg Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
/= Transfer
TransferEverything) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Unexpected transfer type for \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
  Bool
isMaybe <- Arg -> CodeGen Bool
wrapMaybe Arg
arg
  Text
name'' <- if Bool
isMaybe
            then do
              let name'' :: Text
name'' = Text -> Text
prime Text
name'
              Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
name'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " of"
              ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
                   Text -> CodeGen ()
line "Nothing -> return nullPtr"
                   Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> do"
                   ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
                         Text
converted <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
name'' (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Arg -> Type
argType Arg
arg) Transfer
TransferEverything
                         Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
converted
              Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name''
            else Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
name' (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Arg -> Type
argType Arg
arg) Transfer
TransferEverything
  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "poke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name''

-- | A simple wrapper that drops every closure argument.
genDropClosures :: Text -> Callable -> Text -> CodeGen ()
genDropClosures :: Text -> Callable -> Text -> CodeGen ()
genDropClosures subsec :: Text
subsec cb :: Callable
cb name' :: Text
name' = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  let dropper :: Text
dropper = Text -> Text
callbackDropClosures Text
name'
      (inWithClosures :: [Arg]
inWithClosures, _) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
WithClosures
      (inWithoutClosures :: [Arg]
inWithoutClosures, _) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
WithoutClosures
      passOrIgnore :: Arg -> Maybe Text
passOrIgnore = \arg :: Arg
arg -> if Arg
arg Arg -> [Arg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arg]
inWithoutClosures
                             then Text -> Maybe Text
forall a. a -> Maybe a
Just (Arg -> Text
escapedArgName Arg
arg)
                             else Maybe Text
forall a. Maybe a
Nothing
      argNames :: [Text]
argNames = (Arg -> Text) -> [Arg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "_" Text -> Text
forall a. a -> a
id (Maybe Text -> Text) -> (Arg -> Maybe Text) -> Arg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Maybe Text
passOrIgnore) [Arg]
inWithClosures

  HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
dropper
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
dropperDoc

  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
dropper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackHTypeWithClosures Text
name'
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
dropper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " _f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
argNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = _f "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords ([Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ((Arg -> Maybe Text) -> [Arg] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Maybe Text
passOrIgnore [Arg]
inWithClosures))

  where dropperDoc :: Text
        dropperDoc :: Text
dropperDoc = "A simple wrapper that ignores the closure arguments."

-- | The wrapper itself, marshalling to and from Haskell. The `Callable`
-- argument is possibly a pointer to a FunPtr to free (via
-- freeHaskellFunPtr) once the callback is run once, or Nothing if the
-- FunPtr will be freed by someone else (the function registering the
-- callback for ScopeTypeCall, or a destroy notifier for
-- ScopeTypeNotified).
genCallbackWrapper :: Text -> Callable -> Text -> Bool -> ExcCodeGen ()
genCallbackWrapper :: Text -> Callable -> Text -> Bool -> ExcCodeGen ()
genCallbackWrapper subsec :: Text
subsec cb :: Callable
cb name' :: Text
name' isSignal :: Bool
isSignal = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  let wrapperName :: Text
wrapperName = Text -> Text
callbackHaskellToForeign Text
name'
      (hInArgs :: [Arg]
hInArgs, _) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
WithClosures
      hOutArgs :: [Arg]
hOutArgs = Callable -> [Arg]
callableHOutArgs Callable
cb
      wrapperDoc :: Text
wrapperDoc = "Wrap a `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "` into a `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                   Text -> Text
callbackCType Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`."

  HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
wrapperName
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
wrapperDoc

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
wrapperName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ::"
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
      if Bool
isSignal
      then do
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ->"
      else do
           Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Maybe (Ptr (FunPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")) ->"
           let hType :: Text
hType = if Callable -> Bool
callableHasClosures Callable
cb
                       then Text -> Text
callbackHTypeWithClosures Text
name'
                       else Text
name'
           Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
hType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ->"

      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
callbackCType Text
name'

    let cArgNames :: [Text]
cArgNames = (Arg -> Text) -> [Arg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Text
escapedArgName (Callable -> [Arg]
args Callable
cb)
        allArgs :: Text
allArgs = if Bool
isSignal
                  then [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ["_cb", "_"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
cArgNames [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ["_"]
                  else [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ["funptrptr", "_cb"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
cArgNames
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
wrapperName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
allArgs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = do"
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
      [Text]
hInNames <- [Arg]
-> (Arg -> ExcCodeGen Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Arg]
hInArgs (Callable -> Arg -> ExcCodeGen Text
prepareArgForCall Callable
cb)

      let maybeReturn :: [Text]
maybeReturn = case Callable -> Maybe Type
returnType Callable
cb of
                          Nothing -> []
                          _       -> ["result"]
          returnVars :: [Text]
returnVars = [Text]
maybeReturn [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Arg -> Text) -> [Arg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (("out"Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Arg -> Text) -> Arg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Text
escapedArgName) [Arg]
hOutArgs
          mkTuple :: [Text] -> Text
mkTuple = Text -> Text
parenthesize (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate ", "
          returnBind :: Text
returnBind = case [Text]
returnVars of
                         []  -> ""
                         [r :: Text
r] -> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- "
                         _   -> [Text] -> Text
mkTuple [Text]
returnVars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- "
      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
returnBind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_cb " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
hInNames)

      [Arg] -> (Arg -> ExcCodeGen ()) -> ExcCodeGen ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Arg]
hOutArgs Arg -> ExcCodeGen ()
saveOutArg

      Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isSignal (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line "maybeReleaseFunPtr funptrptr"

      case Callable -> Maybe Type
returnType Callable
cb of
        Nothing -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just r :: Type
r -> do
           Bool
nullableReturnType <- Type -> CodeGen Bool
typeIsNullable Type
r
           if Callable -> Bool
returnMayBeNull Callable
cb Bool -> Bool -> Bool
&& Bool
nullableReturnType
           then do
             Text -> CodeGen ()
line "maybeM nullPtr result $ \\result' -> do"
             ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> ExcCodeGen ()
unwrapped "result'"
           else Text -> ExcCodeGen ()
unwrapped "result"
           where
             unwrapped :: Text -> ExcCodeGen ()
unwrapped rname :: Text
rname = do
               Text
result' <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
rname (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF Type
r (Callable -> Transfer
returnTransfer Callable
cb)
               Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result'

genCallback :: Name -> Callback -> CodeGen ()
genCallback :: Name -> Callback -> CodeGen ()
genCallback n :: Name
n (Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
cb, cbDocumentation :: Callback -> Documentation
cbDocumentation = Documentation
cbDoc }) = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- callback " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "--          -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Callable -> Text
forall a. Show a => a -> Text
tshow (Callable -> Callable
fixupCallerAllocates Callable
cb)

  if Callable -> Bool
skipReturn Callable
cb
  then BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Skipping callback " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- Callbacks skipping return unsupported :\n"
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Name -> String
forall a. Show a => a -> String
ppShow Name
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Callable -> String
forall a. Show a => a -> String
ppShow Callable
cb)
  else do
    let cb' :: Callable
cb' = Callable -> Callable
fixupCallerAllocates Callable
cb

    (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> CodeGen ()
line ("-- XXX Could not generate callback wrapper for "
                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                             "\n-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)) (ExcCodeGen () -> BaseCodeGen e ())
-> ExcCodeGen () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text
typeSynonym <- Text -> Callable -> Text -> Bool -> CodeGen Text
genCCallbackPrototype Text
name' Callable
cb' Text
name' Bool
False
      Text
dynamic <- Name -> Text -> Callable -> ExcCodeGen Text
genDynamicCallableWrapper Name
n Text
typeSynonym Callable
cb
      HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
name') Text
dynamic
      Text -> Text -> CodeGen ()
genCallbackWrapperFactory Text
name' Text
name'
      Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma Text
name' (Callable -> Maybe DeprecationInfo
callableDeprecated Callable
cb')
      Text
-> Callable
-> Text
-> ExposeClosures
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype Text
name' Callable
cb' Text
name' ExposeClosures
WithoutClosures Documentation
cbDoc
      Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Callable -> Bool
callableHasClosures Callable
cb') (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
           Text
-> Callable
-> Text
-> ExposeClosures
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype Text
name' Callable
cb' Text
name' ExposeClosures
WithClosures Documentation
cbDoc
           Text -> Callable -> Text -> CodeGen ()
genDropClosures Text
name' Callable
cb' Text
name'
      if Callable -> Bool
callableThrows Callable
cb'
      then do
        {- [Note: Callables that throw]

          In the case that the Callable throws (GErrors) we cannot
          simply take a Haskell functions that throws and wrap it into
          a foreign function, since in the case that an exception is
          raised the return value of the function is undefined, but we
          need to provide some value to the FFI.

          Alternatively, we could ask the Haskell function to provide
          a return value and optionally a GError. If the GError is
          present we should then release the memory associated with
          the out/return values (the caller will not do it, since
          there was an error), and then return some bogus values. This
          is fairly complicated, and callbacks raising GErrors are
          fairly rare, so for the moment we do not generate wrappers
          for these cases.
        -}
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- No Haskell->C wrapper generated since the function throws."
        ExcCodeGen ()
CodeGen ()
blank
      else do
        Text -> Callable -> Text -> Text -> Bool -> CodeGen ()
genClosure Text
name' Callable
cb' Text
name' Text
name' Bool
False
        Text -> Callable -> Text -> Bool -> ExcCodeGen ()
genCallbackWrapper Text
name' Callable
cb' Text
name' Bool
False

-- | Generate the given signal instance for the given API object.
genSignalInfoInstance :: Name -> Signal -> CodeGen ()
genSignalInfoInstance :: Name -> Signal -> CodeGen ()
genSignalInfoInstance owner :: Name
owner signal :: Signal
signal = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  let name :: Text
name = Name -> Text
upperName Name
owner
  let sn :: Text
sn = (Text -> Text
ucFirst (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
signalHaskellName (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
  Text
si <- Name -> Signal -> CodeGen Text
signalInfoName Name
owner Signal
signal
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance SignalInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      let signalConnectorName :: Text
signalConnectorName = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sn
          cbHaskellType :: Text
cbHaskellType = Text
signalConnectorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Callback"
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type HaskellCallbackType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cbHaskellType
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "connectSignal obj cb connectMode detail = do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector Signal
signal Text
cbHaskellType "connectMode" "detail"
  HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst Text
sn) Text
si

-- | Write some simple debug message when signal generation fails, and
-- generate a placeholder SignalInfo instance.
processSignalError :: Signal -> Name -> CGError -> CodeGen ()
processSignalError :: Signal -> Name -> CGError -> CodeGen ()
processSignalError signal :: Signal
signal owner :: Name
owner err :: CGError
err = do
  let qualifiedSignalName :: Text
qualifiedSignalName = Name -> Text
upperName Name
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Signal -> Text
sigName Signal
signal
      sn :: Text
sn = (Text -> Text
ucFirst (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
signalHaskellName (Text -> Text) -> (Signal -> Text) -> Signal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ["-- XXX Could not generate signal "
                  , Text
qualifiedSignalName
                  , "\n", "-- Error was : ", CGError -> Text
describeCGError CGError
err]

  -- Generate a placeholder SignalInfo instance that raises a type
  -- error when one attempts to use it.
  CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text
si <- Name -> Signal -> CodeGen Text
signalInfoName Name
owner Signal
signal
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance SignalInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type HaskellCallbackType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
si Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        " = B.Signals.SignalCodeGenError \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qualifiedSignalName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "connectSignal = undefined"
    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst Text
sn) Text
si

-- | Generate a wrapper for a signal.
genSignal :: Signal -> Name -> CodeGen ()
genSignal :: Signal -> Name -> CodeGen ()
genSignal s :: Signal
s@(Signal { sigName :: Signal -> Text
sigName = Text
sn, sigCallable :: Signal -> Callable
sigCallable = Callable
cb }) on :: Name
on =
  (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (Signal -> Name -> CGError -> CodeGen ()
processSignalError Signal
s Name
on) (ExcCodeGen () -> BaseCodeGen e ())
-> ExcCodeGen () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  let on' :: Text
on' = Name -> Text
upperName Name
on

  Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- signal " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sn

  let sn' :: Text
sn' = Text -> Text
signalHaskellName Text
sn
      signalConnectorName :: Text
signalConnectorName = Text
on' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
sn'
      cbType :: Text
cbType = Text
signalConnectorName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "Callback"
      docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst Text
sn'

  Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma Text
cbType (Callable -> Maybe DeprecationInfo
callableDeprecated Callable
cb)

  Text
-> Callable
-> Text
-> ExposeClosures
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType ExposeClosures
WithoutClosures (Signal -> Documentation
sigDoc Signal
s)

  Text
_ <- Text -> Callable -> Text -> Bool -> CodeGen Text
genCCallbackPrototype (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType Bool
True

  Text -> Text -> CodeGen ()
genCallbackWrapperFactory (Text -> Text
lcFirst Text
sn') Text
cbType

  if Callable -> Bool
callableThrows Callable
cb
    then do
      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- No Haskell->C wrapper generated since the function throws."
      ExcCodeGen ()
CodeGen ()
blank
    else do
      Text -> Callable -> Text -> Text -> Bool -> CodeGen ()
genClosure (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType Text
signalConnectorName Bool
True
      Text -> Callable -> Text -> Bool -> ExcCodeGen ()
genCallbackWrapper (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType Bool
True

  -- Wrapper for connecting functions to the signal
  -- We can connect to a signal either before the default handler runs
  -- ("on...") or after the default handler runs (after...). We
  -- provide convenient wrappers for both cases.
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    -- Notice that we do not include GObject here as a constraint,
    -- since if something provides signals it is necessarily a
    -- GObject.
    Text
klass <- Name -> CodeGen Text
classConstraint Name
on
    let signatureConstraints :: Text
signatureConstraints = "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
klass Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " a, MonadIO m) =>"
        signatureArgs :: Text
signatureArgs = if Signal -> Bool
sigDetailed Signal
s
          then "a -> P.Maybe T.Text -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cbType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m SignalHandlerId"
          else "a -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cbType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m SignalHandlerId"
        signature :: Text
signature = " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signatureConstraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signatureArgs
        onName :: Text
onName = "on" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalConnectorName
        afterName :: Text
afterName = "after" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signalConnectorName

    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
      RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
onDoc
      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
onName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signature
      if Signal -> Bool
sigDetailed Signal
s
        then do
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
onName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj detail cb = liftIO $ do"
        ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector Signal
s Text
cbType "SignalConnectBefore" "detail"
        else do
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
onName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj cb = liftIO $ do"
        ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector Signal
s Text
cbType "SignalConnectBefore" "Nothing"
      HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
onName

    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
      RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
afterDoc
      Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
afterName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signature
      if Signal -> Bool
sigDetailed Signal
s
        then do
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
afterName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj detail cb = liftIO $ do"
        ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector Signal
s Text
cbType "SignalConnectAfter" "detail"
        else do
        Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
afterName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj cb = liftIO $ do"
        ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector Signal
s Text
cbType "SignalConnectAfter" "Nothing"
      HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
afterName

  CPPGuard -> ExcCodeGen () -> ExcCodeGen ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (Name -> Signal -> CodeGen ()
genSignalInfoInstance Name
on Signal
s)

  where
    onDoc :: Text
    onDoc :: Text
onDoc = let hsn :: Text
hsn = Text -> Text
signalHaskellName Text
sn
            in [Text] -> Text
T.unlines [
      "Connect a signal handler for the [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "](#signal:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        ") signal, to be run before the default handler."
      , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
      , ""
      , "@"
      , "'Data.GI.Base.Signals.on' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
on Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " callback"
      , "@"
      , ""
      , Text
detailedDoc ]

    afterDoc :: Text
    afterDoc :: Text
afterDoc = let hsn :: Text
hsn = Text -> Text
signalHaskellName Text
sn
               in [Text] -> Text
T.unlines [
      "Connect a signal handler for the [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "](#signal:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        ") signal, to be run after the default handler."
      , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
      , ""
      , "@"
      , "'Data.GI.Base.Signals.after' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
on Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " callback"
      , "@"
      , ""
      , Text
detailedDoc ]

    detailedDoc :: Text
    detailedDoc :: Text
detailedDoc = if Bool -> Bool
not (Signal -> Bool
sigDetailed Signal
s)
                  then ""
                  else [Text] -> Text
T.unlines [
      "This signal admits a optional parameter @detail@."
      , "If it's not @Nothing@, we will connect to “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sn
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "::detail@” instead."
      ]


-- | Generate the code for connecting the given signal. This assumes
-- that it lives inside a @do@ block.
genSignalConnector :: Signal
                   -> Text -- ^ Callback type
                   -> Text -- ^ SignalConnectBefore or SignalConnectAfter
                   -> Text -- ^ Detail
                   -> CodeGen ()
genSignalConnector :: Signal -> Text -> Text -> Text -> CodeGen ()
genSignalConnector (Signal {sigName :: Signal -> Text
sigName = Text
sn, sigCallable :: Signal -> Callable
sigCallable = Callable
cb}) cbType :: Text
cbType when :: Text
when detail :: Text
detail = do
  Text
cb' <- Callable -> Text -> Text -> Bool -> CodeGen Text
genWrappedCallback Callable
cb "cb" Text
cbType Bool
True
  let cb'' :: Text
cb'' = Text -> Text
prime Text
cb'
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
cb'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackWrapperAllocator Text
cbType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cb'
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "connectSignalFunPtr obj \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cb'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
when
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
detail