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

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

import Data.Maybe (catMaybes, isJust)
#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.ModulePath (dotModulePath)
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 ->
                               Bool -> Documentation -> ExcCodeGen ()
genHaskellCallbackPrototype :: Text
-> Callable
-> Text
-> ExposeClosures
-> Bool
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype Text
subsec Callable
cb Text
htype ExposeClosures
expose Bool
isSignal Documentation
doc = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    let name' :: Text
name' = case ExposeClosures
expose of
                  ExposeClosures
WithClosures -> Text -> Text
callbackHTypeWithClosures Text
htype
                  ExposeClosures
WithoutClosures -> Text
htype
        ([Arg]
hInArgs, [Arg]
_) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
expose
        inArgsWithArrows :: [(Text, Arg)]
inArgsWithArrows = forall a b. [a] -> [b] -> [(a, b)]
zip (Text
"" forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Text
"-> ") [Arg]
hInArgs
        hOutArgs :: [Arg]
hOutArgs = Callable -> [Arg]
callableHOutArgs Callable
cb

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

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isSignal) forall a b. (a -> b) -> a -> b
$ do
      forall e. CodeGen e ()
blank

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

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

-- | 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 ->
                         Maybe Text -> CodeGen e Text
genCCallbackPrototype :: forall e. Text -> Callable -> Text -> Maybe Text -> CodeGen e Text
genCCallbackPrototype Text
subsec Callable
cb Text
name' Maybe Text
maybeOwner = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    let ctypeName :: Text
ctypeName = Text -> Text
callbackCType Text
name'
        isSignal :: Bool
isSignal = forall a. Maybe a -> Bool
isJust Maybe Text
maybeOwner

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isSignal) forall a b. (a -> b) -> a -> b
$ do
      forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
ctypeName
      forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
ccallbackDoc

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

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

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

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

-- | 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 e Text
genWrappedCallback :: forall e. Callable -> Text -> Text -> Bool -> CodeGen e Text
genWrappedCallback Callable
cb Text
cbArg Text
callback Bool
isSignal = do
  Text
drop <- if Callable -> Bool
callableHasClosures Callable
cb
          then do
            let arg' :: Text
arg' = Text -> Text
prime Text
cbArg
            forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"let " forall a. Semigroup a => a -> a -> a
<> Text
arg' forall a. Semigroup a => a -> a -> a
<> Text
" = "
                     forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackDropClosures Text
callback forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
cbArg
            forall (m :: * -> *) a. Monad m => a -> m a
return Text
arg'
          else forall (m :: * -> *) a. Monad m => a -> m a
return Text
cbArg
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"let " forall a. Semigroup a => a -> a -> a
<> Text -> Text
prime Text
drop forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackHaskellToForeign Text
callback forall a. Semigroup a => a -> a -> a
<>
       if Bool
isSignal
       then Text
" " forall a. Semigroup a => a -> a -> a
<> Text
drop
       else Text
" Nothing " forall a. Semigroup a => a -> a -> a
<> Text
drop
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
prime Text
drop)

-- | Generator of closures
genClosure :: Text -> Callable -> Text -> Text -> CodeGen e ()
genClosure :: forall e. Text -> Callable -> Text -> Text -> CodeGen e ()
genClosure Text
subsec Callable
cb Text
callback Text
name = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let closure :: Text
closure = Text -> Text
callbackClosureGenerator Text
name
  forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
closure
  forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
closureDoc
  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
closure forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
callback forall a. Semigroup a => a -> a -> a
<> Text
" -> m (GClosure "
                     forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackCType Text
callback forall a. Semigroup a => a -> a -> a
<> Text
")"
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
closure forall a. Semigroup a => a -> a -> a
<> Text
" cb = liftIO $ do"
      forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
            Text
wrapped <- forall e. Callable -> Text -> Text -> Bool -> CodeGen e Text
genWrappedCallback Callable
cb Text
"cb" Text
callback Bool
False
            forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text -> Text
callbackWrapperAllocator Text
callback forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
wrapped
                     forall a. Semigroup a => a -> a -> a
