-
Notifications
You must be signed in to change notification settings - Fork 80
/
Copy pathJava.hs
369 lines (309 loc) · 12 KB
/
Java.hs
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
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}
module Language.MessagePack.IDL.CodeGen.Java (
Config(..),
generate,
) where
import Data.Char
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
import System.FilePath
import Text.Shakespeare.Text
import Language.MessagePack.IDL.Syntax
data Config
= Config
{ configFilePath :: FilePath
, configPackage :: String
}
deriving (Show, Eq)
generate :: Config -> Spec -> IO()
generate config spec = do
let typeAlias = map genAlias $ filter isMPType spec
mapM_ (genTuple config) $ filter isTuple $ concat $ map extractType spec
mapM_ (genClient typeAlias config) spec
mapM_ (genStruct typeAlias $ configPackage config) spec
mapM_ (genException $ configPackage config) spec
{--
LT.writeFile (name ++ "Server.java") $ templ (configFilePath ++ configPackage ++"/server/")[lt|
import org.msgpack.rpc.Server;
package #{configPackage}
#{LT.concat $ map genServer spec}
|]
--}
genTuple :: Config -> Type -> IO()
genTuple Config{..} (TTuple typeList ) = do
let first = genType $ typeList!!0
second = genType $ typeList!!1
className = LT.unpack $ (LT.pack "Tuple") `mappend` formatClassNameLT first `mappend` formatClassNameLT second
dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack configPackage
fileName = dirName ++ "/" ++ className ++ ".java"
LT.writeFile fileName $ templ configFilePath [lt|
package #{configPackage};
import org.msgpack.MessagePack;
import org.msgpack.annotation.Message;
@Message
public class #{className} {
public #{first} first;
public #{second} second;
};
|]
genTuple _ _ = return ()
isTuple :: Type -> Bool
isTuple (TTuple _) = True
isTuple _ = False
extractType :: Decl -> [Type]
extractType MPMessage {..} = map fldType msgFields
extractType MPException {..} = map fldType excFields
extractType MPType {..} = [tyType]
extractType MPEnum {..} = []
extractType MPService {..} = concat $ map extractTypeFromMethod serviceMethods
extractTypeFromMethod :: Method -> [Type]
extractTypeFromMethod Function {..} = [methodRetType] ++ map fldType methodArgs
extractTypeFromType :: Type -> [Type]
extractTypeFromType x@(TNullable t) = [x] ++ extractTypeFromType t
extractTypeFromType x@(TList t) = [x] ++ extractTypeFromType t
extractTypeFromType x@(TMap s t) = [x] ++ extractTypeFromType s ++ extractTypeFromType t
extractTypeFromType x@(TTuple ts) = [x] ++ Prelude.concatMap extractTypeFromType ts
extractTypeFromType x@(TUserDef _ ts) = [x] ++ Prelude.concatMap extractTypeFromType ts
extractTypeFromType x = [x]
genImport :: FilePath -> Decl -> LT.Text
genImport packageName MPMessage {..} =
[lt|import #{packageName}.#{formatClassNameT msgName};
|]
genImport _ _ = ""
genStruct :: [(T.Text, Type)] -> FilePath -> Decl -> IO()
genStruct alias packageName MPMessage {..} = do
let params = if null msgParam then "" else [lt|<#{T.intercalate ", " msgParam}>|]
resolvedMsgFields = map (resolveFieldAlias alias) msgFields
hashMapImport | not $ null [() | TMap _ _ <- map fldType resolvedMsgFields] = [lt|import java.util.HashMap;|]
| otherwise = ""
arrayListImport | not $ null [() | TList _ <- map fldType resolvedMsgFields] = [lt|import java.util.ArrayList;|]
| otherwise = ""
LT.writeFile ( (formatClassName $ T.unpack msgName) ++ ".java") [lt|
package #{packageName};
#{hashMapImport}
#{arrayListImport}
public class #{formatClassNameT msgName} #{params} {
#{LT.concat $ map genDecl resolvedMsgFields}
public #{formatClassNameT msgName}() {
#{LT.concat $ map genInit resolvedMsgFields}
}
};
|]
genStruct _ _ _ = return ()
resolveMethodAlias :: [(T.Text, Type)] -> Method -> Method
resolveMethodAlias alias Function {..} = Function methodInherit methodName (resolveTypeAlias alias methodRetType) (map (resolveFieldAlias alias) methodArgs)
resolveMethodAlias _ f = f
resolveFieldAlias :: [(T.Text, Type)] -> Field -> Field
resolveFieldAlias alias Field {..} = Field fldId (resolveTypeAlias alias fldType) fldName fldDefault
resolveTypeAlias :: [(T.Text, Type)] -> Type -> Type
resolveTypeAlias alias ty = let fixedAlias = resolveTypeAlias alias in
case ty of
TNullable t ->
TNullable $ fixedAlias t
TList t ->
TList $ fixedAlias t
TMap s t ->
TMap (fixedAlias s) (fixedAlias t)
TTuple ts ->
TTuple $ map fixedAlias ts
TUserDef className params ->
case lookup className alias of
Just resolvedType -> resolvedType
Nothing -> TUserDef className (map fixedAlias params)
otherwise -> ty
genInit :: Field -> LT.Text
genInit Field {..} = case fldDefault of
Nothing -> ""
Just defaultVal -> [lt| #{fldName} = #{genLiteral defaultVal};|]
genDecl :: Field -> LT.Text
genDecl Field {..} =
[lt| public #{genType fldType} #{fldName};
|]
genException :: FilePath -> Decl -> IO()
genException packageName MPException {..} = do
LT.writeFile ( (formatClassName $ T.unpack excName) ++ ".java") [lt|
package #{packageName};
public class #{formatClassNameT excName} #{params}{
#{LT.concat $ map genDecl excFields}
public #{formatClassNameT excName}() {
#{LT.concat $ map genInit excFields}
}
};
|]
where
params = if null excParam then "" else [lt|<#{T.intercalate ", " excParam}>|]
super = case excSuper of
Just x -> [st|extends #{x}|]
Nothing -> ""
genException _ _ = return ()
genClient :: [(T.Text, Type)] -> Config -> Decl -> IO()
genClient alias Config {..} MPService {..} = do
let resolvedServiceMethods = map (resolveMethodAlias alias) serviceMethods
hashMapImport | not $ null [() | TMap _ _ <- map methodRetType resolvedServiceMethods ] = [lt|import java.util.HashMap;|]
| otherwise = ""
arrayListImport | not $ null [() | TList _ <- map methodRetType resolvedServiceMethods] = [lt|import java.util.ArrayList;|]
| otherwise = ""
LT.writeFile (T.unpack className ++ ".java") $ templ configFilePath [lt|
package #{configPackage};
#{hashMapImport}
#{arrayListImport}
import org.msgpack.rpc.Client;
import org.msgpack.rpc.loop.EventLoop;
public class #{className} {
public #{className}(String host, int port, double timeout_sec) throws Exception {
EventLoop loop = EventLoop.defaultEventLoop();
c_ = new Client(host, port, loop);
iface_ = c_.proxy(RPCInterface.class);
}
public static interface RPCInterface {
#{LT.concat $ map genSignature resolvedServiceMethods}
}
#{LT.concat $ map genMethodCall resolvedServiceMethods}
private Client c_;
private RPCInterface iface_;
};
|]
where
className = (formatClassNameT serviceName) `mappend` "Client"
genMethodCall Function {..} =
let args = T.intercalate ", " $ map genArgs' methodArgs
vals = T.intercalate ", " $ pack methodArgs genVal in
case methodRetType of
TVoid -> [lt|
public void #{methodName}(#{args}) {
iface_.#{methodName}(#{vals});
}
|]
_ -> [lt|
public #{genType methodRetType} #{methodName}(#{args}) {
return iface_.#{methodName}(#{vals});
}
|]
genMethodCall _ = ""
genClient _ _ _ = return ()
genSignature :: Method -> LT.Text
genSignature Function {..} =
[lt| #{genType methodRetType} #{methodName}(#{args});
|]
where
args = (T.intercalate ", " $ map genArgs' methodArgs)
genSignature _ = ""
genArgs :: Maybe Field -> T.Text
genArgs (Just field) = genArgs' field
genArgs Nothing = ""
genArgs' :: Field -> T.Text
genArgs' Field {..} = [st|#{genType fldType} #{fldName}|]
pack :: [Field] -> (Maybe Field -> T.Text) -> [T.Text]
pack fields converter=
let ixs = map (\f -> fldId f) fields
dic = zip ixs [0..]
m = maximum (-1 :ixs)
sortedIxs = [ lookup ix dic | ix <- [0..m]] :: [Maybe Int] in
map (\sIx -> case sIx of
Nothing -> converter Nothing
Just i -> converter $ Just (fields!!i) ) sortedIxs
genVal :: Maybe Field -> T.Text
genVal Nothing = "null"
genVal (Just field) = fldName field
formatClassNameLT :: LT.Text -> LT.Text
formatClassNameLT = LT.pack . formatClassName . LT.unpack
formatClassNameT :: T.Text -> T.Text
formatClassNameT = T.pack . formatClassName . T.unpack
formatClassName :: String -> String
formatClassName = concatMap (\(c:cs) -> toUpper c:cs) . words . map (\c -> if c=='_' then ' ' else c)
genServer :: Decl -> LT.Text
genServer _ = ""
genLiteral :: Literal -> LT.Text
genLiteral (LInt i) = [lt|#{show i}|]
genLiteral (LFloat d) = [lt|#{show d}|]
genLiteral (LBool b) = [lt|#{show b}|]
genLiteral LNull = [lt|null|]
genLiteral (LString s) = [lt|#{show s}|]
associateBracket :: [LT.Text] -> LT.Text
associateBracket msgParam =
if null msgParam then "" else [lt|<#{LT.intercalate ", " msgParam}>|]
genType :: Type -> LT.Text
genType (TInt _ bits) = case bits of
8 -> [lt|byte|]
16 -> [lt|short|]
32 -> [lt|int|]
64 -> [lt|long|]
_ -> [lt|int|]
genType (TFloat False) =
[lt|float|]
genType (TFloat True) =
[lt|double|]
genType TBool =
[lt|boolean|]
genType TRaw =
[lt|String|]
genType TString =
[lt|String|]
genType (TList typ) =
[lt|ArrayList<#{genWrapperType typ} >|]
genType (TMap typ1 typ2) =
[lt|HashMap<#{genType typ1}, #{genType typ2} >|]
genType (TUserDef className params) =
[lt|#{formatClassNameT className} #{associateBracket $ map genType params}|]
genType (TTuple ts) =
-- TODO: FIX
foldr1 (\t1 t2 -> [lt|Tuple#{formatClassNameLT t1}#{formatClassNameLT t2}|]) $ map genWrapperType ts
genType TObject =
[lt|org.msgpack.type.Value|]
genType TVoid =
[lt|void|]
genTypeWithContext :: Spec -> Type -> LT.Text
genTypeWithContext spec t = case t of
(TUserDef className params) ->
case lookup className $ map genAlias $ filter isMPType spec of
Just x -> genType x
Nothing -> ""
otherwise -> genType t
isMPType :: Decl -> Bool
isMPType MPType {..} = True
isMPType _ = False
genAlias :: Decl -> (T.Text, Type)
genAlias MPType {..} = (tyName, tyType)
genAlias _ = ("", TBool)
genTypeWithTypedef :: T.Text -> Decl -> Maybe Type
genTypeWithTypedef className MPType {..} =
if className == tyName then Just tyType else Nothing
genTypeWithTypedef className _ = Nothing
genWrapperType :: Type -> LT.Text
genWrapperType (TInt _ bits) = case bits of
8 -> [lt|Byte|]
16 -> [lt|Short|]
32 -> [lt|Integer|]
64 -> [lt|Long|]
_ -> [lt|Integer|]
genWrapperType (TFloat False) =
[lt|Float|]
genWrapperType (TFloat True) =
[lt|Double|]
genWrapperType TBool =
[lt|Boolean|]
genWrapperType TRaw =
[lt|String|]
genWrapperType TString =
[lt|String|]
genWrapperType (TList typ) =
[lt|ArrayList<#{genWrapperType typ} >|]
genWrapperType (TMap typ1 typ2) =
[lt|HashMap<#{genWrapperType typ1}, #{genWrapperType typ2} >|]
genWrapperType (TUserDef className params) =
[lt|#{formatClassNameT className} #{associateBracket $ map genWrapperType params}|]
genWrapperType (TTuple ts) =
-- TODO: FIX
foldr1 (\t1 t2 -> [lt|Tuple#{formatClassNameLT t1}#{formatClassNameLT t2}|]) $ map genWrapperType ts
genWrapperType TObject =
[lt|org.msgpack.type.Value|]
genWrapperType TVoid =
[lt|void|]
templ :: FilePath -> LT.Text -> LT.Text
templ filepath content = [lt|
// This file is auto-generated from #{filepath}
// *** DO NOT EDIT ***
#{content}
|]