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