<> Text
" >>= B.GClosure.newGClosure"
  where
    closureDoc :: Text
    closureDoc :: Text
closureDoc = Text
"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 -> CodeGen e Text -> CodeGen e Text
convertNullable :: forall e. Text -> CodeGen e Text -> CodeGen e Text
convertNullable Text
aname CodeGen e Text
c = do
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"maybe" forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
aname forall a. Semigroup a => a -> a -> a
<> Text
" <-"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"if " forall a. Semigroup a => a -> a -> a
<> Text
aname forall a. Semigroup a => a -> a -> a
<> Text
" == nullPtr"
    forall e. Text -> CodeGen e ()
line   Text
"then return Nothing"
    forall e. Text -> CodeGen e ()
line   Text
"else do"
    forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
             Text
unpacked <- CodeGen e Text
c
             forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return $ Just " forall a. Semigroup a => a -> a -> a
<> Text
unpacked
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"maybe" 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 Arg
arg t :: Type
t@(TCArray Bool
False (-1) Int
length Type
_) Text
aname =
  if Int
length forall a. Ord a => a -> a -> Bool
> -Int
1
  then forall e. Arg -> CodeGen e Bool
wrapMaybe Arg
arg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> a -> Bool -> a
bool ExcCodeGen Text
convertAndFree
                         (forall e. Text -> CodeGen e Text -> CodeGen 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.
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
aname
  where
    lname :: Text
lname = Arg -> Text
escapedArgName forall a b. (a -> b) -> a -> b
$ Callable -> [Arg]
args Callable
callable forall a. [a] -> Int -> a
!! Int
length

    convertAndFree :: ExcCodeGen Text
    convertAndFree :: ExcCodeGen Text
convertAndFree = do
      Text
unpacked <- forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
aname forall a b. (a -> b) -> a -> b
$ Text -> Type -> Transfer -> ExcCodeGen 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
      forall (m :: * -> *) a. Monad m => a -> m a
return Text
unpacked

-- Remove the warning, this should never be reached.
convertCallbackInCArray Callable
_ Arg
t Type
_ Text
_ =
    forall a. HasCallStack => Text -> a
terror forall a b. (a -> b) -> a -> b
$ Text
"convertOutCArray : unexpected " forall a. Semigroup a => a -> a -> a
<> 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 Callable
cb Arg
arg = case Arg -> Direction
direction Arg
arg of
  Direction
DirectionIn -> Callable -> Arg -> ExcCodeGen Text
prepareInArg Callable
cb Arg
arg
  Direction
DirectionInout -> Arg -> ExcCodeGen Text
prepareInoutArg Arg
arg
  Direction
DirectionOut -> forall a. HasCallStack => Text -> a
terror Text
"Unexpected DirectionOut!"

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

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

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

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

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

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

  where dropperDoc :: Text
        dropperDoc :: Text
dropperDoc = Text
"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 ->
                      Maybe Text -> CodeGen e ()
genCallbackWrapper :: forall e. Text -> Callable -> Text -> Maybe Text -> CodeGen e ()
genCallbackWrapper Text
subsec Callable
cb Text
name' Maybe Text
maybeOwner = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let wrapperName :: Text
wrapperName = Text -> Text
callbackHaskellToForeign Text
name'
      ([Arg]
hInArgs, [Arg]
_) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
cb ExposeClosures
WithClosures
      hOutArgs :: [Arg]
hOutArgs = Callable -> [Arg]
callableHOutArgs Callable
cb
      wrapperDoc :: Text
wrapperDoc = Text
"Wrap a `" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"` into a `" forall a. Semigroup a => a -> a -> a
<>
                   Text -> Text
callbackCType Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`."
      isSignal :: Bool
isSignal = forall a. Maybe a -> Bool
isJust Maybe Text
maybeOwner

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isSignal) forall a b. (a -> b) -> a -> b
$ do
    forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
subsec) Text
wrapperName
    forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
wrapperDoc

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

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

    let cArgNames :: [Text]
cArgNames = 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 forall a b. (a -> b) -> a -> b
$ [Text
"gi'cb", Text
"gi'selfPtr"] forall a. Semigroup a => a -> a -> a
<> [Text]
cArgNames forall a. Semigroup a => a -> a -> a
<> [Text
"_"]
                  else [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ [Text
"gi'funptrptr", Text
"gi'cb"] forall a. Semigroup a => a -> a -> a
<> [Text]
cArgNames
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
wrapperName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
allArgs forall a. Semigroup a => a -> a -> a
<> Text
" = do"
    forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
                   forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Could not generate callback wrapper for "
                          forall a. Semigroup a => a -> a -> a
<> Text
name'
                   forall e. CGError -> CodeGen e ()
printCGError CGError
e
                   forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"P.error \"The bindings for " forall a. Semigroup a => a -> a -> a
<> Text
wrapperName forall a. Semigroup a => a -> a -> a
<> Text
" could not be generated, function unsupported.\""
                ) forall a b. (a -> b) -> a -> b
$ forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
      [Text]
hInNames <- 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
                          Maybe Type
Nothing -> []
                          Maybe Type
_       -> [Text
"result"]
          returnVars :: [Text]
returnVars = [Text]
maybeReturn forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ((Text
"out"forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Text
escapedArgName) [Arg]
hOutArgs
          mkTuple :: [Text] -> Text
mkTuple = Text -> Text
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
", "
          returnBind :: Text
returnBind = case [Text]
returnVars of
                         []  -> Text
""
                         [Text
r] -> Text
r forall a. Semigroup a => a -> a -> a
<> Text
" <- "
                         [Text]
_   -> [Text] -> Text
mkTuple [Text]
returnVars forall a. Semigroup a => a -> a -> a
<> Text
" <- "

      if Bool
isSignal
      then forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
returnBind
                  forall a. Semigroup a => a -> a -> a
<> Text
"B.ManagedPtr.withTransient"
                  forall a. Semigroup a => a -> a -> a
<> Text
" gi'selfPtr $ \\gi'self -> "
                  forall a. Semigroup a => a -> a -> a
<> Text
"gi'cb (Coerce.coerce gi'self) "
                  forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map (Text
" " forall a. Semigroup a => a -> a -> a
<>) [Text]
hInNames)
      else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
returnBind forall a. Semigroup a => a -> a -> a
<> Text
"gi'cb " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map (Text
" " forall a. Semigroup a => a -> a -> a
<>) [Text]
hInNames)

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

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

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

genCallback :: Name -> Callback -> CodeGen e ()
genCallback :: forall e. Name -> Callback -> CodeGen e ()
genCallback Name
n callback :: Callback
callback@(Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
cb, cbDocumentation :: Callback -> Documentation
cbDocumentation = Documentation
cbDoc }) = do
  let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Callback -> API
APICallback Callback
callback) Name
n
      cb' :: Callable
cb' = Callable -> Callable
fixupCallerAllocates Callable
cb

  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- callback " forall a. Semigroup a => a -> a -> a
<> Text
name'
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"{- " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
ppShow Callable
cb') forall a. Semigroup a => a -> a -> a
<> Text
"\n-}"

  if Callable -> Bool
skipReturn Callable
cb
  then forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Skipping callback " forall a. Semigroup a => a -> a -> a
<> Text
name'
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"{- Callbacks skipping return unsupported :\n"
             forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
ppShow Name
n) forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
ppShow Callable
cb') forall a. Semigroup a => a -> a -> a
<> Text
"-}"
  else do
    forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
                   forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Could not generate callback wrapper for "
                          forall a. Semigroup a => a -> a -> a
<> Text
name'
                   forall e. CGError -> CodeGen e ()
printCGError CGError
e) forall a b. (a -> b) -> a -> b
$ do
      Text
typeSynonym <- forall e. Text -> Callable -> Text -> Maybe Text -> CodeGen e Text
genCCallbackPrototype Text
name' Callable
cb' Text
name' forall a. Maybe a
Nothing
      Text
dynamic <- Name -> Text -> Callable -> ExcCodeGen Text
genDynamicCallableWrapper Name
n Text
typeSynonym Callable
cb
      forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection Text
name') Text
dynamic
      forall e. Text -> Text -> Bool -> CodeGen e ()
genCallbackWrapperFactory Text
name' Text
name' Bool
False
      forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name' (Callable -> Maybe DeprecationInfo
callableDeprecated Callable
cb')
      Text
-> Callable
-> Text
-> ExposeClosures
-> Bool
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype Text
name' Callable
cb' Text
name' ExposeClosures
WithoutClosures Bool
False Documentation
cbDoc
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Callable -> Bool
callableHasClosures Callable
cb') forall a b. (a -> b) -> a -> b
$ do
           Text
-> Callable
-> Text
-> ExposeClosures
-> Bool
-> Documentation
-> ExcCodeGen ()
genHaskellCallbackPrototype Text
name' Callable
cb' Text
name' ExposeClosures
WithClosures Bool
False Documentation
cbDoc
           forall e. Text -> Callable -> Text -> CodeGen e ()
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.
        -}
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- No Haskell->C wrapper generated since the function throws."
        forall e. CodeGen e ()
blank
      else do
        forall e. Text -> Callable -> Text -> Text -> CodeGen e ()
genClosure Text
name' Callable
cb' Text
name' Text
name'
        forall e. Text -> Callable -> Text -> Maybe Text -> CodeGen e ()
genCallbackWrapper Text
name' Callable
cb' Text
name' forall a. Maybe a
Nothing

-- | Generate the given signal instance for the given API object.
genSignalInfoInstance :: Name -> Signal -> CodeGen e ()
genSignalInfoInstance :: forall e. Name -> Signal -> CodeGen e ()
genSignalInfoInstance Name
owner Signal
signal = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
owner
  let name :: Text
name = Name -> Text
upperName Name
owner
      sn :: Text
sn = (Text -> Text
ucFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
signalHaskellName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName) Signal
signal
      lcSignal :: Text
lcSignal = Text -> Text
lcFirst Text
sn
      qualifiedSignalName :: Text
qualifiedSignalName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
                            forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Signal -> Text
sigName Signal
signal
  Text
hackageLink <- forall e. Name -> CodeGen e Text
hackageModuleLink Name
owner
  Text
si <- forall e. Name -> Signal -> CodeGen e Text
signalInfoName Name
owner Signal
signal
  forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
si
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance SignalInfo " forall a. Semigroup a => a -> a -> a
<> Text
si forall a. Semigroup a => a -> a -> a
<> Text
" where"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
      let signalConnectorName :: Text
signalConnectorName = Text
name forall a. Semigroup a => a -> a -> a
<> Text
sn
          cbHaskellType :: Text
cbHaskellType = Text
signalConnectorName forall a. Semigroup a => a -> a -> a
<> Text
"Callback"
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type HaskellCallbackType " forall a. Semigroup a => a -> a -> a
<> Text
si forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
cbHaskellType
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"connectSignal obj cb connectMode detail = do"
      forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
        forall e. Signal -> Text -> Text -> Text -> Text -> CodeGen e ()
genSignalConnector Signal
signal Text
cbHaskellType Text
"connectMode" Text
"detail" Text
"cb"
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"dbgSignalInfo = P.Just (O.ResolvedSymbolInfo {"
      forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"O.resolvedSymbolName = \"" forall a. Semigroup a => a -> a -> a
<> Text
qualifiedSignalName forall a. Semigroup a => a -> a -> a
<> Text
"\""
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
", O.resolvedSymbolURL = \"" forall a. Semigroup a => a -> a -> a
<> Text
hackageLink forall a. Semigroup a => a -> a -> a
<> Text
"#"
          forall a. Semigroup a => a -> a -> a
<> Text
haddockSignalAnchor forall a. Semigroup a => a -> a -> a
<> Text
lcSignal forall a. Semigroup a => a -> a -> a
<> Text
"\"})"
  forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
SignalSection forall a b. (a -> b) -> a -> b
$ Text
lcSignal) Text
si

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

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

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

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

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

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

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

  Text
_ <- forall e. Text -> Callable -> Text -> Maybe Text -> CodeGen e Text
genCCallbackPrototype (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType (forall a. a -> Maybe a
Just Text
on')

  forall e. Text -> Text -> Bool -> CodeGen e ()
genCallbackWrapperFactory (Text -> Text
lcFirst Text
sn') Text
cbType Bool
True

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

  -- 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.
  forall e a. CodeGen e a -> CodeGen e a
group 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 <- forall e. Name -> CodeGen e Text
classConstraint Name
on

    forall e. Text -> CodeGen e ()
addLanguagePragma Text
"ImplicitParams"
    forall e. Text -> CodeGen e ()
addLanguagePragma Text
"RankNTypes"

    let signatureConstraints :: Text
signatureConstraints = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
klass forall a. Semigroup a => a -> a -> a
<> Text
" a, MonadIO m) =>"
        implicitSelfCBType :: Text
implicitSelfCBType = Text
"((?self :: a) => " forall a. Semigroup a => a -> a -> a
<> Text
cbType forall a. Semigroup a => a -> a -> a
<> Text
")"
        signatureArgs :: Text
signatureArgs = if Signal -> Bool
sigDetailed Signal
s
          then Text
"a -> P.Maybe T.Text -> " forall a. Semigroup a => a -> a -> a
<> Text
implicitSelfCBType forall a. Semigroup a => a -> a -> a
<> Text
" -> m SignalHandlerId"
          else Text
"a -> " forall a. Semigroup a => a -> a -> a
<> Text
implicitSelfCBType forall a. Semigroup a => a -> a -> a
<> Text
" -> m SignalHandlerId"
        signature :: Text
signature = Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
signatureConstraints forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
signatureArgs
        onName :: Text
onName = Text
"on" forall a. Semigroup a => a -> a -> a
<> Text
signalConnectorName
        afterName :: Text
afterName = Text
"after" forall a. Semigroup a => a -> a -> a
<> Text
signalConnectorName

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

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

  forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (forall e. Name -> Signal -> CodeGen e ()
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 [
      Text
"Connect a signal handler for the [" forall a. Semigroup a => a -> a -> a
<> Text
hsn forall a. Semigroup a => a -> a -> a
<> Text
"](#signal:" forall a. Semigroup a => a -> a -> a
<> Text
hsn forall a. Semigroup a => a -> a -> a
<>
        Text
") signal, to be run before the default handler."
      , Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
      , Text
""
      , Text
"@"
      , Text
"'Data.GI.Base.Signals.on' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
on forall a. Semigroup a => a -> a -> a
<> Text
" #"
        forall a. Semigroup a => a -> a -> a
<> Text
hsn forall a. Semigroup a => a -> a -> a
<> Text
" callback"
      , Text
"@"
      , Text
""
      , Text
detailedDoc ]

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

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

    selfDoc :: Text
    selfDoc :: Text
selfDoc = [Text] -> Text
T.unlines [
      Text
"By default the object invoking the signal is not passed to the callback."
      , Text
"If you need to access it, you can use the implit @?self@ parameter."
      , Text
"Note that this requires activating the @ImplicitParams@ GHC extension."
      ]

-- | 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
                   -> Text -- ^ Name of variable holding the callback
                   -> CodeGen e ()
genSignalConnector :: forall e. Signal -> Text -> Text -> Text -> Text -> CodeGen e ()
genSignalConnector (Signal {sigName :: Signal -> Text
sigName = Text
sn, sigCallable :: Signal -> Callable
sigCallable = Callable
cb})
                   Text
cbType Text
when Text
detail Text
cbName = do
  Text
cb' <- forall e. Callable -> Text -> Text -> Bool -> CodeGen e Text
genWrappedCallback Callable
cb Text
cbName Text
cbType Bool
True
  let cb'' :: Text
cb'' = Text -> Text
prime Text
cb'
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
cb'' forall a. Semigroup a => a -> a -> a
<> Text
" <- " forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackWrapperAllocator Text
cbType forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
cb'
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"connectSignalFunPtr obj \"" forall a. Semigroup a => a -> a -> a
<> Text
sn forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
cb'' forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
when
          forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
detail