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
|
module Wayland.CodeGen.Parser
( parseProtocolSpec
) where
import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc)
import Text.Read (readEither)
import Wayland.CodeGen.Types
parseProtocolSpec :: String -> Either String Protocol
parseProtocolSpec s = case parseXMLDoc s of
Just el | matchName "protocol" (elName el) -> processProtocol el
_ -> Left "Invalid XML"
processProtocol :: Element -> Either String Protocol
processProtocol el = do
name <- requireAttr "name" el
description <- traverse processDescription (filterChildName (matchName "description") el)
interfaces <- mapM processInterface (filterChildrenName (matchName "interface") el)
let copyright = strContent <$> filterChildName (matchName "copyright") el
pure $ Protocol { protName = name
, protCopyright = copyright
, protDescription = description
, protInterfaces = interfaces
}
processDescription :: Element -> Either String Description
processDescription el = do
summary <- requireAttr "summary" el
pure $ Description { descSummary = summary
, descBody = strContent el
}
processInterface :: Element -> Either String InterfaceDesc
processInterface el = do
name <- requireAttr "name" el
version <- requireAttr "version" el >>= readEither
description <- traverse processDescription (filterChildName (matchName "description") el)
enums <- mapM processEnum (filterChildrenName (matchName "enum") el)
requests <- mapM processMessage (filterChildrenName (matchName "request") el)
events <- mapM processMessage (filterChildrenName (matchName "event") el)
pure $ InterfaceDesc { ifName = name
, ifVersion = version
, ifDescription = description
, ifEnums = enums
, ifRequests = requests
, ifEvents = events
}
processEnum :: Element -> Either String EnumDesc
processEnum el = do
name <- requireAttr "name" el
description <- traverse processDescription (filterChildName (matchName "description") el)
since <- traverse readEither (findAttrBy (matchName "since") el)
bitfield <- traverse readBool (findAttrBy (matchName "bitfield") el)
entries <- mapM processEntry (filterChildrenName (matchName "entry") el)
pure $ EnumDesc { enumName = name
, enumDescription = description
, enumSince = since
, enumBitfield = bitfield
, enumEntries = entries
}
processEntry :: Element -> Either String EntryDesc
processEntry el = do
name <- requireAttr "name" el
value <- requireAttr "value" el >>= readEither
description <- traverse processDescription (filterChildName (matchName "description") el)
since <- traverse readEither (findAttrBy (matchName "since") el)
deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el)
let summary = findAttrBy (matchName "summary") el
pure $ EntryDesc { entryName = name
, entryValue = value
, entryDescription = description
, entrySummary = summary
, entrySince = since
, entryDeprecatedSince = deprecatedSince
}
processMessage :: Element -> Either String MessageDesc
processMessage el = do
name <- requireAttr "name" el
description <- traverse processDescription (filterChildName (matchName "description") el)
type' <- traverse readMessageType (findAttrBy (matchName "type") el)
since <- traverse readEither (findAttrBy (matchName "since") el)
deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el)
arguments <- mapM processArgument (filterChildrenName (matchName "arg") el)
pure $ MessageDesc { msgName = name
, msgDescription = description
, msgType = type'
, msgSince = since
, msgDeprecatedSince = deprecatedSince
, msgArguments = arguments
}
processArgument :: Element -> Either String ArgumentDesc
processArgument el = do
name <- requireAttr "name" el
type' <- requireAttr "type" el >>= readArgumentType
description <- traverse processDescription (filterChildName (matchName "description") el)
allowNull <- traverse readBool (findAttrBy (matchName "allow-null") el)
let summary = findAttrBy (matchName "summary") el
let interface = findAttrBy (matchName "interface") el
let enum = findAttrBy (matchName "enum") el
pure $ ArgumentDesc { argName = name
, argType = type'
, argDescription = description
, argSummary = summary
, argInterface = interface
, argAllowNull = allowNull
, argEnum = enum
}
requireAttr :: String -> Element -> Either String String
requireAttr name el = expect ("Expected attribute " ++ name) $ findAttrBy (matchName name) el
matchName :: String -> QName -> Bool
matchName name q = qName q == name
expect :: String -> Maybe a -> Either String a
expect _ (Just x) = Right x
expect e Nothing = Left e
readBool :: String -> Either String Bool
readBool "true" = Right True
readBool "false" = Right False
readBool x = Left $ "Expected a boolean value, got " ++ x
readMessageType :: String -> Either String MessageType
readMessageType "destructor" = Right MessageDestructor
readMessageType "normal" = Right MessageNormal
readMessageType x = Left $ "Expected a message type, got " ++ x
readArgumentType :: String -> Either String ArgumentType
readArgumentType "int" = Right ArgumentInt
readArgumentType "uint" = Right ArgumentUInt
readArgumentType "fixed" = Right ArgumentFixed
readArgumentType "string" = Right ArgumentString
readArgumentType "array" = Right ArgumentArray
readArgumentType "fd" = Right ArgumentFD
readArgumentType "new_id" = Right ArgumentNewID
readArgumentType "object" = Right ArgumentObject
readArgumentType x = Left $ "Expected an argument type, got " ++ x
|
