1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
{-# LANGUAGE ScopedTypeVariables #-}
module Data.GI.CodeGen.Inheritance
( fullObjectPropertyList
, fullInterfacePropertyList
, fullObjectSignalList
, fullInterfaceSignalList
, fullObjectMethodList
, fullInterfaceMethodList
, instanceTree
) where
import Control.Monad (foldM, when)
import qualified Data.Map as M
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line)
import Data.GI.CodeGen.Util (tshow)
import Data.GI.CodeGen.Fixups (dropMovedItems)
-- | Find the parent of a given object when building the
-- instanceTree. For the purposes of the binding we do not need to
-- distinguish between GObject.Object and GObject.InitiallyUnowned.
getParent :: API -> Maybe Name
getParent (APIObject o) = rename $ objParent o
where
rename :: Maybe Name -> Maybe Name
rename (Just (Name "GObject" "InitiallyUnowned")) =
Just (Name "GObject" "Object")
rename x = x
getParent _ = Nothing
-- | Compute the (ordered) list of parents of the current object.
instanceTree :: Name -> CodeGen e [Name]
instanceTree n = do
api <- findAPIByName n
case getParent api of
Just p -> (p :) <$> instanceTree p
Nothing -> return []
-- A class for qualities of an object/interface that it inherits from
-- its ancestors. Properties and Signals are two classes of interest.
class Inheritable i where
ifInheritables :: Interface -> [i]
objInheritables :: Object -> [i]
iName :: i -> Text
instance Inheritable Property where
ifInheritables = ifProperties
objInheritables = objProperties
iName = propName
instance Inheritable Signal where
ifInheritables = ifSignals
objInheritables = objSignals
iName = sigName
instance Inheritable Method where
ifInheritables = ifMethods
objInheritables = objMethods
iName = name . methodName
-- Returns a list of all inheritables defined for this object
-- (including those defined by its ancestors and the interfaces it
-- implements), together with the name of the interface defining the
-- property.
apiInheritables :: Inheritable i => Name -> CodeGen e [(Name, i)]
apiInheritables n = do
api <- findAPIByName n
case dropMovedItems api of
Just (APIInterface iface) -> return $ map ((,) n) (ifInheritables iface)
Just (APIObject object) -> return $ map ((,) n) (objInheritables object)
_ -> error $ "apiInheritables : Unexpected API : " ++ show n
fullAPIInheritableList :: Inheritable i => Name -> CodeGen e [(Name, i)]
fullAPIInheritableList n = do
api <- findAPIByName n
case api of
APIInterface iface -> fullInterfaceInheritableList n iface
APIObject object -> fullObjectInheritableList n object
_ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n
fullObjectInheritableList :: Inheritable i => Name -> Object ->
CodeGen e [(Name, i)]
fullObjectInheritableList n obj = do
iT <- instanceTree n
(++) <$> (concat <$> mapM apiInheritables (n : iT))
<*> (concat <$> mapM apiInheritables (objInterfaces obj))
fullInterfaceInheritableList :: Inheritable i => Name -> Interface ->
CodeGen e [(Name, i)]
fullInterfaceInheritableList n iface =
(++) (map ((,) n) (ifInheritables iface))
<$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface))
-- | It is sometimes the case that a property name or signal is defined
-- both in an object and in one of its ancestors/implemented
-- interfaces. This is harmless if the properties are isomorphic
-- (there will be more than one qualified set of property
-- setters/getters that we can call, but they are all isomorphic). If
-- they are not isomorphic we print a warning, and choose to use the
-- one closest to the leaves of the object hierarchy.
removeDuplicates :: forall i e. (Eq i, Show i, Inheritable i) =>
Bool -> [(Name, i)] -> CodeGen e [(Name, i)]
removeDuplicates verbose inheritables =
(filterTainted . M.toList) <$> foldM filterDups M.empty inheritables
where
filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->
CodeGen e (M.Map Text (Bool, Name, i))
filterDups m (name, prop) =
case M.lookup (iName prop) m of
Just (tainted, n, p)
| tainted -> return m
| (p == prop) -> return m -- Duplicated, but isomorphic property
| otherwise ->
do when verbose $ do
line "--- XXX Duplicated object with different types:"
line $ " --- " <> tshow n <> " -> " <> tshow p
line $ " --- " <> tshow name <> " -> " <> tshow prop
-- Tainted
return $ M.insert (iName prop) (True, n, p) m
Nothing -> return $ M.insert (iName prop) (False, name, prop) m
filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)]
filterTainted xs =
[(name, prop) | (_, (_, name, prop)) <- xs]
-- | List all properties defined for an object, including those
-- defined by its ancestors.
fullObjectPropertyList :: Name -> Object -> CodeGen e [(Name, Property)]
fullObjectPropertyList n o = fullObjectInheritableList n o >>=
removeDuplicates True
-- | List all properties defined for an interface, including those
-- defined by its prerequisites.
fullInterfacePropertyList :: Name -> Interface -> CodeGen e [(Name, Property)]
fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=
removeDuplicates True
-- | List all signals defined for an object, including those
-- defined by its ancestors.
fullObjectSignalList :: Name -> Object -> CodeGen e [(Name, Signal)]
fullObjectSignalList n o = fullObjectInheritableList n o >>=
removeDuplicates True
-- | List all signals defined for an interface, including those
-- defined by its prerequisites.
fullInterfaceSignalList :: Name -> Interface -> CodeGen e [(Name, Signal)]
fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=
removeDuplicates True
-- | List all methods defined for an object, including those defined
-- by its ancestors.
fullObjectMethodList :: Name -> Object -> CodeGen e [(Name, Method)]
fullObjectMethodList n o = fullObjectInheritableList n o >>=
removeDuplicates False
-- | List all methods defined for an interface, including those
-- defined by its prerequisites.
fullInterfaceMethodList :: Name -> Interface -> CodeGen e [(Name, Method)]
fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>=
removeDuplicates False
|
