diff --git a/haskell-gi-base.cabal b/haskell-gi-base.cabal --- a/haskell-gi-base.cabal +++ b/haskell-gi-base.cabal @@ -1,5 +1,5 @@ name: haskell-gi-base -version: 0.12 +version: 0.13 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi-base diff --git a/src/Data/GI/Base/Attributes.hs b/src/Data/GI/Base/Attributes.hs --- a/src/Data/GI/Base/Attributes.hs +++ b/src/Data/GI/Base/Attributes.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures, TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds, - UndecidableInstances #-} + UndecidableInstances, FlexibleInstances #-} -- | -- @@ -45,10 +45,10 @@ -- -- > value <- get button _label -- --- The definition of @_label@ is simply a 'Proxy' encoding the name of --- the attribute to get: +-- The definition of @_label@ is basically a 'Proxy' encoding the name +-- of the attribute to get: -- --- > _label = Proxy :: Proxy "label" +-- > _label = fromLabelProxy (Proxy :: Proxy "label") -- -- These proxies can be automatically generated by invoking the code -- generator with the @-a@ option. The leading underscore is simply so @@ -56,6 +56,12 @@ -- this is not a concern the autogenerated names (in the autogenerated -- @GI/Properties.hs@) can be edited as one wishes. -- +-- In addition, for ghc >= 8.0, one can directly use the overloaded +-- labels provided by GHC itself. Using the "OverloadedLabels" +-- extension, the code above can also be written as +-- +-- > value <- get button #label +-- -- The syntax for setting or updating an attribute is only slightly more -- complex. At the simplest level it is just: -- @@ -98,8 +104,11 @@ AttrOpTag(..), AttrOp(..), + get, - set + set, + + AttrLabelProxy(..) ) where import Control.Monad.IO.Class (MonadIO, liftIO) @@ -107,13 +116,29 @@ import Data.Proxy (Proxy(..)) import Data.GI.Base.GValue (GValue(..)) -import Data.GI.Base.Overloading (ResolveAttribute) +import Data.GI.Base.Overloading (ResolveAttribute, IsLabelProxy(..)) import GHC.TypeLits import GHC.Exts (Constraint) +#if MIN_VERSION_base(4,9,0) +import GHC.OverloadedLabels (IsLabel(..)) +#endif + infixr 0 :=,:~,:=>,:~>,::=,::~ +-- | A proxy for attribute labels. +data AttrLabelProxy (a :: Symbol) = AttrLabelProxy + +-- | Support for overloaded labels. +instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where + fromLabelProxy _ = AttrLabelProxy + +#if MIN_VERSION_base(4,9,0) +instance a ~ x => IsLabel x (AttrLabelProxy a) where + fromLabel _ = AttrLabelProxy +#endif + -- | Info describing an attribute. class AttrInfo (info :: *) where -- | The operations that are allowed on the attribute. @@ -129,25 +154,34 @@ type AttrLabel info :: Symbol -- | Get the value of the given attribute. attrGet :: AttrBaseTypeConstraint info o => - proxy info -> o -> IO (AttrGetType info) + Proxy info -> o -> IO (AttrGetType info) -- | Set the value of the given attribute, after the object having -- the attribute has already been created. attrSet :: (AttrBaseTypeConstraint info o, AttrSetTypeConstraint info b) => - proxy info -> o -> b -> IO () + Proxy info -> o -> b -> IO () -- | Build a `GValue` representing the attribute. attrConstruct :: AttrSetTypeConstraint info b => - proxy info -> b -> IO (String, GValue) + Proxy info -> b -> IO (String, GValue) -- | Result of checking whether an op is allowed on an attribute. data OpAllowed tag attrName = - OpIsAllowed | AttrOpNotAllowed Symbol tag Symbol attrName + OpIsAllowed +#if !MIN_VERSION_base(4,9,0) + | AttrOpNotAllowed Symbol tag Symbol attrName +#endif -- | Look in the given list to see if the given `AttrOp` is a member, -- if not return an error type. type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) :: OpAllowed AttrOpTag Symbol where AttrOpIsAllowed tag '[] label = +#if !MIN_VERSION_base(4,9,0) 'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute type " label +#else + TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>: + 'Text "’ is not " ':<>: + 'Text (AttrOpText tag) ':<>: 'Text ".") +#endif AttrOpIsAllowed tag (tag ': ops) label = 'OpIsAllowed AttrOpIsAllowed tag (other ': ops) label = AttrOpIsAllowed tag ops label @@ -160,6 +194,15 @@ -- | Possible operations on an attribute. data AttrOpTag = AttrGet | AttrSet | AttrConstruct +#if MIN_VERSION_base(4,9,0) +-- | A user friendly description of the `AttrOpTag`, useful when +-- printing type errors. +type family AttrOpText (tag :: AttrOpTag) :: Symbol where + AttrOpText 'AttrGet = "gettable" + AttrOpText 'AttrSet = "settable" + AttrOpText 'AttrConstruct = "constructible" +#endif + -- | Constructors for the different operations allowed on an attribute. data AttrOp obj (tag :: AttrOpTag) where -- Assign a value to an attribute @@ -168,14 +211,14 @@ AttrBaseTypeConstraint info obj, AttrOpAllowed tag info, (AttrSetTypeConstraint info) b) => - proxy (attr :: Symbol) -> b -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag -- Assign the result of an IO action to an attribute (:=>) :: (info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, AttrOpAllowed tag info, (AttrSetTypeConstraint info) b) => - proxy (attr :: Symbol) -> IO b -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> IO b -> AttrOp obj tag -- Apply an update function to an attribute (:~) :: (info ~ ResolveAttribute attr obj, AttrInfo info, @@ -185,7 +228,7 @@ AttrOpAllowed 'AttrGet info, (AttrSetTypeConstraint info) b, a ~ (AttrGetType info)) => - proxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag -- Apply an IO update function to an attribute (:~>) :: (info ~ ResolveAttribute attr obj, AttrInfo info, @@ -195,7 +238,7 @@ AttrOpAllowed 'AttrGet info, (AttrSetTypeConstraint info) b, a ~ (AttrGetType info)) => - proxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag -- Assign a value to an attribute with the object as an argument (::=) :: (info ~ ResolveAttribute attr obj, AttrInfo info, @@ -203,7 +246,7 @@ tag ~ 'AttrSet, AttrOpAllowed tag info, (AttrSetTypeConstraint info) b) => - proxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag -- Apply an update function to an attribute with the object as an -- argument (::~) :: (info ~ ResolveAttribute attr obj, @@ -214,13 +257,13 @@ AttrOpAllowed 'AttrGet info, (AttrSetTypeConstraint info) b, a ~ (AttrGetType info)) => - proxy (attr :: Symbol) -> (obj -> a -> b) -> AttrOp obj tag + AttrLabelProxy (attr :: Symbol) -> (obj -> a -> b) -> AttrOp obj tag -- | Set a number of properties for some object. set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m () set obj = liftIO . mapM_ app where - resolve :: proxy attr -> Proxy (ResolveAttribute attr o) + resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o) resolve _ = Proxy app :: AttrOp o 'AttrSet -> IO () @@ -235,9 +278,9 @@ \v -> attrSet (resolve attr) obj (f obj v) -- | Get the value of an attribute for an object. -get :: forall info attr obj proxy m. +get :: forall info attr obj m. (info ~ ResolveAttribute attr obj, AttrInfo info, (AttrBaseTypeConstraint info) obj, AttrOpAllowed 'AttrGet info, MonadIO m) => - obj -> proxy (attr :: Symbol) -> m (AttrGetType info) + obj -> AttrLabelProxy (attr :: Symbol) -> m (AttrGetType info) get o _ = liftIO $ attrGet (Proxy :: Proxy info) o diff --git a/src/Data/GI/Base/BasicConversions.hsc b/src/Data/GI/Base/BasicConversions.hsc --- a/src/Data/GI/Base/BasicConversions.hsc +++ b/src/Data/GI/Base/BasicConversions.hsc @@ -97,11 +97,10 @@ where go (f:fs) = fromEnum f .|. go fs go [] = 0 -wordToGFlags :: forall a b. (Storable a, Integral a, Bits a, IsGFlag b) => - a -> [b] +wordToGFlags :: (Storable a, Integral a, Bits a, IsGFlag b) => a -> [b] wordToGFlags w = go 0 where - nbits = (sizeOf (undefined :: a))*8 + nbits = (sizeOf w)*8 go k | k == nbits = [] | otherwise = if mask .&. w /= 0 diff --git a/src/Data/GI/Base/ManagedPtr.hs b/src/Data/GI/Base/ManagedPtr.hs --- a/src/Data/GI/Base/ManagedPtr.hs +++ b/src/Data/GI/Base/ManagedPtr.hs @@ -42,7 +42,7 @@ import Data.Coerce (coerce) -import Foreign (finalizerFree, poke) +import Foreign (poke) import Foreign.C (CInt(..)) import Foreign.Ptr (Ptr, FunPtr, castPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv, touchForeignPtr) @@ -233,7 +233,7 @@ -- | Wrap a pointer, taking ownership of it. wrapPtr :: (ForeignPtr a -> a) -> Ptr a -> IO a wrapPtr constructor ptr = do - fPtr <- newForeignPtr finalizerFree ptr + fPtr <- newForeignPtr ptr_to_g_free ptr return $! constructor fPtr -- | Wrap a pointer to n bytes, making a copy of the data. @@ -241,5 +241,5 @@ newPtr n constructor ptr = do ptr' <- callocBytes n :: IO (Ptr a) memcpy ptr' ptr n - fPtr <- newForeignPtr finalizerFree ptr' + fPtr <- newForeignPtr ptr_to_g_free ptr' return $! constructor fPtr diff --git a/src/Data/GI/Base/Overloading.hs b/src/Data/GI/Base/Overloading.hs --- a/src/Data/GI/Base/Overloading.hs +++ b/src/Data/GI/Base/Overloading.hs @@ -19,33 +19,70 @@ , SignalList , ResolveSignal , HasSignal + + -- * Looking up methods in parent types + , MethodInfo(..) + , MethodProxy(..) + , MethodResolutionFailed + + -- * Overloaded labels + , IsLabelProxy(..) ) where import GHC.Exts (Constraint) import GHC.TypeLits +import Data.Proxy (Proxy) +-- | Support for overloaded labels in ghc < 8.0. This is like the +-- `IsLabel` class introduced in ghc 8.0 (for use with the +-- OverloadedLabels extension) with the difference that the `Proxy` +-- argument is lifted. (Using the unlifted Proxy# type in user code is +-- a bit of a pain, hence the choice.) +class IsLabelProxy (x :: Symbol) a where + fromLabelProxy :: Proxy x -> a + -- | Join two lists. type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where JoinLists '[] bs = bs JoinLists (a ': as) bs = a ': JoinLists as bs -- | Look in the given list of (symbol, tag) tuples for the tag --- corresponding to the given symbol. If not found return the given --- default type. -type family FindElement (m :: Symbol) (ms :: [(Symbol, *)]) (d :: *) :: * where - FindElement m '[] d = d - FindElement m ('(m, o) ': ms) d = o - FindElement m ('(m', o) ': ms) d = FindElement m ms d +-- corresponding to the given symbol. If not found raise the given +-- type error. +type family FindElement (m :: Symbol) (ms :: [(Symbol, *)]) +#if !MIN_VERSION_base(4,9,0) + (typeError :: *) +#else + (typeError :: ErrorMessage) +#endif + :: * where + FindElement m '[] typeError = +#if !MIN_VERSION_base(4,9,0) + typeError +#else + TypeError typeError +#endif + FindElement m ('(m, o) ': ms) typeError = o + FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError -- | Result of a ancestor check. Basically a Bool type with a bit of -- extra info in order to improve typechecker error messages. -data AncestorCheck t a = HasAncestor a t | DoesNotHaveRequiredAncestor Symbol t Symbol a +data AncestorCheck t a = HasAncestor a t +#if !MIN_VERSION_base(4,9,0) + | DoesNotHaveRequiredAncestor Symbol t Symbol a +#endif -- | Check whether a type appears in a list. We specialize the -- names/types a bit so the error messages are more informative. type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where CheckForAncestorType t a '[] = +#if !MIN_VERSION_base(4,9,0) 'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t +#else + TypeError ('Text "Required ancestor ‘" ':<>: 'ShowType a + ':<>: 'Text "’ not found for type ‘" ':<>: 'ShowType t + ':<>: 'Text "’.") +#endif CheckForAncestorType t a (a ': as) = 'HasAncestor a t CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as @@ -67,32 +104,59 @@ -- of the attribute. This type will be an instance of `AttrInfo`. type family AttributeList a :: [(Symbol, *)] +#if !MIN_VERSION_base(4,9,0) -- | Datatype returned when the attribute is not found, hopefully making -- the resulting error messages somewhat clearer. data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) +#endif -- | Return the type encoding the attribute information for a given -- type and attribute. type family ResolveAttribute (s :: Symbol) (o :: *) :: * where ResolveAttribute s o = FindElement s (AttributeList o) +#if !MIN_VERSION_base(4,9,0) (UnknownAttribute "Error: could not find attribute" s "for object" o) +#else + ('Text "Unknown attribute ‘" ':<>: + 'Text s ':<>: 'Text "’ for object ‘" ':<>: + 'ShowType o ':<>: 'Text "’.") +#endif -- | Whether a given type is in the given list. If found, return -- @success@, otherwise return @failure@. -type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k) (failure :: k) :: k where - IsElem e '[] success failure = failure +type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k) +#if !MIN_VERSION_base(4,9,0) + (failure :: k) +#else + (failure :: ErrorMessage) +#endif + :: k where + IsElem e '[] success failure = +#if !MIN_VERSION_base(4,9,0) + failure +#else + TypeError failure +#endif IsElem e ( '(e, t) ': es) success failure = success IsElem e ( '(other, t) ': es) s f = IsElem e es s f -- | Isomorphic to Bool, but having some extra debug information. data AttributeCheck a t = HasAttribute +#if !MIN_VERSION_base(4,9,0) | DoesNotHaveAttribute Symbol a Symbol t +#endif -- | A constraint imposing that the given object has the given attribute. type family HasAttribute (attr :: Symbol) (o :: *) where HasAttribute attr o = IsElem attr (AttributeList o) 'HasAttribute +#if !MIN_VERSION_base(4,9,0) ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o) +#else + ('Text "Attribute ‘" ':<>: 'Text attr ':<>: + 'Text "’ not found for type ‘" ':<>: + 'ShowType o ':<>: 'Text "’.") +#endif ~ 'HasAttribute -- | A constraint that enforces that the given type has a given attribute. @@ -105,24 +169,62 @@ -- the signal. This type will be an instance of `SignalInfo`. type family SignalList a :: [(Symbol, *)] +#if !MIN_VERSION_base(4,9,0) -- | Datatype returned when the signal is not found, hopefully making -- the resulting error messages somewhat clearer. data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) +#endif -- | Return the type encoding the signal information for a given -- type and signal. type family ResolveSignal (s :: Symbol) (o :: *) :: * where ResolveSignal s o = FindElement s (SignalList o) +#if !MIN_VERSION_base(4,9,0) (UnknownSignal "Error: could not find signal" s "for object" o) +#else + ('Text "Unknown signal ‘" ':<>: + 'Text s ':<>: 'Text "’ for object ‘" ':<>: + 'ShowType o ':<>: 'Text "’.") +#endif -- | Isomorphic to Bool, but having some extra debug information. data SignalCheck s t = HasSignal +#if !MIN_VERSION_base(4,9,0) | DoesNotHaveSignal Symbol s Symbol t +#endif -- | A constraint enforcing that the signal exists for the given -- object, or one of its ancestors. type family HasSignal (s :: Symbol) (o :: *) where HasSignal s o = IsElem s (SignalList o) 'HasSignal +#if !MIN_VERSION_base(4,9,0) ('DoesNotHaveSignal "Error: signal" s "not found for type" o) +#else + ('Text "Signal ‘" ':<>: 'Text s ':<>: + 'Text "’ not found for type ‘" ':<>: + 'ShowType o ':<>: 'Text "’.") +#endif ~ 'HasSignal + +-- | Class for types containing the information about an overloaded +-- method of type `o -> s`. +class MethodInfo i o s where + overloadedMethod :: MethodProxy i -> o -> s + +-- | Proxy for passing a type to `overloadedMethod`. We do not use +-- `Data.Proxy.Proxy` directly since it clashes with types defined in +-- the autogenerated bindings. +data MethodProxy a = MethodProxy + +#if !MIN_VERSION_base(4,9,0) +-- | Datatype returned when the method is not found, hopefully making +-- the resulting error messages somewhat clearer. +data MethodResolutionFailed (label :: Symbol) (o :: *) +#else +type family MethodResolutionFailed (method :: Symbol) (o :: *) where + MethodResolutionFailed m o = + TypeError ('Text "Unknown method ‘" ':<>: + 'Text m ':<>: 'Text "’ for type ‘" ':<>: + 'ShowType o ':<>: 'Text "’.") +#endif diff --git a/src/Data/GI/Base/Properties.hsc b/src/Data/GI/Base/Properties.hsc --- a/src/Data/GI/Base/Properties.hsc +++ b/src/Data/GI/Base/Properties.hsc @@ -6,9 +6,6 @@ module Data.GI.Base.Properties ( new - , PropertyNotify(..) - , GObjectNotifySignalInfo - , setObjectPropertyString , setObjectPropertyStringArray , setObjectPropertyPtr @@ -84,16 +81,9 @@ import Data.GI.Base.BasicConversions import Data.GI.Base.ManagedPtr import Data.GI.Base.Attributes -import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) import Data.GI.Base.GValue import Data.GI.Base.GVariant (newGVariantFromPtr) -import Data.GI.Base.Overloading (ResolveAttribute, HasAttr) -import Data.GI.Base.Signals (SignalConnectMode, SignalHandlerId, - connectSignalFunPtr, - SignalInfo(HaskellCallbackType, connectSignal)) - -import GHC.Exts (Constraint) -import GHC.TypeLits +import Data.GI.Base.Overloading (ResolveAttribute) import Foreign hiding (new) import Foreign.C @@ -129,7 +119,7 @@ mapM_ (touchManagedPtr . snd) props wrapObject constructor (result :: Ptr o) where - resolve :: proxy attr -> Proxy (ResolveAttribute attr o) + resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o) resolve _ = Proxy construct :: AttrOp o 'AttrConstruct -> @@ -159,44 +149,6 @@ do cstr <- peek (castPtr dataPtr) :: IO CString free cstr freeStrings (n-1) (dataPtr `plusPtr` gparameterSize) - --- | Proxy for "notify::property-name" signals. -data PropertyNotify (s :: Symbol) (propName :: Symbol) (constraint :: * -> Constraint) where - PropertyNotify :: KnownSymbol propName => proxy propName -> - PropertyNotify "notify::[property]" propName (HasAttr propName) - --- | Connection information for a "notify" signal indicating that a --- specific property changed (see `PropertyNotify` for the relevant --- constructor). -data GObjectNotifySignalInfo -instance SignalInfo GObjectNotifySignalInfo where - type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback - connectSignal = connectGObjectNotify - --- | Type for a `GObject` `notify` callback. -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) - --- | Connect the given notify callback for a GObject. -connectGObjectNotify :: forall o i proxy propName constraint. - (GObject o, constraint o, KnownSymbol propName) => - proxy (i :: *) (propName :: Symbol) (constraint :: * -> Constraint) -> - o -> GObjectNotifyCallback -> - SignalConnectMode -> IO SignalHandlerId -connectGObjectNotify _ obj cb after = do - cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb) - let signalName = "notify::" ++ symbolVal (Proxy :: Proxy propName) - connectSignalFunPtr obj signalName cb' after foreign import ccall "g_object_set_property" g_object_set_property :: Ptr a -> CString -> Ptr GValue -> IO () diff --git a/src/Data/GI/Base/ShortPrelude.hs b/src/Data/GI/Base/ShortPrelude.hs --- a/src/Data/GI/Base/ShortPrelude.hs +++ b/src/Data/GI/Base/ShortPrelude.hs @@ -33,6 +33,10 @@ , module GHC.TypeLits +#if MIN_VERSION_base(4,9,0) + , module GHC.OverloadedLabels +#endif + , Enum(fromEnum, toEnum) , Show(..) , Eq(..) @@ -62,7 +66,7 @@ import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Data.ByteString.Char8 (ByteString) -import Foreign.C (CInt(..), CUInt(..), CFloat(..), CDouble(..), CString) +import Foreign.C (CInt(..), CUInt(..), CFloat(..), CDouble(..), CString, CIntPtr(..), CUIntPtr(..)) import Foreign.Ptr (Ptr, plusPtr, FunPtr, nullPtr, castFunPtrToPtr, castPtrToFunPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_) @@ -84,7 +88,10 @@ import Data.GI.Base.ManagedPtr import Data.GI.Base.Overloading import Data.GI.Base.Properties hiding (new) -import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..)) +import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo) import Data.GI.Base.Utils import GHC.TypeLits (Symbol) +#if MIN_VERSION_base(4,9,0) +import GHC.OverloadedLabels (IsLabel(..)) +#endif diff --git a/src/Data/GI/Base/Signals.hsc b/src/Data/GI/Base/Signals.hsc --- a/src/Data/GI/Base/Signals.hsc +++ b/src/Data/GI/Base/Signals.hsc @@ -6,46 +6,87 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} -- | Routines for connecting `GObject`s to signals. module Data.GI.Base.Signals - ( SignalConnectMode(..), - connectSignalFunPtr, - on, - after, - SignalHandlerId, - SignalInfo(..) + ( on + , after + , SignalProxy(..) + , SignalConnectMode(..) + , connectSignalFunPtr + , SignalHandlerId + , SignalInfo(..) + , GObjectNotifySignalInfo ) where import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Proxy (Proxy(..)) import Foreign import Foreign.C -import GHC.Exts (Constraint) import GHC.TypeLits +import Data.GI.Base.Attributes (AttrLabelProxy, AttrInfo(AttrLabel)) import Data.GI.Base.BasicTypes +import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) import Data.GI.Base.ManagedPtr (withManagedPtr) -import Data.GI.Base.Overloading (HasSignal, ResolveSignal) +import Data.GI.Base.Overloading (ResolveSignal, + IsLabelProxy(..), ResolveAttribute) import Data.GI.Base.Utils (safeFreeFunPtrPtr) +#if MIN_VERSION_base(4,9,0) +import GHC.OverloadedLabels (IsLabel(..)) +#else +import Data.GI.Base.Overloading (HasSignal) +#endif + #include -- | Type of a `GObject` signal handler id. type SignalHandlerId = #type gulong --- | A proxy for passing on the signal information. -data SignalProxy (s :: *) (e :: Symbol) (c :: * -> Constraint) = SignalProxy +-- | A class that provides a constraint satisfied by every type. +class NoConstraint a +instance NoConstraint a +-- | Support for overloaded signal connectors. +data SignalProxy (object :: *) (info :: *) where + SignalProxy :: SignalProxy o info + PropertyNotify :: (info ~ ResolveAttribute propName o, + AttrInfo info, + pl ~ AttrLabel info) => + AttrLabelProxy propName -> + SignalProxy o (GObjectNotifySignalInfo pl) + +-- | Support for overloaded labels. +instance +#if !MIN_VERSION_base(4,9,0) + -- This gives better error reporting in ghc < 8.0. + (HasSignal slot object, info ~ ResolveSignal slot object) +#else + info ~ ResolveSignal slot object +#endif + => IsLabelProxy slot (SignalProxy object info) where + fromLabelProxy _ = SignalProxy + +#if MIN_VERSION_base(4,9,0) +instance info ~ ResolveSignal slot object => + IsLabel slot (SignalProxy object info) where + fromLabel _ = SignalProxy +#endif + -- | Information about an overloaded signal. class SignalInfo (info :: *) where type HaskellCallbackType info -- | Connect a Haskell function to a signal of the given `GObject`, -- specifying whether the handler will be called before or after -- the default handler. - connectSignal :: (KnownSymbol extra, GObject o, constraint o) => - SignalProxy info extra constraint -> + connectSignal :: GObject o => + SignalProxy o info -> o -> HaskellCallbackType info -> SignalConnectMode -> @@ -60,30 +101,20 @@ -- handler is to be run before the default handler. -- -- > on = connectSignal SignalConnectBefore -on :: forall signal extra o info constraint proxy m. - (GObject o, - HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info, - KnownSymbol extra, constraint o, MonadIO m) => - o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint) - -> HaskellCallbackType info -> m SignalHandlerId -on o p c = liftIO $ connectSignal (resolve p) o c SignalConnectBefore - where resolve :: proxy signal extra constraint -> - SignalProxy (ResolveSignal signal o) extra constraint - resolve _ = SignalProxy +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 p o c SignalConnectBefore -- | Connect a signal to a handler, running the handler after the default one. -- -- > after = connectSignal SignalConnectAfter -after :: forall signal extra o info constraint proxy m. - (GObject o, - HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info, - KnownSymbol extra, constraint o, MonadIO m) => - o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint) - -> HaskellCallbackType info -> m SignalHandlerId -after o p c = liftIO $ connectSignal (resolve p) o c SignalConnectAfter - where resolve :: proxy signal extra constraint -> - SignalProxy (ResolveSignal signal o) extra constraint - resolve _ = SignalProxy +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 p o c SignalConnectAfter -- Connecting GObjects to signals foreign import ccall "g_signal_connect_data" g_signal_connect_data :: @@ -105,3 +136,37 @@ withCString signal $ \csignal -> withManagedPtr object $ \objPtr -> g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags + +-- | Connection information for a "notify" signal indicating that a +-- specific property changed (see `PropertyNotify` for the relevant +-- constructor). +data GObjectNotifySignalInfo (propName :: Symbol) +instance KnownSymbol propName => + SignalInfo (GObjectNotifySignalInfo propName) where + type HaskellCallbackType (GObjectNotifySignalInfo propName) = GObjectNotifyCallback + connectSignal = connectGObjectNotify (symbolVal (Proxy :: Proxy propName)) + +-- | Type for a `GObject` `notify` callback. +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) + +-- | Connect the given notify callback for a GObject. +connectGObjectNotify :: forall o i. GObject o => + String -> + SignalProxy o (i :: *) -> + o -> GObjectNotifyCallback -> + SignalConnectMode -> IO SignalHandlerId +connectGObjectNotify propName _ obj cb after = do + cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb) + let signalName = "notify::" ++ propName + connectSignalFunPtr obj signalName cb' after