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
|
{-# LANGUAGE OverloadedStrings #-}
module DBus.Introspection.Parse
( parseXML
) where
import Conduit
import Data.Maybe
import Data.XML.Types
import qualified Data.Text as T
import qualified Text.XML.Stream.Parse as X
import DBus.Internal.Types
import DBus.Introspection.Types
data ObjectChildren
= InterfaceDefinition Interface
| SubNode Object
data InterfaceChildren
= MethodDefinition Method
| SignalDefinition Signal
| PropertyDefinition Property
parseXML :: ObjectPath -> T.Text -> Maybe Object
parseXML path xml =
runConduit $ yieldMany [xml] .| X.parseText X.def .| X.force "parse error" (parseObject $ getRootName path)
getRootName :: ObjectPath -> X.AttrParser ObjectPath
getRootName defaultPath = do
nodeName <- X.attr "name"
pure $ maybe defaultPath (objectPath_ . T.unpack) nodeName
getChildName :: ObjectPath -> X.AttrParser ObjectPath
getChildName parentPath = do
nodeName <- X.requireAttr "name"
let parentPath' = case formatObjectPath parentPath of
"/" -> "/"
x -> x ++ "/"
pure $ objectPath_ (parentPath' ++ T.unpack nodeName)
parseObject
:: X.AttrParser ObjectPath
-> ConduitT Event o Maybe (Maybe Object)
parseObject getPath = X.tag' "node" getPath parseContent
where
parseContent objPath = do
elems <- X.many $ X.choose
[ fmap SubNode <$> parseObject (getChildName objPath)
, fmap InterfaceDefinition <$> parseInterface
]
let base = Object objPath [] []
addElem e (Object p is cs) = case e of
InterfaceDefinition i -> Object p (i:is) cs
SubNode c -> Object p is (c:cs)
pure $ foldr addElem base elems
parseInterface
:: ConduitT Event o Maybe (Maybe Interface)
parseInterface = X.tag' "interface" getName parseContent
where
getName = do
ifName <- X.requireAttr "name"
pure $ interfaceName_ (T.unpack ifName)
parseContent ifName = do
elems <- X.many $ do
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
X.choose
[ parseMethod
, parseSignal
, parseProperty
]
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
let base = Interface ifName [] [] []
addElem e (Interface n ms ss ps) = case e of
MethodDefinition m -> Interface n (m:ms) ss ps
SignalDefinition s -> Interface n ms (s:ss) ps
PropertyDefinition p -> Interface n ms ss (p:ps)
pure $ foldr addElem base elems
parseMethod :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseMethod = X.tag' "method" getName parseArgs
where
getName = do
ifName <- X.requireAttr "name"
parseMemberName (T.unpack ifName)
parseArgs name = do
args <- X.many $ do
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
X.tag' "arg" getArg pure
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
pure $ MethodDefinition $ Method name args
getArg = do
name <- fromMaybe "" <$> X.attr "name"
typeStr <- X.requireAttr "type"
dirStr <- fromMaybe "in" <$> X.attr "direction"
X.ignoreAttrs
typ <- parseType typeStr
let dir = if dirStr == "in" then In else Out
pure $ MethodArg (T.unpack name) typ dir
parseSignal :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseSignal = X.tag' "signal" getName parseArgs
where
getName = do
ifName <- X.requireAttr "name"
parseMemberName (T.unpack ifName)
parseArgs name = do
args <- X.many $ do
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
X.tag' "arg" getArg pure
X.many_ $ X.ignoreTreeContent "annotation" X.ignoreAttrs
pure $ SignalDefinition $ Signal name args
getArg = do
name <- fromMaybe "" <$> X.attr "name"
typeStr <- X.requireAttr "type"
X.ignoreAttrs
typ <- parseType typeStr
pure $ SignalArg (T.unpack name) typ
parseProperty :: ConduitT Event o Maybe (Maybe InterfaceChildren)
parseProperty = X.tag' "property" getProp $ \p -> do
X.many_ X.ignoreAnyTreeContent
pure p
where
getProp = do
name <- T.unpack <$> X.requireAttr "name"
typeStr <- X.requireAttr "type"
accessStr <- fromMaybe "" <$> X.attr "access"
X.ignoreAttrs
typ <- parseType typeStr
(canRead, canWrite) <- case accessStr of
"" -> pure (False, False)
"read" -> pure (True, False)
"write" -> pure (False, True)
"readwrite" -> pure (True, True)
_ -> throwM $ userError "invalid access value"
pure $ PropertyDefinition $ Property name typ canRead canWrite
parseType :: MonadThrow m => T.Text -> m Type
parseType typeStr = do
typ <- parseSignature (T.unpack typeStr)
case signatureTypes typ of
[t] -> pure t
_ -> throwM $ userError "invalid type sig"
|
