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)
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
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
"`@."
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
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."
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
"`."
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)
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`."
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
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
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)
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
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
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''
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."
genCallbackWrapper :: Text -> Callable -> Text ->
Maybe Text -> ExcCodeGen ()
genCallbackWrapper :: Text -> Callable -> Text -> Maybe Text -> ExcCodeGen ()
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. 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
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'
Text -> Callable -> Text -> Maybe Text -> ExcCodeGen ()
genCallbackWrapper Text
name' Callable
cb' Text
name' forall a. Maybe a
Nothing
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
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
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
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
Text -> Callable -> Text -> Maybe Text -> ExcCodeGen ()
genCallbackWrapper (Text -> Text
lcFirst Text
sn') Callable
cb Text
cbType (forall a. a -> Maybe a
Just Text
on')
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
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."
]
genSignalConnector :: Signal
-> Text
-> Text
-> Text
-> Text
-> 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