Source file ppx_rpc.ml
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
module Parsetree = Ppxlib.Parsetree
module Asttypes = Ppxlib.Asttypes
module Longident = Ppxlib.Longident
module Location = Ppxlib.Location
open Ppxlib.Ast
open Ppxlib.Ast_helper
let mkloc txt loc = {txt; loc}
let mkloc_opt ?(loc = !default_loc) x = mkloc x loc
let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Const.string s)
let pvar ?loc name = Pat.var ?loc (mkloc_opt ?loc name)
let ident x = Exp.ident (mkloc_opt (Longident.Lident x))
let unit ?loc ?attrs () =
Exp.construct ?loc ?attrs (mkloc_opt ?loc (Longident.Lident "()")) None
let tunit ?loc () = Typ.constr (mkloc_opt ?loc (Longident.Lident "unit")) []
type error =
| No_parameter
| Missing_parameter_type
| Missing_parameter_name
| Reserved_parameter of string
| Duplicated_parameter of string
| No_return_type
let print_error ~loc (e : error) =
let error_str =
match e with
| No_parameter -> "The function must have at least one parameter"
| Missing_parameter_type -> "Missing parameter type anotation"
| Missing_parameter_name -> "The parameter should be a variable"
| Reserved_parameter nm ->
Printf.sprintf "Parameter '%s' has a reserved name" nm
| Duplicated_parameter nm ->
Printf.sprintf "Two parameters have name '%s'" nm
| No_return_type -> "An Lwt.t return type is mandatory"
in
Location.raise_errorf ~loc "%s" error_str
let rpc_name fun_name =
let filename =
Filename.(!Ocaml_common.Location.input_name |> chop_extension |> basename)
in
Format.sprintf "%s.%s" filename fun_name
let expr_tuple l =
match l with
| [] -> unit ()
| [(_, x, _)] -> ident x
| _ -> Exp.tuple (List.map (fun (_, x, _) -> ident x) l)
let pat_tuple l =
match l with
| [] -> Pat.any ()
| [(_, x, _)] -> pvar x
| _ -> Pat.tuple (List.map (fun (_, x, _) -> pvar x) l)
let typ_tuple l =
match l with
| [] -> tunit ()
| [(_, _, ty)] -> ty
| _ -> Typ.tuple (List.map (fun (_, _, ty) -> ty) l)
let expr_type e =
match e with [%expr ([%e? _] : [%t? ty] Lwt.t)] -> Some ty | _ -> None
let rec collect_params l expr =
match expr with
| { pexp_desc =
Pexp_fun
( ((Labelled name | Optional name) as label)
, def
, {ppat_desc = Ppat_constraint (_, ty)}
, expr' ) }
| { pexp_desc =
Pexp_fun
( (Nolabel as label)
, def
, { ppat_desc =
Ppat_constraint ({ppat_desc = Ppat_var {txt = name}}, ty) }
, expr' ) }
| { pexp_desc =
Pexp_fun
( ((Labelled name | Optional name) as label)
, (Some {pexp_desc = Pexp_constraint (_, ty)} as def)
, _
, expr' ) }
| { pexp_desc =
Pexp_fun
( (Nolabel as label)
, (Some {pexp_desc = Pexp_constraint (_, ty)} as def)
, {ppat_desc = Ppat_var {txt = name}}
, expr' ) } ->
let ty =
match label, def with
| Optional _, Some _ ->
let loc = ty.ptyp_loc in
[%type: [%t ty] option]
| _ -> ty
in
collect_params ((label, name, ty) :: l) expr'
| [%expr fun () -> [%e? expr']] -> (List.rev l, true), expr_type expr'
| {pexp_desc = Pexp_fun (_, _, ({ppat_desc = Ppat_constraint (_, _)} as p), _)}
->
print_error ~loc:p.ppat_loc Missing_parameter_name
| {pexp_desc = Pexp_fun (_, _, p, _)} ->
print_error ~loc:p.ppat_loc Missing_parameter_type
| _ -> (List.rev l, false), expr_type expr
let parametrize loc (params, has_unit) expr =
List.fold_right
(fun (label, x, _) expr -> Exp.fun_ label None (pvar x) expr)
params
(if has_unit then [%expr fun () -> [%e expr]] else expr)
let build_params loc (params, has_unit) =
List.map (fun (label, x, _) -> label, ident x) params
@ if has_unit then [Nolabel, [%expr ()]] else []
let apply args expr = Exp.apply expr args
let server_function ~loc ~kind ~fun_var expr' =
let expr =
match kind with
| `Connected -> [%expr fun (myid : Os_types.User.id) -> [%e expr']]
| `Any -> [%expr fun (myid_o : Os_types.User.id option) -> [%e expr']]
| `None -> expr'
in
[%stri let%server [%p fun_var] = [%e expr]]
let server_cacher ~loc ~kind ~cache ~fun_name ~fun_var ~params =
match cache with
| None -> [%stri let%server _ = ()]
| Some return_typ ->
let id_param =
match kind with
| `Connected -> [Nolabel, [%expr myid]]
| `Any -> [Nolabel, [%expr myid_o]]
| `None -> []
in
let cache expr =
[%expr
let%lwt x = [%e expr] in
Bs_proxy.cache [%derive.caching: [%t return_typ]] x]
in
let parametrize_id expr =
match kind with
| `Connected -> [%expr fun myid -> [%e expr]]
| `Any -> [%expr fun myid_o -> [%e expr]]
| `None -> expr
in
let expr =
fun_name |> ident
|> apply (id_param @ build_params loc params)
|> cache |> parametrize loc params |> parametrize_id
in
[%stri let%server [%p fun_var] = [%e expr] [@@ocaml.warning "-16"]]
let server_wrapper ~loc ~kind ~raw ~cache ~fun_name ~fun_var ~params =
if raw
then [%stri let%server _ = ()]
else
let id_param =
match kind with
| `Connected -> [Nolabel, [%expr Os_current_user.get_current_userid ()]]
| `Any -> [Nolabel, [%expr Os_current_user.Opt.get_current_userid ()]]
| `None -> []
in
let uncache expr =
if cache <> None then [%expr Bs_proxy.extract [%e expr]] else expr
in
let expr =
fun_name |> ident
|> apply (id_param @ build_params loc params)
|> uncache |> parametrize loc params
in
[%stri let%server [%p fun_var] = [%e expr] [@@ocaml.warning "-16-32"]]
let client_wrapper ~loc ~kind ~raw ~cache ~fun_name ~fun_var ~params =
let id_param =
match kind with
| `Connected -> [Nolabel, [%expr myid]]
| `Any -> [Nolabel, [%expr myid_o]]
| `None -> []
in
let uncache expr =
if cache <> None then [%expr Bs_proxy.extract [%e expr]] else expr
in
let parametrize' expr =
[%expr fun [%p pat_tuple (fst params)] -> [%e expr]]
in
let parametrize_id expr =
match kind with
| `Connected -> [%expr fun myid -> [%e expr]]
| `Any -> [%expr fun myid_o -> [%e expr]]
| `None -> expr
in
let wrap expr =
if raw
then expr
else
match kind with
| `Connected -> [%expr Os_session.connected_rpc [%e expr]]
| `Any -> [%expr Os_session.Opt.connected_rpc [%e expr]]
| `None -> [%expr Os_session.connected_wrapper [%e expr]]
in
let expr =
fun_name |> ident
|> apply (id_param @ build_params loc params)
|> uncache |> parametrize' |> parametrize_id |> wrap
in
let expr =
[%expr
~%(Eliom_client.server_function
~name:[%e str (rpc_name fun_name)]
[%json: [%t typ_tuple (fst params)]] [%e expr])
[%e expr_tuple (fst params)]]
in
[%stri
let%client [%p fun_var] = [%e parametrize loc params expr]
[@@ocaml.warning "-16"]]
let raw = ref false
let cache = ref false
let extension ~legacy ~loc ~path:_ fun_name expr =
let raw = !raw && not !cache in
let cache = (not legacy) && !cache in
let fun_var = pvar ~loc:fun_name.loc fun_name.txt in
let fun_name = fun_name.txt in
let kind, expr' =
if raw
then `None, expr
else
match expr with
| [%expr fun myid -> [%e? expr']] -> `Connected, expr'
| [%expr fun myid_o -> [%e? expr']] -> `Any, expr'
| _ -> `None, expr
in
let params, return_typ = collect_params [] expr' in
(match params with
| [], false -> print_error ~loc No_parameter
| l, _ ->
ignore
(List.fold_left
(fun acc (_, nm, _) ->
if List.mem nm acc then print_error ~loc (Duplicated_parameter nm);
if nm = "myid" || nm = "myid_o"
then print_error ~loc (Reserved_parameter nm);
nm :: acc)
[] l));
if cache && return_typ = None then print_error ~loc No_return_type;
let cache = if cache then return_typ else None in
Str.include_ ~loc
(Incl.mk ~loc
(Mod.structure ~loc
[ server_function ~loc ~kind ~fun_var expr'
; server_cacher ~loc ~kind ~cache ~fun_name ~fun_var ~params
; client_wrapper ~loc ~kind ~raw ~cache ~fun_name ~fun_var ~params
; server_wrapper ~loc ~kind ~raw ~cache ~fun_name ~fun_var ~params ]))
let extensions =
let open Ppxlib in
List.concat
@@ List.map
(fun (legacy, exts) ->
List.map
(fun ext ->
Extension.declare ext Extension.Context.structure_item
(let open Ast_pattern in
pstr
(pstr_value nonrecursive
(value_binding ~pat:(ppat_var __') ~expr:__ ^:: nil)
^:: nil))
(extension ~legacy))
exts)
[true, ["cw_rpc"; "crpc"; "crpc_opt"]; false, ["rpc"]]
let driver_args =
[ ( "--rpc-raw"
, Arg.Unit (fun () -> raw := true)
, " Do not insert any ocsigen-start session wrapper." )
; ( "--rpc-cache"
, Arg.Unit (fun () -> cache := true)
, " Insert caching directives (for internal use at Be Sport)." ) ]
let () =
List.iter
(fun (key, spec, doc) -> Ppxlib.Driver.add_arg key spec ~doc)
driver_args
let rules = List.map Ppxlib.Context_free.Rule.extension extensions
let () = Ppxlib.Driver.register_transformation ~rules "rpc"