-
Notifications
You must be signed in to change notification settings - Fork 125
/
opa_InsertRemote.ml
1487 lines (1309 loc) · 56.9 KB
/
opa_InsertRemote.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
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
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* depends in base *)
module Format = BaseFormat
module String = BaseString
module List = BaseList
(* refactoring in progress *)
module QmlCons = QmlAstCons
(* alias *)
module TypedExpr = QmlCons.TypedExpr
module TypedPat = QmlCons.TypedPat
(* shorthand *)
module Q = QmlAst
(* -- *)
#<Debugvar:RPC_DEBUG>
(* ******************************************************************)
(* Some utilities functions *****************************************)
(* ******************************************************************)
let full_apply gamma annotmap fun_ tys args =
let annotmap, e = QmlAstCons.TypedExpr.apply_partial gamma annotmap fun_ (tys @ args) in
QmlAstCons.TypedExpr.directive annotmap (`full_apply (List.length tys)) [e] []
type publish_directive = [`ajax_publish of [`sync | `async] | `comet_publish ]
type call_directive = [`ajax_call of [`sync | `async] | `comet_call]
type insert_directive = [ `insert_server_value of Ident.t ]
type producted_directive = [ `hybrid_value ]
type all_input_directives = [ publish_directive | call_directive | insert_directive ]
type options = {
optimize_insert : int;
optimize_publish : int;
optimize_call : int;
}
let default_options = {
optimize_insert = 0;
optimize_publish = 0;
optimize_call = 0;
}
let warn_olvl = OManager.warning ~wclass:WarningClass.warn_olevel
let verbose fmt = OManager.printf ("InsertRemote : "^^fmt^^"@.")
let debug_print _f =
#<If> OManager.printf "InsertRemote : %s@\n" (_f ())
#<Else> ()
#<End>
let debug_string str = debug_print (fun _ -> str)
let debug_do _f =
#<If> _f ()
#<Else> ()
#<End>
let debug_code ?(str="") _code =
ignore(str);
#<If>
verbose "DEBUG CODE %s" str;
debug_do
(fun _ ->
List.iter
(function
| Q.NewVal (_, l) | Q.NewValRec (_, l) ->
List.iter (
fun (ident, expr) ->
if String.is_contained (Option.get DebugVariables.rpc_debug)
(Ident.original_name ident)
then debug_string
(Format.sprintf "%s | %a = %a" str
QmlPrint.pp#ident ident
QmlPrint.pp#expr expr);
) l
| _ -> ()
)
_code
)
#<End>
(* Generate optimized code if true *)
(* TODOK1 - Make some other optimization:
- Do not instantiate at runtime if they aren't type variable
- ...
*)
let optimized = false
let directive_to_side = function
| `ajax_publish _ | `comet_call -> `server
| `comet_publish | `ajax_call _ | `insert_server_value _ -> `client
let call_directive_to_sync = function
| `ajax_call b -> b
| _ -> `sync
let publish_directive_to_sync = function
| `ajax_publish b -> b
| _ -> `sync
let _call, _stub, _skel, _insert, _reset, get_info =
#<If>
let rc = ref 0
and rs = ref 0
and rsk = ref 0
and ri = ref 0
in
((fun _ -> incr rc),
(fun _ -> incr rs),
(fun _ -> incr rsk),
(fun _ -> incr ri),
(fun _ -> rc := 0; rs := 0; rsk := 0; ri := 0),
(fun _ -> !rc, !rs, !rsk, !ri)
)
#<Else>
((fun _ -> ()),
(fun _ -> ()),
(fun _ -> ()),
(fun _ -> ()),
(fun _ -> ()),
(fun _ -> -1, -1, -1, -1)
)
#<End>
let debug_info _side =
#<If>
debug_do
(fun _ ->
let c, s, sk, i = get_info () in
let _side =
match _side with `server -> "server" | `client -> "client" in
verbose
"%i stub(s) generated on %s for %i call(s) resolved. " s _side c;
verbose
"%i skeleton(s) generated on %s" sk _side;
verbose
"%i insert values resolved on %s" i _side
)
#<Else> ()
#<End>
let check_hybrid_value annotmap e1 e2 =
let t1 = QmlAnnotMap.find_ty (Q.QAnnot.expr e1) annotmap in
let t2 = QmlAnnotMap.find_ty (Q.QAnnot.expr e2) annotmap in
match t1, t2 with
| Q.TypeArrow ([Q.TypeConst Q.TyString], Q.TypeVar _),
Q.TypeConst Q.TyString -> true
| _ -> false
(* ******************************************************************)
(* Retrieve OPA type and functions **********************************)
(* /!\ WARNING : DON'T USE BELOW FUNCTIONS UNTIL YOU READ /!\ *******)
(* /!\ COMMENT of preprocess_types. /!\ *****************************)
(* ******************************************************************)
(** *)
module TyIdent = struct
let default_pos name = Q.Ident (Annot.nolabel "Opa_InsertRemote", Ident.source name)
let get name ~side ?(posexpr=default_pos name) annotmap gamma =
try
let ident = OpaMapToIdent.val_ ~side name in
let (ty:QmlAst.ty) = QmlTypes.Scheme.instantiate (QmlTypes.Env.Ident.find ident gamma) in
( (* manual check, to verify that explicit instantiation has done its job *)
match name, ty with
| "OpaSerialize_serialize", Q.TypeArrow ([_] , Q.TypeArrow([_], Q.TypeConst Q.TyString)) -> ()
| "OpaSerialize_serialize", _ ->
OManager.i_error "BAD TYPE FOR %s %a@." name QmlPrint.pp#ty ty;
| _ -> ()
);
TypedExpr.ident annotmap ident ty
with Not_found ->
let context = QmlError.Context.annoted_expr annotmap posexpr in
QmlError.cond_violation QmlAlphaConv.Check.unbound_id context
"Missing ident"
end
(** This module allows access to some values and types defined on
module OpaType (written on opa). This expression are well
typed. For more information see the corresponding module written
in OPA. *)
module OpaType = struct
let tsc = ref Pass_ExplicitInstantiation.opatsc_type
let ty = ref Pass_ExplicitInstantiation.opatype_type
let row = ref Pass_ExplicitInstantiation.oparow_type
let col = ref Pass_ExplicitInstantiation.opacol_type
(** Type of list(OpaType.ty)*)
let list_of_opaty =
ref (Q.TypeName ([!ty], Q.TypeIdent.of_string Opacapi.Types.list))
let tsc_implementation = TyIdent.get Opacapi.OpaTsc.implementation
end
(** This module allows access to some values and types defined on
module OpaSerialize (written on opa). This expression are well
typed. For more information see the corresponding module written
in OPA. *)
module OpaSerialize = struct
let serialize = TyIdent.get Opacapi.OpaSerialize.serialize
let serialize_for_js = TyIdent.get Opacapi.OpaSerialize.serialize_for_js
let unserialize = TyIdent.get Opacapi.OpaSerialize.unserialize
let unserialize_unsafe = TyIdent.get Opacapi.OpaSerialize.unserialize_unsafe
end
(** This module allows access to some values and types defined on
module OpaRPC (written on opa). This expression are well
typed. For more information see the corresponding module written
in OPA. *)
module OpaRPC = struct
let request =
ref (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.OpaRPC.request))
let taux_extract_values =
let t =
QmlAst.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.list) in
ref (Q.TypeName ([t], Q.TypeIdent.of_string Opacapi.Types.option))
let serialize = TyIdent.get Opacapi.OpaRPC.serialize
let empty_request = TyIdent.get Opacapi.OpaRPC.empty_request
let add_var_types = TyIdent.get Opacapi.OpaRPC.add_var_types
let add_row_types = TyIdent.get Opacapi.OpaRPC.add_row_types
let add_col_types = TyIdent.get Opacapi.OpaRPC.add_col_types
let add_args_with_type = TyIdent.get Opacapi.OpaRPC.add_args_with_type
let unserialize = TyIdent.get Opacapi.OpaRPC.unserialize
let extract_types = TyIdent.get Opacapi.OpaRPC.extract_types
let extract_values = TyIdent.get Opacapi.OpaRPC.extract_values
let send_to_other_side ~side ~sync = TyIdent.get
(if side = `client then
match sync with
| `sync -> Opacapi.OpaRPC.client_send_to_server
| `async -> Opacapi.OpaRPC.client_async_send_to_server
else
match sync with
| `sync -> Opacapi.OpaRPC.server_send_to_client
| `async -> Opacapi.OpaRPC.server_async_send_to_client) ~side
let fake_stub = TyIdent.get Opacapi.OpaRPC.fake_stub
let error_stub = TyIdent.get Opacapi.OpaRPC.error_stub
let try_cache ~side = TyIdent.get
(match side with
| `client -> Opacapi.OpaRPC.client_try_cache
| `server -> Opacapi.OpaRPC.server_try_cache) ~side
module Dispatcher = struct
let ty_str = Q.TypeConst Q.TyString
let ty_opt_str =
ref (Q.TypeName ([ty_str], Q.TypeIdent.of_string Opacapi.Types.option))
let register ~side = TyIdent.get
(if side = `client then Opacapi.OpaRPC.client_dispatcher_register
else Opacapi.OpaRPC.server_dispatcher_register) ~side
end
end
module Opa2Js =
struct
let to_string = TyIdent.get Opacapi.Opa2Js.to_string
end
(** /!\ WARNING /!\
This function must be used before all functions above. If this
function is not called before you use above functions,
QmlFlatCompiler will make an assert failure.
Note : All types are refences and are updated by this
function. I'm accord to you it's not very nice, but I don't want
had a gamma argument on almost above function.
*)
let preprocess_types gamma =
let process ty = fst (QmlTypes.type_of_type gamma ty) in
OpaType.tsc := process Pass_ExplicitInstantiation.opatsc_type;
OpaType.ty := process Pass_ExplicitInstantiation.opatype_type;
OpaType.list_of_opaty :=
process (Q.TypeName ([!OpaType.ty], Q.TypeIdent.of_string Opacapi.Types.list));
OpaRPC.request :=
process (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.OpaRPC.request));
OpaRPC.taux_extract_values :=
(let t = process (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.list)) in
process (Q.TypeName ([t], Q.TypeIdent.of_string Opacapi.Types.option)));
OpaRPC.Dispatcher.ty_opt_str :=
process (Q.TypeName ([Q.TypeConst Q.TyString], Q.TypeIdent.of_string Opacapi.Types.option))
(* ******************************************************************)
(* Utils functions for generate some expressions ********************)
(* ******************************************************************)
(** Update gamma *)
let update_gamma gamma id ty =
QmlTypes.Env.Ident.add id (QmlTypes.Scheme.quantify ty) gamma
(** Generate typed variable.
@param name Name of variable
@param ty Type of variable
@return (annotmap, gamma, id, ty, expr) [id] is the ident of
variable. [ty] is the type of this variable. [expr] is expression
of this variable.
*)
let generate_var ~annotmap ~gamma name ty =
let ident = (Ident.next name) in
let (annotmap, expr) = TypedExpr.ident annotmap ident ty in
(annotmap, gamma(* update_gamma gamma ident ty *), ident, ty, expr)
(** Generate typed variables. Name of this variables is
"prefix[1..n]".
@param Prefix of variables.
@param Type of variables.
@param n Number of variables to generate.
@return (annotmap, gamma, list of ident, list of expression)
*)
let generate_vars ~annotmap ~gamma prefix ty =
let rec aux annotmap gamma id_l ex_l = function
| 0 -> annotmap, gamma, id_l, ex_l
| n -> let annotmap, gamma, id, _, ex =
generate_var ~annotmap ~gamma (Printf.sprintf "%s%d" prefix n) ty in
aux annotmap gamma (id::id_l) (ex::ex_l) (n-1) in
aux annotmap gamma [] []
(** Generate a match on option, like this in OPA syntax :
match [expr] with
| {some = [id_expr]} -> [ok_expr]
| {none} -> ko_expr
@param expr Expression to match. This expression must be type of
option.
@param ident_list A list of ident for bind elements in matched
list.
@param ok_expr Expression when match success. Il this expression
you can use [id_expr].
@param ko_expr Expression when match failed.
@return (annotmap, match expression).
*)
let generate_match_some ~annotmap ~gamma expr id_expr ty_id ok_expr ko_expr =
let annotmap, patvar =
TypedPat.var annotmap id_expr ty_id in
TypedPat.match_option annotmap gamma expr patvar ok_expr ko_expr
(** Generate a pattern on list. *)
let generate_pat_list ~annotmap ident_list ty =
let annotmap, pat_list =
let annotmap, e1 = TypedPat.emptyrecord annotmap in
TypedPat.record annotmap ["nil", e1]
in
List.fold_right
(fun ident (annotmap, acc) ->
let annotmap, pat = TypedPat.var annotmap ident ty in
TypedPat.record annotmap [
"hd", pat ;
"tl", acc ;
]
) ident_list (annotmap, pat_list)
(** Generate a match on list(option), like this in OPA syntax :
match [expr] with
| {some = [ident_list]} -> [ok_expr]
| _ -> [ko_expr]
@param expr Expression to match. This expression must be type of
option(list).
@param ident_list A list of ident for bind elements in matched list.
@param ok_expr Expression when match success. In this expression
you can use ident of [ident_list].
@param ko_expr Expression when match failed.
@return (annotmap, match expression).
*)
let generate_match_some_list ~annotmap expr ident_list ok_expr ko_expr ty_ident =
let annotmap, pat_list = generate_pat_list ~annotmap ident_list ty_ident in
let annotmap, pat_some =
TypedPat.record annotmap ["some", pat_list] in
let annotmap, any = TypedPat.any annotmap in
TypedExpr.match_ annotmap expr [(pat_some, ok_expr); (any, ko_expr)]
(**
Generates the following expression:
match $expr$ with
| {field1 = [$ident_list_1$]; field2 = [$ident_list_2$], ...} -> $ok_expr$
| _ -> $ko_expr$
*)
let generate_match_record_of_list ~annotmap expr ident_list_list ok_expr ko_expr =
let annotmap, pat_list_list =
List.fold_left_map
(fun annotmap (field, ident_list, ty_ident) ->
let annotmap, l = generate_pat_list ~annotmap ident_list ty_ident in
annotmap, (field, l)
) annotmap ident_list_list in
let annotmap, pat = TypedPat.record annotmap pat_list_list in
let annotmap, any = TypedPat.any annotmap in
TypedExpr.match_ annotmap expr [(pat, ok_expr); (any, ko_expr)]
(* ******************************************************************)
(* Main functions for resolving directives **************************)
(* ******************************************************************)
(** Retrieve a registering string from ident. This string it's the end
of url where skeleton is published.
It is NOT related to the closure identifiers
*)
let ident_to_registering renamingmap ident =
(*try*)
Ident.to_uniq_string (
QmlRenamingMap.original_from_new renamingmap ident
)
(*with
Not_found ->
Printf.printf "Couldn't find original name of %s\n%!" (Ident.to_string ident);
Ident.to_uniq_string ident*)
(** Check given [expr], and retrieve associated expression, ident, and
type in explicit map.*)
let check_and_get ?(msg="") ~annotmap ~gamma:_ explicit_map expr =
let iv expr str =
invalid_arg
(Format.sprintf
"%s %s : unexpected expression => %a"
msg str QmlPrint.pp#expr expr
) in
match expr with
| Q.Ident (label,ident) ->
let o =
try IdentMap.find ident explicit_map
with Not_found ->
OManager.i_error
"Opa_InsertRemote: cannot find %s in the explicit_map"
(Ident.to_string ident) in
begin
match o with
| Some (label2, ident, kind) ->
(* the identifier was rewritten by ei *)
let expr2 = Q.Ident (label2, ident) in
#<If>
if String.is_contained (Option.get DebugVariables.rpc_debug)
(Ident.original_name ident)
then
verbose
"@[<v2>Identifier rewritten by ei:@ the one that takes all the type variables:%a@ optimized:%a@]"
QmlPrint.pp#ident ident
QmlPrint.pp#expr expr
#<End>;
(* Get type and scheme of explicit instantiate expression *)
let ty = QmlAnnotMap.find_ty_label label2 annotmap in
let tsc = QmlTypes.Scheme.quantify ty in
(* get nb of ty var *)
let nb_tyvar,nb_rowvar,nb_colvar = QmlGenericScheme.full_arity tsc in
(* Get original type and scheme of expression (before exp-inst) *)
let oty = QmlAstCons.Type.Arrow.drop (nb_tyvar+nb_rowvar+nb_colvar) ty in
let otsc = QmlTypes.Scheme.quantify oty in
expr2, ident, ty, tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, kind
| None ->
(* the identifier was not rewritten by ei *)
#<If>
if String.is_contained (Option.get DebugVariables.rpc_debug)
(Ident.original_name ident)
then
verbose
"Identifier not rewritten by ei: %a = %a"
QmlPrint.pp#ident ident
QmlPrint.pp#expr expr
#<End>;
let ty = QmlAnnotMap.find_ty_label label annotmap in
let tsc = QmlTypes.Scheme.quantify ty in
expr, ident, ty, tsc, 0, 0, 0, ty, tsc, `one_lambda
end
| _ -> iv expr "on an non ident expression"
(* ***********)
(* SKELETONS *)
(* ***********)
(** Generate a skeleton from an expression. This function is used
for resolve [@ajax_publish, @comet_publish].
@param expr Expression to make a skeleton. This expression must be an
ident else raise Invalid_argument exception.
@return A skeleton for given [expr].
This generate skeleton maybe used both on server and client.
fun str ->
match OpaRPC.unserialize str with
| {some = request} ->
extracted_types = OpaRPC.extract_type request
(match extracted_types with
| {types=[v1; v2; ...]; rows=[r1,r2,...]; cols=[c1,c2,...]} ->
(match OpaTsc.implementation extracted_types tsc with
| { TyArrow_params = ts; TyArrow_res = tres } ->
(match OpaRPC.extract_value ts /* or [] if not a function type */ request with
| { some = [a1; a2; a3; ...] } ->
{ some = OpaSerialize.serialize tres
(sliced_fun v1 v2 ... r1 r2 ... c1 c2 ... a1 a2 a3 ...) }
| _ -> { none = () })
| _ -> { none = () })
| _ -> { none = () })
| _ -> { none = () }
: string -> string option
Generated skeleton is good only if explicit instantiation has already taken place.
Execution of the generated skeleton:
1 - Unserialize RPC request represented by argument of the
skeleton.
2 - Extract instantiate types include in request (if original type
scheme have type variable).
3 - Extract value and check with instantiate type of function.
4 - Call to the function with type arguments and values (either sync or Scheduler.push)
5 - If sync, serialize the response.
5 - If async, send standard reply.
@param sync True if the call is synchronous, false if it is asynchronous i.e. result doesn't matter
@param expr The body of the function
*)
let generate_skeleton explicit_map ~annotmap ~stdlib_gamma ~gamma ~side expr =
(* Check and get *)
let expr, ident, _ty, _tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, number_of_lambdas =
check_and_get ~msg:"generate_skeleton" ~annotmap ~gamma explicit_map expr
in
#<If>
if String.is_contained (Option.get DebugVariables.rpc_debug)
(Ident.original_name ident)
then
verbose
"SKELETON %a = @\n Type : %a@\n OriginalType : %a@\nExprType : %a@\n"
QmlPrint.pp#ident ident
QmlPrint.pp#ty _ty
QmlPrint.pp#ty oty
QmlPrint.pp#ty (QmlAnnotMap.find_ty (Q.QAnnot.expr expr) annotmap)
else ()
#<Else>()
#<End>;
(* Argument of generated skeleton *)
let annotmap, gamma, ident_arg, ty_arg, expr_arg =
generate_var ~annotmap ~gamma "str" (Q.TypeConst Q.TyString) in
(* Some variables of generated skeleton *)
let annotmap, gamma, ident_req, ty_req, expr_req =
generate_var ~annotmap ~gamma "request" !OpaRPC.request in
(* Opa type scheme expression *)
let annotmap, opatsc =
Pass_ExplicitInstantiation.tsc_to_opatsc ~val_:OpaMapToIdent.val_ ~side (annotmap, gamma) otsc in
(* List of ident for types extracted *)
let annotmap, gamma, ident_ty_list, list_expr_ty =
generate_vars ~annotmap ~gamma "v" !OpaType.ty nb_tyvar in
let annotmap, gamma, ident_row_list, list_expr_row =
generate_vars ~annotmap ~gamma "r" !OpaType.row nb_rowvar in
let annotmap, gamma, ident_col_list, list_expr_col =
generate_vars ~annotmap ~gamma "c" !OpaType.col nb_colvar in
(* Pattern arrow and associated vars *)
let annotmap, gamma, ident_tres, ty_tres, expr_tres =
generate_var ~annotmap ~gamma "tres" !OpaType.ty in
let annotmap, gamma, pat_arrow, n_args, expr_ins_list, is_a_function =
let rec aux annotmap gamma = function
| Q.TypeArrow (lt, _res) ->
let n_args = List.length lt in
let ts = Ident.next "ts" in
(* FIXME: give a real type *)
let ts_type = QmlAstCons.Type.next_var () in
let annotmap, ts_expr = TypedExpr.ident annotmap ts ts_type in
let annotmap, pat_ts = TypedPat.var annotmap ts ts_type in
let annotmap, pat_res = TypedPat.var annotmap ident_tres ty_tres in
let annotmap, pat =
TypedPat.record annotmap [
"TyArrow_params", pat_ts ;
"TyArrow_res", pat_res ;
] in
annotmap, gamma, pat, n_args, ts_expr, true
| Q.TypeName (list, tyident) ->
aux annotmap gamma
(QmlTypesUtils.Inspect.find_and_specialize gamma tyident list)
| _ ->
let n_args = 0 in
let annotmap, pat_res = TypedPat.var annotmap ident_tres ty_tres in
let annotmap, ts_expr = TypedExpr.list (annotmap, gamma) [] in
annotmap, gamma, pat_res, n_args, ts_expr, false in
aux annotmap gamma oty in
(* List of ident for values extracted *)
let ty_ident_val_list = QmlCons.Type.typevar (Q.TypeVar.next ()) in
let annotmap, gamma, ident_val_list, list_expr_val =
generate_vars ~annotmap ~gamma "a" ty_ident_val_list n_args in
(* Call to encapsulated function *)
let annotmap, fun_call =
let annotmap, expr =
TypedExpr.shallow_copy annotmap expr in
(* NOT SURE: what if the expression already has no arguments? *)
(*try*)
if is_a_function then
let args_ty = list_expr_ty @ list_expr_row @ list_expr_col in
match number_of_lambdas with
| `one_lambda -> full_apply gamma annotmap expr args_ty list_expr_val
| `two_lambdas ->
let annotmap, apply1 = QmlAstCons.TypedExpr.apply gamma annotmap expr args_ty in
QmlAstCons.TypedExpr.apply gamma annotmap apply1 list_expr_val
else (
assert (list_expr_val = []);
TypedExpr.may_apply gamma annotmap expr (list_expr_ty @ list_expr_row @ list_expr_col)
)
(*with e -> Format.printf "FAILURE:@\n%a@." QmlPrint.pp#expr fun_call; raise e*)
in
(* Call to serialize function *)
let annotmap, call_ser = match side with
| `server -> TypedExpr.opa_tuple_2 (annotmap,gamma) (expr_tres,fun_call)
| `client ->
let annotmap, ser = OpaSerialize.serialize ~side annotmap stdlib_gamma in
full_apply gamma annotmap ser [expr_tres] [fun_call] in
(* Call to extract_values *)
let annotmap, call_ext_val =
let annotmap, ext = OpaRPC.extract_values ~side annotmap stdlib_gamma in
TypedExpr.apply gamma annotmap ext [expr_req; expr_ins_list] in
(* Match values *)
let annotmap, match_values =
let annotmap, ok_expr = TypedExpr.some annotmap gamma call_ser in
let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr call_ser) annotmap in
let annotmap, ko_expr =
#<If>
let annotmap, es =
OpaRPC.error_stub ~side annotmap stdlib_gamma in
let annotmap, msg =
TypedExpr.string annotmap "match_values" in
TypedExpr.apply gamma annotmap es [msg]
#<Else>
TypedExpr.none ~ty annotmap gamma
#<End>
in
generate_match_some_list ~annotmap
call_ext_val ident_val_list ok_expr ko_expr ty_ident_val_list
in
let ident_extracted_types = Ident.next "extracted_types" in
(* FIXME: give a real type *)
let type_ident_extracted_types = QmlAstCons.Type.next_var () in
(* Call to instantiate *)
let annotmap, call_ins =
let annotmap, ins = OpaType.tsc_implementation ~side annotmap stdlib_gamma in
let annotmap, expr_ty_list = TypedExpr.ident annotmap ident_extracted_types type_ident_extracted_types in
TypedExpr.apply gamma annotmap ins [expr_ty_list ;opatsc] in
(* Match instantiate types *)
let annotmap, match_types =
let annotmap, ko_expr =
#<If>
let annotmap, es =
OpaRPC.error_stub ~side annotmap stdlib_gamma in
let annotmap, msg =
TypedExpr.string annotmap "instantiate" in
TypedExpr.apply gamma annotmap es [msg]
#<Else>
TypedExpr.none annotmap gamma
#<End>
in
let annotmap, any = TypedPat.any annotmap in
TypedExpr.match_ annotmap call_ins [(pat_arrow, match_values); (any, ko_expr)]
in
(* Call to extract_types *)
let annotmap, call_ext_ty =
let annotmap, ext = OpaRPC.extract_types ~side annotmap stdlib_gamma in
let annotmap, expr_req = TypedExpr.shallow_copy annotmap expr_req in
TypedExpr.apply gamma annotmap ext [expr_req] in
(* Match extracted types *)
let annotmap, match_types =
let annotmap, ko_expr =
#<If>
let annotmap, es =
OpaRPC.error_stub ~side annotmap stdlib_gamma in
let annotmap, msg =
TypedExpr.string annotmap "match_types" in
TypedExpr.apply gamma annotmap es [msg]
#<Else>
TypedExpr.none annotmap gamma
#<End> in
let annotmap, extracted_types = TypedExpr.ident annotmap ident_extracted_types type_ident_extracted_types in
let annotmap, match_ =
generate_match_record_of_list
~annotmap extracted_types [
"types", ident_ty_list, !OpaType.ty;
"rows", ident_row_list, !OpaType.row;
"cols", ident_col_list, !OpaType.col;
] match_types ko_expr in
TypedExpr.letin annotmap [ident_extracted_types, call_ext_ty] match_
in
(* Call to unserialize and match it *)
let annotmap, call_un =
let annotmap, un = OpaRPC.unserialize ~side annotmap stdlib_gamma in
TypedExpr.apply gamma annotmap un [expr_arg] in
let annotmap, match_un =
let annotmap, ko_expr =
#<If>
let annotmap, es =
OpaRPC.error_stub ~side annotmap stdlib_gamma in
let annotmap, msg =
TypedExpr.string annotmap "unserialize" in
TypedExpr.apply gamma annotmap es [msg]
#<Else>
TypedExpr.none annotmap gamma
#<End>
in
generate_match_some ~annotmap ~gamma call_un ident_req ty_req
match_types ko_expr in
(* Make the lambda *)
let annotmap, fun_skeleton =
TypedExpr.lambda annotmap [ident_arg, ty_arg] match_un in
(* Make an ident for skeleton *)
let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr fun_skeleton) annotmap in
let id = Ident.refresh ~map:(fun s -> "skeleton_"^s) ident in
let annotmap, iskeleton =
TypedExpr.ident annotmap id ty in
annotmap, update_gamma gamma id ty, (iskeleton, fun_skeleton)
(** Register a skeleton as an rpc.
@param iskeleton The skeleton to be register should be identified
by this parameter.
@param oexpr Expression that was used for generate skeleton.
@param side Side where the skeleton should be register.*)
let register_skeleton ~renamingmap ~annotmap ~stdlib_gamma ~gamma ~side oexpr iskeleton =
match oexpr with
| Q.Ident (_, oident) ->
(* Register skeleton *)
let annotmap, reg =
OpaRPC.Dispatcher.register ~side annotmap stdlib_gamma in
let annotmap, str =
TypedExpr.tagged_string annotmap (ident_to_registering renamingmap oident) Q.Rpc_def in
let annotmap, call =
TypedExpr.apply gamma annotmap reg [str; iskeleton] in
let ident = Ident.refresh ~map:(fun s -> "register_"^s) oident in
let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr call) annotmap in
annotmap, update_gamma gamma ident ty , (ident, call)
| _ -> assert false (* Inexpected expr *)
(* *******)
(* STUBS *)
(** Generate a stub from an expression. This function is used
for resolve [@ajax_call, @comet_call].
@param expr Expression to make a skeleton. This expression must be an
ident else raise Invalid_argument exception.
@side Side where the stub will be used.
@return A stub for given [expr].
If call is synchronous, generate a stub along the lines of:
v1, v2, .., r1, r2, ..., c1, c2, ... ->
fun a1 -> fun a2 -> fun a3 ->
match OpaTsc.implementation [i1; i2; ...] tsc /*type scheme of the function*/ with
| { TyArrow_params = [t1; t2; t3; ...]; TyArrow_res = tres } } ->
send_to_<side>
"<function_id>"
(OpaRPC.serialize
(OpaRPC.add_args_with_type t3 a3
(OpaRPC.add_args_with_type t2 a2
(OpaRPC.add_args_with_type t1 a1
(OpaRPC.add_var_types i2
(OpaRPC.add_var_types i1 OpaRPC.empty_request))))))
tres
| _ -> /* Make an error */
If call is asynchronous, generate a stub along the lines of:
fun i1 -> fun i2 -> ... ->
fun a1 -> fun a2 -> fun a3 ->
match OpaTsc.implementation [i1; i2; ...] tsc /*type scheme of the function*/ with
| { TyArrow_params = [t1; t2; t3; ...]; TyArrow_res = _ } } ->
async_send_to_<side>
"<function_id>"
(OpaRPC.serialize
(OpaRPC.add_args t3 a3
(OpaRPC.add_args t2 a2
(OpaRPC.add_args t1 a1
(OpaRPC.add_var_types i2
(OpaRPC.add_var_types i1 OpaRPC.empty_request))))))
| _ -> /* Make an error */
Generate stub make :
1 - Instantiate type scheme
2 - Let ret as the expected type of value returned
(Used for check type of returned value)
3 - Add instantiate type variable of the function to an empty
request. (Type given at runtime, like exp-inst).
4 - Add argument to request
5 - Send serialized request, and check returned value with ret.
*)
let generate_stub explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync expr =
(* Check and get *)
let _expr, ident, _ty, _tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, _number_of_lambdas =
check_and_get ~msg:"generate_stub" ~annotmap ~gamma explicit_map expr in
#<If>
if String.is_contained (Option.get DebugVariables.rpc_debug)
(Ident.original_name ident)
then
verbose
"%a = %a"
QmlPrint.pp#ident ident
QmlPrint.pp#ty _ty
else ()
#<Else>()
#<End>;
(* Create type args *)
let annotmap, gamma, ident_ty_list, expr_ty_list =
generate_vars ~annotmap ~gamma "v" !OpaType.ty nb_tyvar in
let annotmap, gamma, ident_row_list, expr_row_list =
generate_vars ~annotmap ~gamma "r" !OpaType.row nb_rowvar in
let annotmap, gamma, ident_col_list, expr_col_list =
generate_vars ~annotmap ~gamma "c" !OpaType.col nb_colvar in
(* Get type of standard args *)
let is_lambda, typeof_args, typeof_res =
let rec aux = function
| Q.TypeArrow (args, res) -> true, args, res
| Q.TypeName (list, tyident) ->
aux (QmlTypesUtils.Inspect.find_and_specialize gamma tyident list)
| r -> false, [], r in
aux oty
in
(* Create standard args [a*] and variable for pattern arrow [t*] *)
let annotmap, gamma,
id_ty_std_list, expr_std_list,
id_ins_list, ex_ins_list =
let rec aux i annotmap gamma = function
| [] -> annotmap, gamma, [], [], [], []
| ty::tys ->
let annotmap, gamma, id_l, ex_l, id_l2, ex_l2 =
aux (i+1) annotmap gamma tys in
let annotmap, gamma, id, _, ex =
generate_var ~annotmap ~gamma (Printf.sprintf "a%d" i) ty in
let annotmap, gamma, id2, _, ex2 =
generate_var ~annotmap ~gamma
(Printf.sprintf "t%d" i) !OpaType.ty
in
annotmap, gamma,
(id,ty)::id_l, ex::ex_l, id2::id_l2, ex2::ex_l2 in
aux 0 annotmap gamma typeof_args
in
(* Some variables of generated stub *)
let annotmap, gamma, id_tres, ty_tres, ex_tres =
generate_var ~annotmap ~gamma "tres" !OpaType.ty in
(* Type scheme in opa *)
let annotmap, opatsc =
Pass_ExplicitInstantiation.tsc_to_opatsc ~val_:OpaMapToIdent.val_ ~side (annotmap, gamma) otsc in
(* Pattern arrow *)
let annotmap, pat_arrow =
let annotmap, pat_res =
TypedPat.var annotmap id_tres ty_tres in
if not is_lambda then annotmap, pat_res
else
let annotmap, pat_list =
generate_pat_list ~annotmap id_ins_list !OpaType.ty in
let annotmap, pat =
TypedPat.record annotmap [
"TyArrow_params", pat_list ;
"TyArrow_res", pat_res ;
] in
annotmap, pat
in
(* Create request *)
let annotmap, req =
let annotmap, req = OpaRPC.empty_request ~side annotmap stdlib_gamma in
let annotmap, req =
let add_variables annotmap req ident variables =
List.fold_left
(fun (annotmap, req) t ->
let annotmap, add_ty = ident ~side ?posexpr:None annotmap stdlib_gamma in
TypedExpr.apply gamma annotmap add_ty [t;req])
(annotmap, req) variables in
(* Insert type var *)
let annotmap, req = add_variables annotmap req OpaRPC.add_var_types expr_ty_list in
let annotmap, req = add_variables annotmap req OpaRPC.add_row_types expr_row_list in
let annotmap, req = add_variables annotmap req OpaRPC.add_col_types expr_col_list in
annotmap, req in
(* Insert std args *)
List.fold_left2
(fun (annotmap, req) t a ->
let annotmap, add_args_with_type = OpaRPC.add_args_with_type ~side annotmap stdlib_gamma in
TypedExpr.apply gamma annotmap add_args_with_type [t; a; req])
(annotmap, req) ex_ins_list expr_std_list in
(* String identifier of function *)
let annotmap, f_id =
TypedExpr.tagged_string annotmap (ident_to_registering renamingmap ident) Q.Rpc_use in
(* Match send_to *)
let annotmap, send_to =
let annotmap, send =
OpaRPC.send_to_other_side ~side ~sync annotmap stdlib_gamma in
TypedExpr.apply gamma annotmap send [f_id; req; ex_tres]
in
(* Match instantiate *)
let annotmap, call_ins =
let annotmap, ins = OpaType.tsc_implementation ~side annotmap stdlib_gamma in
let copy_list annotmap expr_ty_list =
let annotmap, expr_ty_list =
TypedExpr.shallow_copys annotmap expr_ty_list in
TypedExpr.list (annotmap, gamma) expr_ty_list in
let annotmap, ex_list_ty = copy_list annotmap expr_ty_list in
let annotmap, ex_list_row = copy_list annotmap expr_row_list in
let annotmap, ex_list_col = copy_list annotmap expr_col_list in
let annotmap, instantiation = TypedExpr.record annotmap [
"types", ex_list_ty;
"rows", ex_list_row;
"cols", ex_list_col;
] in
TypedExpr.apply gamma annotmap ins [instantiation; opatsc]
in
let annotmap, match_instantiate =
let annotmap, err_stub = OpaRPC.error_stub ~side annotmap stdlib_gamma in
let annotmap, f_id = TypedExpr.shallow_copy annotmap f_id in
let annotmap, ko_expr = TypedExpr.apply gamma annotmap err_stub [f_id] in
let annotmap, any = TypedPat.any annotmap in
TypedExpr.match_ty annotmap call_ins [(pat_arrow, send_to); (any, ko_expr)] typeof_res
in
(* Create lambda *)
(*
<!> In case ei has introduce some extra arguments, we must currently generate 2 lambdas.
but if no argument are added, we should not create an empty lambda.
That what the function may_lambda does.
<!> Quentin (Fri Sep 10 17:07:29 CEST 2010) what about the first lambda ?
*)
let annotmap, stub =
if not is_lambda then
TypedExpr.may_lambda annotmap
(List.map (fun id -> id, !OpaType.ty) ident_ty_list @
List.map (fun id -> id, !OpaType.row) ident_row_list @
List.map (fun id -> id, !OpaType.col) ident_col_list) match_instantiate
else
let annotmap, lambda =
TypedExpr.lambda annotmap
(List.map (fun id -> id, !OpaType.ty) ident_ty_list @
List.map (fun id -> id, !OpaType.row) ident_row_list @
List.map (fun id -> id, !OpaType.col) ident_col_list @
id_ty_std_list)
match_instantiate in
TypedExpr.directive annotmap (`lifted_lambda (nb_tyvar + nb_colvar + nb_rowvar, [])) [lambda] [] in