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
|
module Wayland.CodeGen.Parser
( parseProtocolSpec
) where
import Data.Maybe (fromMaybe)
import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc)
import Text.Read (readEither)
import Wayland.CodeGen.Types
import Control.Applicative ((<|>))
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 <- mapM processDescription (filterChildName (matchName "description") el)
enums <- mapM processEnum (filterChildrenName (matchName "enum") el)
requests <- mapM processMessage (zip (filterChildrenName (matchName "request") el) [0..])
events <- mapM processMessage (zip (filterChildrenName (matchName "event" ) el) [0..])
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 <- mapM processDescription (filterChildName (matchName "description") el)
since <- mapM readEither (findAttrBy (matchName "since") el)
bitfield <- mapM readBool (findAttrBy (matchName "bitfield") el)
entries <- mapM processEntry (filterChildrenName (matchName "entry") el)
pure $ EnumDesc { enumName = name
, enumDescription = description
, enumSince = fromMaybe 1 since
, enumBitfield = fromMaybe False bitfield
, enumEntries = entries
}
processEntry :: Element -> Either String EntryDesc
processEntry el = do
name <- requireAttr "name" el
value <- requireAttr "value" el >>= readEither
description <- mapM processDescription (filterChildName (matchName "description") el)
since <- mapM readEither (findAttrBy (matchName "since") el)
deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el)
let summary = findAttrBy (matchName "summary") el
pure $ EntryDesc { entryName = name
, entryValue = value
, entryDescription = description <|> simpleDescription <$> summary
, entrySince = fromMaybe 1 since
, entryDeprecatedSince = deprecatedSince
}
processMessage :: (Element, Int) -> Either String MessageDesc
processMessage (el, opcode) = do
name <- requireAttr "name" el
description <- mapM processDescription (filterChildName (matchName "description") el)
type' <- mapM readMessageType (findAttrBy (matchName "type") el)
since <- mapM readEither (findAttrBy (matchName "since") el)
deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el)
arguments <- mapM processArgument (filterChildrenName (matchName "arg") el)
pure $ MessageDesc { msgName = name
, msgOpCode = opcode
, msgDescription = description
, msgType = fromMaybe MessageNormal type'
, msgSince = fromMaybe 1 since
, msgDeprecatedSince = deprecatedSince
, msgArguments = arguments
}
processArgument :: Element -> Either String ArgumentDesc
processArgument el = do
name <- requireAttr "name" el
type' <- requireAttr "type" el >>= readArgumentType
description <- mapM processDescription (filterChildName (matchName "description") el)
allowNull <- mapM 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 <|> simpleDescription <$> summary
, argInterface = interface
, argEnum = enum
, argAllowNull = fromMaybe False allowNull
}
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
simpleDescription :: String -> Description
simpleDescription summary = Description { descSummary = summary
, descBody = ""
}
|
