{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Data.GI.Base.Signals
( on
, after
, SignalProxy(..)
, SignalConnectMode(..)
, connectSignalFunPtr
, disconnectSignalHandler
, SignalHandlerId
, SignalInfo(..)
, GObjectNotifySignalInfo
, SignalCodeGenError
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Proxy (Proxy(..))
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Foreign
import Foreign.C
#if !MIN_VERSION_base(4,13,0)
import Foreign.Ptr (nullPtr)
#endif
import GHC.TypeLits
import qualified Data.Text as T
import Data.Text (Text)
import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel))
import Data.GI.Base.BasicConversions (withTextCString)
import Data.GI.Base.BasicTypes
import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)
import Data.GI.Base.ManagedPtr (withManagedPtr)
import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute)
import GHC.OverloadedLabels (IsLabel(..))
type SignalHandlerId = CULong
data SignalProxy (object :: *) (info :: *) where
SignalProxy :: SignalProxy o info
(:::) :: forall o info. SignalProxy o info -> Text -> SignalProxy o info
PropertyNotify :: (info ~ ResolveAttribute propName o,
AttrInfo info,
pl ~ AttrLabel info, KnownSymbol pl) =>
AttrLabelProxy propName ->
SignalProxy o GObjectNotifySignalInfo
instance (info ~ ResolveSignal slot object) =>
IsLabel slot (SignalProxy object info) where
#if MIN_VERSION_base(4,10,0)
fromLabel = SignalProxy
#else
fromLabel _ = SignalProxy
#endif
class SignalInfo (info :: *) where
type HaskellCallbackType info :: *
connectSignal :: GObject o =>
o ->
HaskellCallbackType info ->
SignalConnectMode ->
Maybe Text ->
IO SignalHandlerId
data SignalConnectMode = SignalConnectBefore
| SignalConnectAfter
on :: forall object info m.
(GObject object, MonadIO m, SignalInfo info) =>
object -> SignalProxy object info
-> HaskellCallbackType info -> m SignalHandlerId
on o p c =
liftIO $ connectSignal @info o c SignalConnectBefore (proxyDetail p)
after :: forall object info m.
(GObject object, MonadIO m, SignalInfo info) =>
object -> SignalProxy object info
-> HaskellCallbackType info -> m SignalHandlerId
after o p c =
liftIO $ connectSignal @info o c SignalConnectAfter (proxyDetail p)
proxyDetail :: forall object info. SignalProxy object info -> Maybe Text
proxyDetail p = case p of
SignalProxy -> Nothing
(_ ::: detail) -> Just detail
PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) ->
Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))
foreign import ccall g_signal_connect_data ::
Ptr a ->
CString ->
FunPtr b ->
Ptr () ->
FunPtr c ->
CUInt ->
IO SignalHandlerId
foreign import ccall "& haskell_gi_release_signal_closure"
ptr_to_release_closure :: FunPtr (Ptr () -> Ptr () -> IO ())
connectSignalFunPtr :: GObject o =>
o -> Text -> FunPtr a -> SignalConnectMode ->
Maybe Text -> IO SignalHandlerId
connectSignalFunPtr object signal fn mode maybeDetail = do
let flags = case mode of
SignalConnectAfter -> 1
SignalConnectBefore -> 0
signalSpec = case maybeDetail of
Nothing -> signal
Just detail -> signal <> "::" <> detail
withTextCString signalSpec $ \csignal ->
withManagedPtr object $ \objPtr ->
g_signal_connect_data objPtr csignal fn nullPtr ptr_to_release_closure flags
foreign import ccall g_signal_handler_disconnect :: Ptr o -> SignalHandlerId -> IO ()
disconnectSignalHandler :: GObject o => o -> SignalHandlerId -> IO ()
disconnectSignalHandler obj handlerId =
withManagedPtr obj $ \objPtr ->
g_signal_handler_disconnect objPtr handlerId
data GObjectNotifySignalInfo
instance SignalInfo GObjectNotifySignalInfo where
type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback
connectSignal = connectGObjectNotify
type GObjectNotifyCallback = GParamSpec -> IO ()
gobjectNotifyCallbackWrapper ::
GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()
gobjectNotifyCallbackWrapper _cb _ pspec _ = do
pspec' <- newGParamSpecFromPtr pspec
_cb pspec'
type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()
foreign import ccall "wrapper"
mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)
connectGObjectNotify :: GObject o =>
o -> GObjectNotifyCallback ->
SignalConnectMode ->
Maybe Text ->
IO SignalHandlerId
connectGObjectNotify obj cb mode detail = do
cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)
connectSignalFunPtr obj "notify" cb' mode detail
type family SignalCodeGenError (signalName :: Symbol) :: * where
SignalCodeGenError signalName = TypeError
('Text "The signal ‘"
':<>: 'Text signalName
':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings."
':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.")