haskell-gi-base 0.12 → 0.13

raw patch · 8 files changed

+287/−119 lines, 8 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• haskell-gi-base.cabal +1/−1
• src/Data/GI/Base/Attributes.hs +62/−19
• src/Data/GI/Base/BasicConversions.hsc +2/−3
• src/Data/GI/Base/ManagedPtr.hs +3/−3
• src/Data/GI/Base/Overloading.hs +111/−9
• src/Data/GI/Base/Properties.hsc +2/−50
• src/Data/GI/Base/ShortPrelude.hs +9/−2
• src/Data/GI/Base/Signals.hsc +97/−32

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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 <glib-object.h>  -- | 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