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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
{-# LANGUAGE TemplateHaskell #-}
module Wayland.CodeGen.CodeGen
( generateInterface
, generateInterfaceBoot
) where
-- TODO: Documentation
import Wayland.CodeGen.Types
import Wayland.CodeGen.Utils
import Control.Monad.State.Strict (State, runState)
import Lens.Micro.TH (makeLenses)
import Data.List (intercalate, sort, isPrefixOf)
import Lens.Micro.Mtl ((%=))
import Data.Functor (($>))
import Control.Monad.Reader (ReaderT (..), asks)
import Data.Map ((!))
import qualified Data.Map as M
newtype Declaration = Declaration { declLines :: [String] }
data Import = Import { imModule :: !String
, imSource :: !Bool
}
deriving (Show, Eq)
data GeneratorState
= GeneratorState { _stateImports :: ![Import]
, _stateExports :: ![String]
, _stateExtensions :: ![String]
, _stateDecls :: ![Declaration]
}
data GeneratorConfig
= GeneratorConfig { genModules :: !FlatModules
, genProtocol :: !TypedProtocol
, genInterface :: !InterfaceDesc
, genTypes :: !TypeInfo
}
type Generator = ReaderT GeneratorConfig (State GeneratorState)
makeLenses ''GeneratorState
generateInterface :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
generateInterface flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emit
generateInterfaceBoot :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
generateInterfaceBoot flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emitBoot
generate :: GeneratorConfig -> Generator () -> String
generate cfg g = transform $ runState (runReaderT g cfg) initialState
where initialState = GeneratorState { _stateImports = []
, _stateExports = []
, _stateExtensions = []
, _stateDecls = []
}
transform (_, state) = undecls $ [ extensionDecl state, moduleDecl state, importDecl state ] ++ _stateDecls state
extensionDecl s = Declaration $ sort $ fmap formatExtension (_stateExtensions s)
moduleDecl s = Declaration [ "module " ++ genFullModule cfg ++ " (" ++ intercalate ", " (_stateExports s) ++ ") where" ]
importDecl s = Declaration $ sort $ fmap formatImport (_stateImports s)
undecls decls = intercalate "\n" $ unlines . declLines <$> filter (not . null . declLines) decls
formatExtension e = "{-# LANGUAGE " ++ e ++ " #-}"
formatImport i = "import " ++ (if imSource i then "{-# SOURCE #-} " else "") ++ "qualified " ++ imModule i
genFullModule :: GeneratorConfig -> String
genFullModule cfg = fullModule (genProtocol cfg) (genInterface cfg)
emitDecl :: [String] -> Generator ()
emitDecl c = stateDecls %= (++ [ Declaration c ])
emitImport :: Import -> Generator ()
emitImport i = stateImports %= \is -> if i `elem` is then is else i:is
emitExport :: String -> Generator ()
emitExport e = stateExports %= (e:)
emitExtension :: String -> Generator ()
emitExtension e = stateExtensions %= (e:)
resolve :: String -> String -> Generator String
resolve m e = do
this <- asks genFullModule
if this == m
then pure e
else emitImport (Import m ("Wayland.Protocols." `isPrefixOf` m)) $> m ++ "." ++ e
resolveInterface :: Maybe String -> String -> Generator String
resolveInterface (Just name) e = do modules <- asks genModules
let (p, i) = modules ! name
resolve (fullModule p (fst i)) e
resolveInterface Nothing e = pure e
resolveEnum :: String -> Generator String
resolveEnum e = resolveQualified $ break (== '.') e
where resolveQualified :: (String, String) -> Generator String
resolveQualified (e', []) = do types <- asks genTypes
pure $ typeEnums types ! e'
resolveQualified (i, _:e') = do modules <- asks genModules
resolveInterface (Just i) $ typeEnums (snd (snd (modules ! i))) ! e'
resolveArgument :: ArgumentDesc -> Generator String
resolveArgument a = case argType a of
ArgumentInt -> maybe (pure "Int") resolveEnum (argEnum a)
ArgumentUInt -> maybe (pure "Word") resolveEnum (argEnum a)
ArgumentFixed -> pure "Float"
ArgumentArray -> resolve "Data.ByteString" "ByteString"
ArgumentFD -> resolve "System.Posix.Types" "Fd"
ArgumentString -> pure $ if argAllowNull a then "(Maybe String)" else "String"
ArgumentNewID -> resolveInterface (argInterface a) "Object"
ArgumentObject -> do obj <- resolveInterface (argInterface a) "Object"
pure $ if argAllowNull a then "(Maybe " ++ obj ++ ")" else obj
emitBoot :: Generator ()
emitBoot = do
anyObject <- resolve "Wayland.Server" "AnyObject"
interfaceDesc <- resolve "Wayland.Server" "InterfaceDesc"
objectClass <- resolve "Wayland.Server" "Object"
enumTypes <- asks $ typeEnums . genTypes
i <- asks genInterface
emitDecl [ "newtype Object = Object " ++ anyObject ]
emitExport "Object"
emitDecl [ "interface :: " ++ interfaceDesc ]
emitExport "interface"
emitDecl [ "instance " ++ objectClass ++ " Object"
, "instance Show Object"
, "instance Eq Object" ]
let emitEnumBoot e = do let name = enumTypes ! enumName e
emitDecl [ "data " ++ name
, "instance Show " ++ name
, "instance Eq " ++ name ]
emitExport name
mapM_ emitEnumBoot (ifEnums i)
emit :: Generator ()
emit = do
anyObject <- resolve "Wayland.Server" "AnyObject"
hashable <- resolve "Data.Hashable" "Hashable"
objectClass <- resolve "Wayland.Server" "Object"
i <- asks genInterface
emitExtension "GeneralizedNewtypeDeriving"
emitExtension "EmptyDataDeriving"
emitDecl [ "newtype Object = Object " ++ anyObject
, " deriving (Show, Eq, Ord, " ++ hashable ++ ")" ]
emitExport "Object"
mapM_ (emitMessageDesc requestDescName) (ifRequests i)
mapM_ (emitMessageDesc eventDescName) (ifEvents i)
emitInterfaceDesc
emitRequests (ifRequests i)
emitEvents (ifEvents i)
mapM_ emitEnum (ifEnums i)
asks (typeRequestArgs . genTypes) >>= mapM_ emitArguments
asks (typeEventArgs . genTypes) >>= mapM_ emitArguments
emitExtension "TypeFamilies"
emitDecl [ "instance " ++ objectClass ++ " Object where"
, " type ObjectEvent Object = Event"
, " type ObjectRequest Object = Request"
, " toAny (Object o) = o"
, " fromAny = Object"
, " describeInterface _ = interface"
, " demarshalRequest _ _ = undefined"
, " marshalEvent _ _ = undefined"
, " requestSignature _ _ = undefined"
, " eventSignature _ _ = undefined" ]
-- TODO: Proper marshalling/demarshalling
requestDescName :: MessageDesc -> String
requestDescName m = "req" ++ pascalCase (msgName m)
eventDescName :: MessageDesc -> String
eventDescName m = "ev" ++ pascalCase (msgName m)
emitMessageDesc :: (MessageDesc -> String) -> MessageDesc -> Generator ()
emitMessageDesc name m = do
let argumentNullability True = resolve "Wayland.Server" "Nullable"
argumentNullability False = resolve "Wayland.Server" "NotNull"
let argumentType :: ArgumentDesc -> Generator String
argumentType a = case argType a of
ArgumentInt -> resolve "Wayland.Server" "ArgumentInt"
ArgumentUInt -> resolve "Wayland.Server" "ArgumentUInt"
ArgumentFixed -> resolve "Wayland.Server" "ArgumentFixed"
ArgumentArray -> resolve "Wayland.Server" "ArgumentArray"
ArgumentFD -> resolve "Wayland.Server" "ArgumentFD"
ArgumentString -> do aType <- resolve "Wayland.Server" "ArgumentString"
aNullability <- argumentNullability (argAllowNull a)
pure $ aType ++ " " ++ aNullability
ArgumentObject -> do aType <- resolve "Wayland.Server" "ArgumentObject"
aIface <- resolveInterface (argInterface a) "interface"
aNullability <- argumentNullability (argAllowNull a)
pure $ aType ++ " " ++ aNullability ++ " " ++ aIface
ArgumentNewID -> do aType <- resolve "Wayland.Server" "ArgumentNewID"
aIface <- resolveInterface (argInterface a) "interface"
pure $ aType ++ " " ++ aIface
messageDesc <- resolve "Wayland.Server" "MessageDesc"
msgName' <- resolve "Wayland.Server" "msgName"
msgArguments' <- resolve "Wayland.Server" "msgArguments"
msgSince' <- resolve "Wayland.Server" "msgSince"
msgIsDestructor' <- resolve "Wayland.Server" "msgIsDestructor"
arguments <- mapM argumentType (msgArguments m)
emitDecl [ name m ++ " :: " ++ messageDesc
, name m ++ " ="
, " " ++ messageDesc
, " { " ++ msgName' ++ " = " ++ escapeStr (msgName m)
, " , " ++ msgArguments' ++ " = [" ++ intercalate ", " arguments ++ "]"
, " , " ++ msgSince' ++ " = " ++ show (msgSince m)
, " , " ++ msgIsDestructor' ++ " = " ++ show (msgType m == MessageDestructor)
, " }"
]
emitInterfaceDesc :: Generator ()
emitInterfaceDesc = do
interfaceDesc <- resolve "Wayland.Server" "InterfaceDesc"
ifName' <- resolve "Wayland.Server" "ifName"
ifVersion' <- resolve "Wayland.Server" "ifVersion"
ifRequests' <- resolve "Wayland.Server" "ifRequests"
ifEvents' <- resolve "Wayland.Server" "ifEvents"
i <- asks genInterface
emitDecl [ "interface :: " ++ interfaceDesc
, "interface ="
, " " ++ interfaceDesc
, " { " ++ ifName' ++ " = " ++ escapeStr (ifName i)
, " , " ++ ifVersion' ++ " = " ++ show (ifVersion i)
, " , " ++ ifRequests' ++ " = [" ++ intercalate ", " (requestDescName <$> ifRequests i) ++ "]"
, " , " ++ ifEvents' ++ " = [" ++ intercalate ", " (eventDescName <$> ifEvents i) ++ "]"
, " }" ]
emitExport "interface"
emitRequests :: [MessageDesc] -> Generator ()
emitRequests ms = emitMessages ms typeRequestArgs formatConstructor "Request"
where formatConstructor m = "Req" ++ pascalCase (msgName m) ++ " Object"
emitEvents :: [MessageDesc] -> Generator ()
emitEvents ms = emitMessages ms typeEventArgs formatConstructor "Event"
where formatConstructor m = "Ev" ++ pascalCase (msgName m)
emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentMode) -> (MessageDesc -> String) -> String -> Generator ()
emitMessages ms argTypes formatConstructor type' = do
typeable <- resolve "Data.Typeable" "Typeable"
messageClass <- resolve "Wayland.Server" "MessageClass"
typeClass <- resolve "Wayland.Server" (type' ++ "Class")
args <- asks $ argTypes . genTypes
let constructorArg :: ArgumentMode -> Generator String
constructorArg ArgumentModeNone = pure ""
constructorArg (ArgumentModeSingle a) = (++) " " <$> resolveArgument a
constructorArg (ArgumentModeRecord _ r) = pure $ " " ++ r
let constructor m = (++) (formatConstructor m) <$> constructorArg (args ! msgName m)
constructors <- mapM constructor ms
emitDecl $ [ "data " ++ type' ]
++ dataConstructors constructors
++ [ " deriving (" ++ typeable ++ ", Show, Eq)" ]
emitExport $ type' ++ "(..)"
emitDecl [ "instance " ++ messageClass ++ " " ++ type'
, "instance " ++ typeClass ++ " " ++ type' ]
emitEnum :: EnumDesc -> Generator ()
emitEnum e = do
-- TODO: Handle bitsets
types <- asks $ typeEnums . genTypes
let name = types ! enumName e
let constructorName entry = name ++ pascalCase (entryName entry)
let constructors = dataConstructors $ fmap constructorName (enumEntries e)
emitDecl ([ "data " ++ name ]
++ constructors ++
[ " deriving (Show, Eq)" ])
emitExport $ name ++ "(..)"
emitArguments :: ArgumentMode -> Generator ()
emitArguments ArgumentModeNone = pure ()
emitArguments (ArgumentModeSingle _) = pure ()
emitArguments (ArgumentModeRecord args name) = do
let field a = recordField name (camelCase (argName (fst a))) ++ " :: " ++ snd a
let formatArgs [] = [ " {" ]
formatArgs (a:as) = (" { " ++ field a) : fmap formatArg' as
formatArg' a = " , " ++ field a
resolvedArgs <- mapM resolveArgument args
emitDecl ([ "data " ++ name
, " = " ++ name ]
++ formatArgs (zip args resolvedArgs) ++
[ " }"
, " deriving (Show, Eq)" ])
emitExport $ name ++ "(..)"
dataConstructors :: [String] -> [String]
dataConstructors (c:cs) = (" = " ++ c) : fmap (" | " ++) cs
dataConstructors [] = []
escapeStr :: String -> String
escapeStr str = "\"" ++ escapeInner str ++ "\""
where escapeInner ('\"':xs) = "\\\"" ++ escapeInner xs
escapeInner ('\\':xs) = "\\\\" ++ escapeInner xs
escapeInner ('\n':xs) = "\\n" ++ escapeInner xs
escapeInner (x :xs) = x : escapeInner xs
escapeInner [] = []
|
