1{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds,
2             TypeFamilies, UndecidableInstances, EmptyDataDecls,
3             MultiParamTypeClasses, FlexibleInstances, ConstraintKinds,
4             AllowAmbiguousTypes, FlexibleContexts #-}
5
6-- | Helpers for dealing with overladed properties, signals and
7-- methods.
8
9module Data.GI.Base.Overloading
10    ( -- * Type level inheritance
11      ParentTypes
12    , HasParentTypes
13    , IsDescendantOf
14
15    , asA
16
17    -- * Looking up attributes in parent types
18    , AttributeList
19    , HasAttributeList
20    , ResolveAttribute
21    , HasAttribute
22    , HasAttr
23
24    -- * Looking up signals in parent types
25    , SignalList
26    , ResolveSignal
27    , HasSignal
28
29    -- * Looking up methods in parent types
30    , MethodResolutionFailed
31    , UnsupportedMethodError
32    , MethodInfo(..)
33    ) where
34
35import Data.Coerce (coerce)
36
37import GHC.Exts (Constraint)
38import GHC.TypeLits
39
40import Data.GI.Base.BasicTypes (ManagedPtrNewtype, ManagedPtr(..))
41
42-- | Look in the given list of (symbol, tag) tuples for the tag
43-- corresponding to the given symbol. If not found raise the given
44-- type error.
45type family FindElement (m :: Symbol) (ms :: [(Symbol, *)])
46    (typeError :: ErrorMessage) :: * where
47    FindElement m '[] typeError = TypeError typeError
48    FindElement m ('(m, o) ': ms) typeError = o
49    FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError
50
51-- | Check whether a type appears in a list. We specialize the
52-- names/types a bit so the error messages are more informative.
53type family CheckForAncestorType t (a :: *) (as :: [*]) :: Constraint where
54  CheckForAncestorType t a '[] = TypeError ('Text "Required ancestor ‘"
55                                            ':<>: 'ShowType a
56                                            ':<>: 'Text "’ not found for type ‘"
57                                            ':<>: 'ShowType t ':<>: 'Text "’.")
58  CheckForAncestorType t a (a ': as) = ()
59  CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as
60
61-- | Check that a type is in the list of `ParentTypes` of another
62-- type.
63type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where
64    -- Every object is defined to be a descendant of itself.
65    IsDescendantOf d d = ()
66    IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d)
67
68-- | All the types that are ascendants of this type, including
69-- interfaces that the type implements.
70type family ParentTypes a :: [*]
71
72-- | A constraint on a type, to be fulfilled whenever it has a type
73-- instance for `ParentTypes`. This leads to nicer errors, thanks to
74-- the overlappable instance below.
75class HasParentTypes (o :: *)
76
77-- | Default instance, which will give rise to an error for types
78-- without an associated `ParentTypes` instance.
79instance {-# OVERLAPPABLE #-}
80    TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:
81               'Text "’ does not have any known parent types.")
82    => HasParentTypes a
83
84-- | Safe coercions to a parent class. For instance:
85--
86-- > #show $ label `asA` Gtk.Widget
87--
88asA :: (ManagedPtrNewtype a, ManagedPtrNewtype b,
89        HasParentTypes b, IsDescendantOf a b)
90    => b -> (ManagedPtr a -> a) -> a
91asA obj _constructor = coerce obj
92
93-- | The list of attributes defined for a given type. Each element of
94-- the list is a tuple, with the first element of the tuple the name
95-- of the attribute, and the second the type encoding the information
96-- of the attribute. This type will be an instance of
97-- `Data.GI.Base.Attributes.AttrInfo`.
98type family AttributeList a :: [(Symbol, *)]
99
100-- | A constraint on a type, to be fulfilled whenever it has a type
101-- instance for `AttributeList`. This is here for nicer error
102-- reporting.
103class HasAttributeList a
104
105-- | Default instance, which will give rise to an error for types
106-- without an associated `AttributeList`.
107instance {-# OVERLAPPABLE #-}
108    TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:
109               'Text "’ does not have any known attributes.")
110    => HasAttributeList a
111
112-- | Return the type encoding the attribute information for a given
113-- type and attribute.
114type family ResolveAttribute (s :: Symbol) (o :: *) :: * where
115    ResolveAttribute s o = FindElement s (AttributeList o)
116                           ('Text "Unknown attribute ‘" ':<>:
117                            'Text s ':<>: 'Text "’ for object ‘" ':<>:
118                            'ShowType o ':<>: 'Text "’.")
119
120-- | Whether a given type is in the given list. If found, return
121-- @success@, otherwise return @failure@.
122type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k)
123    (failure :: ErrorMessage) :: k where
124    IsElem e '[] success failure = TypeError failure
125    IsElem e ( '(e, t) ': es) success failure = success
126    IsElem e ( '(other, t) ': es) s f = IsElem e es s f
127
128-- | A constraint imposing that the given object has the given attribute.
129type family HasAttribute (attr :: Symbol) (o :: *) :: Constraint where
130    HasAttribute attr o = IsElem attr (AttributeList o)
131                          (() :: Constraint) -- success
132                          ('Text "Attribute ‘" ':<>: 'Text attr ':<>:
133                           'Text "’ not found for type ‘" ':<>:
134                           'ShowType o ':<>: 'Text "’.")
135
136-- | A constraint that enforces that the given type has a given attribute.
137class HasAttr (attr :: Symbol) (o :: *)
138instance HasAttribute attr o => HasAttr attr o
139
140-- | The list of signals defined for a given type. Each element of the
141-- list is a tuple, with the first element of the tuple the name of
142-- the signal, and the second the type encoding the information of the
143-- signal. This type will be an instance of
144-- `Data.GI.Base.Signals.SignalInfo`.
145type family SignalList a :: [(Symbol, *)]
146
147-- | Return the type encoding the signal information for a given
148-- type and signal.
149type family ResolveSignal (s :: Symbol) (o :: *) :: * where
150    ResolveSignal s o = FindElement s (SignalList o)
151                        ('Text "Unknown signal ‘" ':<>:
152                         'Text s ':<>: 'Text "’ for object ‘" ':<>:
153                         'ShowType o ':<>: 'Text "’.")
154
155-- | A constraint enforcing that the signal exists for the given
156-- object, or one of its ancestors.
157type family HasSignal (s :: Symbol) (o :: *) :: Constraint where
158    HasSignal s o = IsElem s (SignalList o)
159                    (() :: Constraint) -- success
160                    ('Text "Signal ‘" ':<>: 'Text s ':<>:
161                     'Text "’ not found for type ‘" ':<>:
162                     'ShowType o ':<>: 'Text "’.")
163
164-- | A constraint that always fails with a type error, for
165-- documentation purposes.
166type family UnsupportedMethodError (s :: Symbol) (o :: *) :: * where
167  UnsupportedMethodError s o =
168    TypeError ('Text "Unsupported method ‘" ':<>:
169               'Text s ':<>: 'Text "’ for object ‘" ':<>:
170               'ShowType o ':<>: 'Text "’.")
171
172-- | Returned when the method is not found, hopefully making
173-- the resulting error messages somewhat clearer.
174type family MethodResolutionFailed (method :: Symbol) (o :: *) where
175    MethodResolutionFailed m o =
176        TypeError ('Text "Unknown method ‘" ':<>:
177                   'Text m ':<>: 'Text "’ for type ‘" ':<>:
178                   'ShowType o ':<>: 'Text "’.")
179
180-- | Class for types containing the information about an overloaded
181-- method of type @o -> s@.
182class MethodInfo i o s where
183    overloadedMethod :: o -> s
184