-
Notifications
You must be signed in to change notification settings - Fork 125
/
mlidl.ml
3527 lines (3252 loc) · 162 KB
/
mlidl.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/>.
*)
module String = Base.String
module List = Base.List
module PI = Parse_idl
module O = Ocaml
module Cons = O.Cons
let testfile = false
let debug = ref false
let verbose = ref (!debug)
let module_name = ref ""
let output_suffix = ref "types"
let bsl_prefix = ref "bsl"
(*let encoding_number = ref 2*)
let ocaml_wrap_opt = ref true
let opa_wrap_opt = ref true
let native_parser = ref true
let hlnet_logging = ref false
let protocol_version = ref 1
let default_port = ref 49152
let default_addr = ref "Unix.inet_addr_loopback"
let logger_function = ref "Logger.log"
let create_functions = ref true
let tojson_functions = ref true
let fromjson_functions = ref true
let string_functions = ref true
let bsl_file = ref true
let no_ocaml = ref false
let no_opa = ref false
let protocol_name = ref None
let mns = ref ""
let _Mns = ref ""
let bslmns = ref ""
let base = ref ""
type opts = {
opt_debug : bool;
opt_verbose : bool;
opt_module_name : string;
opt_output_suffix : string;
opt_bsl_prefix : string;
(*opt_encoding_number : int;*)
opt_ocaml_wrap_opt : bool;
opt_opa_wrap_opt : bool;
opt_native_parser : bool;
opt_hlnet_logging : bool;
opt_protocol_version : int;
opt_default_port : int;
opt_default_addr : string;
opt_logger_function : string;
opt_create_functions : bool;
opt_tojson_functions : bool;
opt_fromjson_functions : bool;
opt_string_functions : bool;
opt_bsl_file : bool;
opt_no_ocaml : bool;
opt_no_opa : bool;
opt_mns : string;
}
let default_opts = ref {
opt_debug = false;
opt_verbose = false;
opt_module_name = "";
opt_output_suffix = "types";
opt_bsl_prefix = "bsl";
(*opt_encoding_number = 2;*)
opt_ocaml_wrap_opt = true;
opt_opa_wrap_opt = true;
opt_native_parser = true;
opt_hlnet_logging = false;
opt_protocol_version = 1;
opt_default_port = 49152;
opt_default_addr = "Unix.inet_addr_loopback";
opt_logger_function = "Logger.log";
opt_create_functions = true;
opt_tojson_functions = true;
opt_fromjson_functions = true;
opt_string_functions = true;
opt_bsl_file = true;
opt_no_ocaml = false;
opt_no_opa = false;
opt_mns = "";
}
let save_opts () = {
opt_debug = !debug;
opt_verbose = !verbose;
opt_module_name = !module_name;
opt_output_suffix = !output_suffix;
opt_bsl_prefix = !bsl_prefix;
(*opt_encoding_number = !encoding_number;*)
opt_ocaml_wrap_opt = !ocaml_wrap_opt;
opt_opa_wrap_opt = !opa_wrap_opt;
opt_native_parser = !native_parser;
opt_hlnet_logging = !hlnet_logging;
opt_protocol_version = !protocol_version;
opt_default_port = !default_port;
opt_default_addr = !default_addr;
opt_logger_function = !logger_function;
opt_create_functions = !create_functions;
opt_tojson_functions = !tojson_functions;
opt_fromjson_functions = !fromjson_functions;
opt_string_functions = !string_functions;
opt_bsl_file = !bsl_file;
opt_no_ocaml = !no_ocaml;
opt_no_opa = !no_opa;
opt_mns = !mns;
}
let restore_opts {
opt_debug;
opt_verbose;
opt_module_name;
opt_output_suffix;
opt_bsl_prefix;
(*opt_encoding_number;*)
opt_ocaml_wrap_opt;
opt_opa_wrap_opt;
opt_native_parser;
opt_hlnet_logging;
opt_protocol_version;
opt_default_port;
opt_default_addr;
opt_logger_function;
opt_create_functions;
opt_tojson_functions;
opt_fromjson_functions;
opt_string_functions;
opt_bsl_file;
opt_no_ocaml;
opt_no_opa;
opt_mns;
} =
debug := opt_debug;
verbose := opt_verbose;
module_name := opt_module_name;
output_suffix := opt_output_suffix;
bsl_prefix := opt_bsl_prefix;
(* bslmns := opt_bsl_prefix; *)
(*encoding_number := opt_encoding_number;*)
ocaml_wrap_opt := opt_ocaml_wrap_opt;
opa_wrap_opt := opt_opa_wrap_opt;
native_parser := opt_native_parser;
hlnet_logging := opt_hlnet_logging;
protocol_version := opt_protocol_version;
default_port := opt_default_port;
default_addr := opt_default_addr;
logger_function := opt_logger_function;
create_functions := opt_create_functions;
tojson_functions := opt_tojson_functions;
fromjson_functions := opt_fromjson_functions;
string_functions := opt_string_functions;
bsl_file := opt_bsl_file;
no_ocaml := opt_no_ocaml;
no_opa := opt_no_opa;
mns := opt_mns
let printf = Printf.printf
let eprintf = Printf.eprintf
let fprintf = Printf.fprintf
let sprintf = Printf.sprintf
let rec ll l = match l with | [] -> [] | [_] -> [] | h::t -> h::(ll t)
let lc1 s = let ss = String.copy s in ss.[0] <- (Char.lowercase ss.[0]); ss
let ispfx pfxs name = List.exists (fun pfx -> String.is_prefix pfx name) pfxs
let name_of_prefix prefixes str =
List.fold_left (fun name pfx -> if String.is_prefix pfx name then String.remove_prefix pfx name else name) str prefixes
let opt () = if !ocaml_wrap_opt then " option" else ""
let optS () = if !ocaml_wrap_opt then "Some " else ""
let fail () = if !ocaml_wrap_opt then "None" else "raise (Failure \"parse_error\")"
let string_of_idl = function
| PI.IDLType (name,type_expr,None) -> sprintf "IDLType (%s,%s)" name (Tools.str_of_type_expr type_expr)
| PI.IDLType (name,type_expr,Some s) -> sprintf "IDLType (%s,%s,\"%s\")" name (Tools.str_of_type_expr type_expr) s
| PI.IDLSar (name,sndtype,rcvtype) -> sprintf "IDLSar (%s,%s,%s)" name sndtype rcvtype
| PI.IDLLet expr -> sprintf "IDLLet %s" (Tools.str_of_expr expr)
(* Handlers for typenames:
* Complicated by the presence of external types which are encoded in
* the type name as: ["external";<name>;[<ocaml type name (list)>]]
*)
type tn = string list
type ext = (string * string) list
type exts = (string * ext) list
type tyexts = tn list * exts
let string_of_tyns tyns = String.concat ", " (List.map (fun itn -> (String.concat "." itn)) tyns)
let string_of_tynames tynames = "["^(string_of_tyns tynames)^"]"
let string_of_al ?(sep1="; ") ?(sep2="=>") vtos al =
String.concat sep1 (List.map (fun (k,v) -> sprintf "%s%s%s" k sep2 (vtos v)) al)
let string_of_exts = string_of_al (fun l -> "["^string_of_al (fun s -> s) l^"]")
let string_of_tyexts ((tyns,exts):tyexts) = sprintf "([%s],<%s>)" (string_of_tyns tyns) (string_of_exts exts)
let opa_tyn tn ((tyns,exts):tyexts) =
match tn with
| [tn] -> [tn]
| [mn;tn] -> [(lc1 mn);tn]
| "external"::_ -> failwith "external type expected for OPA type name"
| _ -> assert false
let str_of_tyn = function
| "external"::_::rest -> String.concat "." rest
| tyn -> String.concat "." tyn
let tyn_base = function
| [tn] -> tn
| [_; tn] -> tn
| "external"::t::_ -> t
| _ -> assert false
let cmp_tyn tn1 tn2 = tyn_base tn1 = tyn_base tn2
type tyntype =
ExternalTyn of (tn * ext)
| InternalTyn of tn
| UnknownTyn
let get_tyn tn ((tyns,exts):tyexts) =
let tnb = tyn_base tn in
match List.find_opt (fun (name,_) -> name = tnb) exts, List.find_opt (fun tyn -> cmp_tyn tn tyn) tyns with
| (Some (_,ext),Some tn) -> ExternalTyn (tn,ext)
| (None,Some tn) -> InternalTyn tn
| _ -> UnknownTyn
let var_of_tyn tyn = "__"^(tyn_base tyn)
(* Module naming routines.
* Centralised here because we have to be able to access all of these
* from all phases.
*)
let rmv_suffix from_suffix filename =
if Filename.check_suffix filename from_suffix
then Filename.chop_suffix filename from_suffix
else filename
let getbase filename from_suffix =
if !module_name = ""
then rmv_suffix from_suffix (Filename.basename filename)
else !module_name
let setsuffix filename prefix from_suffix to_suffix extension =
let d = Filename.dirname filename in
let base = getbase filename from_suffix in
Filename.concat d ((Tools.add_prefix ~force_split:true (Tools.add_suffix base to_suffix) prefix)^extension)
let modnamesuffix from_suffix filename = Tools.add_suffix ~force_split:true (getbase filename from_suffix) !output_suffix
let prefixmodname prefix from_suffix filename = Tools.add_prefix ~force_split:true (modnamesuffix from_suffix filename) prefix
let output_header oc filename intro cs ce =
let tim = Time.localtime (Time.now ()) in
fprintf oc "%s Translated from %s\n%s Date: %s %s\n %s\n\n%s %s %s\n\n%!"
cs filename (if ce = "" then cs else " *") (Date.date2 tim) (Date.time tim) ce cs intro ce
let brre = Str.regexp "\\([{}]\\)"
let toopastr = Str.global_replace brre "\\\\\\1"
(* Generate OCaml types *)
let type_ocaml_cte = function
| O.TypeString -> "string"
| O.TypeInt -> "int"
| O.TypeInt64 -> "int64"
| O.TypeFloat -> "float"
| O.TypeBool -> "bool"
| O.TypeUnit -> "unit"
let rec type_ocaml_te tyns = function
| O.TypeName ([te],["option"]) -> sprintf "(%s) option" (type_ocaml_te tyns te)
| O.TypeName ([te],["list"]) -> sprintf "(%s) list" (type_ocaml_te tyns te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(*eprintf "n: %s\n%!" n;
eprintf "tyns: %s\n%!" (string_of_tyexts tyns);*)
(match get_tyn tn tyns with
| InternalTyn tn
| ExternalTyn (tn,_) ->
if tes = []
then sprintf "%s" (str_of_tyn tn)
else sprintf "%s %s" (String.concat "," (List.map (type_ocaml_te tyns) tes)) (str_of_tyn tn)
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_ocaml_cte cte
| O.TypeTuple tes ->
let args = List.map (fun te -> type_ocaml_te tyns te) tes in
sprintf "%s" (String.concat " * " args)
| O.TypeRecord l ->
let els = List.map (fun (_,lab,te) -> sprintf "%s:%s" lab (type_ocaml_te tyns te)) l in
sprintf "{%s}" (String.concat "; " els)
| O.TypeConstructor cl ->
let cons = List.map (fun (name,teo) ->
match teo with
| Some te -> sprintf "%s of %s" name (type_ocaml_te tyns te)
| None -> sprintf "%s" name
) cl in
sprintf "%s" (String.concat " | " cons)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate OCaml types *)
(* Generate OPA types *)
let type_opa_cte = function
| O.TypeString -> "string"
| O.TypeInt -> "int"
| O.TypeInt64 -> "int64"
| O.TypeFloat -> "float"
| O.TypeBool -> "bool"
| O.TypeUnit -> "void"
let rec type_opa_te tyns = function
| O.TypeName ([te],["option"]) -> sprintf "option(%s)" (type_opa_te tyns te)
| O.TypeName ([te],["list"]) -> sprintf "list(%s)" (type_opa_te tyns te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(*eprintf "type_opa_te: TypeName(%s,%s)\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;*)
(match get_tyn tn tyns with
| InternalTyn [tn] ->
if tes = []
then sprintf "%s.%s" !mns tn
else sprintf "%s.%s(%s)" !mns tn (String.concat "," (List.map (type_opa_te tyns) tes))
| InternalTyn [mn;tn] ->
let on = str_of_tyn (opa_tyn [mn;tn] tyns) in
if tes = []
then sprintf "%s" on
else sprintf "%s(%s)" on (String.concat "," (List.map (type_opa_te tyns) tes))
| ExternalTyn (_,ext) ->
(try List.assoc "opatype" ext
with Not_found -> failwith (sprintf "No OPA type defined for external type %s" n))
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_opa_cte cte
| O.TypeTuple tes ->
let args = List.map (fun te -> type_opa_te tyns te) tes in
sprintf "(%s)" (String.concat "," args)
| O.TypeRecord l ->
let els = List.map (fun (_,lab,te) -> sprintf "%s:%s" lab (type_opa_te tyns te)) l in
sprintf "{%s}" (String.concat "; " els)
| O.TypeConstructor cl ->
let cons = List.map (fun (name,teo) ->
match teo with
| Some te -> sprintf "{%s:%s}" name (type_opa_te tyns te)
| None -> sprintf "{%s}" name
) cl in
sprintf "%s" (String.concat " / " cons)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate OPA types *)
(* Generate OPA arg types *)
let opa_arg_type_cte = function
| O.TypeString -> "opa[string]"
| O.TypeInt -> "opa[int]"
| O.TypeInt64 -> "opa[int]"
| O.TypeFloat -> "opa[float]"
| O.TypeBool -> "opa[bool]"
| O.TypeUnit -> "opa[void]"
let rec opa_arg_type_te name = function
| O.TypeConst cte -> opa_arg_type_cte cte
| _ -> sprintf "opa[%s_%s]" !mns name
(* End of Generate OPA arg types *)
(* Generate ServerLib types *)
let type_sl_cte = function
| O.TypeString -> "ServerLib.ty_string"
| O.TypeInt -> "ServerLib.ty_int"
| O.TypeInt64 -> "ServerLib.ty_int"
| O.TypeFloat -> "ServerLib.ty_float"
| O.TypeBool -> "ServerLib.ty_bool"
| O.TypeUnit -> "ServerLib.ty_void"
let rec type_sl_te tyns withmod = function
| O.TypeName ([te],["option"]) -> "ServerLib.ty_record"
| O.TypeName ([te],["list"]) -> "ServerLib.ty_record"
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn [tn] ->
let m = if withmod then (!_Mns)^"." else "" in
if tes = []
then sprintf "%ssl_%s" m tn
else sprintf "%ssl_%s(%s)" m tn (String.concat "," (List.map (type_sl_te tyns withmod) tes))
| InternalTyn [mn;tn] ->
let on = str_of_tyn (opa_tyn [mn;tn] tyns) in
if tes = []
then sprintf "sl_%s" on
else sprintf "sl_%s(%s)" on (String.concat "," (List.map (type_sl_te tyns withmod) tes))
| ExternalTyn (_,_) -> "ServerLib.ty_record"
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_sl_cte cte
| O.TypeTuple tes -> "ServerLib.ty_record"
| O.TypeRecord l -> "ServerLib.ty_record"
| O.TypeConstructor cl -> "ServerLib.ty_record"
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate ServerLib types *)
(* Encoding descriptor *)
type lang = {
make_some : string -> string;
make_none : string;
make_cons : string -> string option -> string;
map_list : string -> string -> string;
map_while_opt : string -> string -> string;
list_sep : string;
flush_str : encoding -> string -> string -> string;
output_s : encoding -> string -> string -> string -> string;
output_v : encoding -> string -> string -> string -> string -> string;
output_a : encoding -> string -> string -> string -> string;
output_f : encoding -> string -> string -> string -> string;
output_m : encoding -> string -> string -> string -> (string * (string -> string)) list -> string;
output_l : encoding -> string -> string -> string -> (string -> string -> string) -> (string -> string) -> string;
make_ext_fn : encoding -> tyexts -> tn -> string;
pat_tup : string list -> string;
tup_v : O.type_expr -> string;
pat_rec : encoding -> string list -> string list -> string;
pat_con0 : string -> string; pat_con1 : string -> string -> string;
error : string -> string;
mtch : encoding -> string -> (string * string) list -> string;
fnctn : encoding -> (string * string) list -> string;
app : encoding -> string -> string -> string;
}
(* TODO: use this... *)
(*and prepost = {
first_pre : encoding -> string;
pre : string;
make : string -> string;
void : string;
sep1 : string;
sep2 : string;
post : string;
last_post : string;
}*)
and enc = {
string_to_string : string*string;
int_to_string : string*string;
int64_to_string : string*string;
float_to_string : string*string;
bool_to_string : string*string;
unit_to_string : string*string;
option_pre : string; option_post : string;
list_pre : string; list_post : string;
tuple_pre : int -> string; tuple_post : string;
record_pre : encoding -> string; record_post : string;
cons_pre : string; cons_post : string;
con_pre : string; con_sep : string; con_post : string; make_con : string -> string;
rec_pre : string; rec_sep1 : string; rec_sep2 : string; rec_post : string; make_rec : string -> string; rec_void : string;
tup_pre : string; tup_sep1 : string; tup_sep2 : string; tup_post : string; make_tup : string -> string;
lst_pre : string; lst_sep1 : string; lst_sep2 : string; lst_post : string;
(*rcrd : prepost;*)
}
and prs = {
wrap_opt : bool ref;
succeed : encoding -> string -> string;
fail : encoding -> string -> string;
string_pat : string*string*string;
int_pat : string*string*string;
int64_pat : string*string*string;
float_pat : string*string*string;
bool_pat : string*string*string;
char_pat : string*string*string;
unit_pat : string*string*string;
opt_pat : string option -> string;
list_pat : string -> string;
tup_field : int -> string;
pre_tup : (encoding -> int -> string -> string) option;
tuple_pat : int -> string;
pre_rec : (encoding -> string -> string) option;
record_pat : string list -> string;
cons_pat : string -> string option -> (string option) * string;
input_v : encoding -> string * string * string -> string;
}
and encoding = {
(* Internal data structures *)
foldstrs : bool;
str : string ref;
modname : string;
(* Name prefix for generated functions *)
prefix : string;
(* Define host language constructs *)
lang : lang;
(* Define encoding *)
enc : enc;
(* Define input parser *)
prs : prs;
}
(* Generic support routines *)
let flush_str enc o t =
if enc.foldstrs && !(enc.str) <> ""
then
let t = enc.lang.flush_str enc o t in
enc.str := ""; t
else t
let make_ext enc o t tyexts tyn =
enc.lang.app enc (enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) (flush_str enc o t)) (var_of_tyn tyn)
let make_ext2 enc tyexts tyn t = enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) t
let make_ext3 enc o t tyexts tyn =
enc.lang.app enc (enc.lang.app enc o (flush_str enc o t))
(enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) (var_of_tyn tyn))
let make_ext4 enc tyexts tyn t =
enc.lang.app enc
(enc.lang.app enc "input_external" t)
(enc.lang.make_ext_fn enc tyexts tyn)
let make_ext5 enc o t tyexts tyn =
enc.lang.output_v enc (var_of_tyn tyn) o t (enc.lang.make_ext_fn enc tyexts tyn)
let output_br enc o t l r f a = enc.lang.output_s enc o (f (enc.lang.output_s enc o t l) a) r
let rec output_seq enc i o f sep t = function
| [] -> t
| [v] -> f i t v
| v::vs -> output_seq enc (i+1) o f sep (enc.lang.output_s enc o (f i t v) sep) vs
let make_tup enc name value _ =
sprintf "%s%s%s%s%s%s%s"
(enc.enc.tuple_pre 0) enc.enc.rec_pre (enc.enc.make_tup name) enc.enc.tup_sep1 value enc.enc.tup_post enc.enc.tuple_post
let make_tups enc nvs =
sprintf "%s%s%s"
(enc.enc.tuple_pre (List.length nvs))
(String.concat enc.enc.tup_sep2
(List.map (fun (name,value) ->
sprintf "%s%s%s%s%s" enc.enc.tup_pre (enc.enc.make_tup name) enc.enc.tup_sep1 value enc.enc.tup_post) nvs))
enc.enc.tuple_post
let make_rec enc name value _ =
sprintf "%s%s%s%s%s%s%s"
(enc.enc.record_pre enc) enc.enc.rec_pre (enc.enc.make_rec name) enc.enc.rec_sep1 value enc.enc.rec_post enc.enc.record_post
let make_recs enc nvs =
sprintf "%s%s%s"
(enc.enc.record_pre enc)
(String.concat enc.enc.rec_sep2
(List.map (fun (name,value) ->
sprintf "%s%s%s%s%s" enc.enc.rec_pre (enc.enc.make_rec name) enc.enc.rec_sep1 value enc.enc.rec_post) nvs))
enc.enc.record_post
let ocaml_input_pvs enc (p,v,s) =
if v = ""
then enc.lang.fnctn enc [(enc.lang.pat_con0 p,enc.prs.succeed enc s); ("_",enc.prs.fail enc p)]
else enc.lang.fnctn enc [(enc.lang.pat_con1 p v,enc.prs.succeed enc s); ("_",enc.prs.fail enc p)]
let ocaml_input_str enc (p,v,s) =
enc.lang.app enc p v
(* End of generic support routines *)
(* Wrappers for optional inputs *)
let wrap_opt_some enc res v =
let ro = enc.lang.app enc res v in
if !(enc.prs.wrap_opt)
then
enc.lang.mtch enc ro [
(enc.lang.make_some v, enc.lang.make_some (enc.lang.make_some v));
(enc.lang.make_none, enc.lang.make_none);
]
else enc.lang.make_some ro
let wrap_opt_none enc = if !(enc.prs.wrap_opt) then enc.lang.make_some enc.lang.make_none else enc.lang.make_none
let wrap_list enc res v = (if !(enc.prs.wrap_opt) then enc.lang.map_while_opt else enc.lang.map_list) res v
let wrap_tuple enc n ress =
if !(enc.prs.wrap_opt)
then
let vs = List.init n (fun i -> sprintf "__%d" i) in
let p = "("^String.concat ", " (List.map (fun v -> enc.lang.make_some v) vs)^")" in
let e = sprintf "(%s)" (String.concat ", " vs) in
enc.lang.mtch enc ress [
(p, enc.lang.make_some e);
("_", enc.lang.make_none);
]
else ress
let wrap_record enc names labs =
if !(enc.prs.wrap_opt)
then
let vs = List.map (fun l -> sprintf "__%s" l) names in
let p = sprintf "(%s)" (String.concat ", " (List.map (fun v -> enc.lang.make_some v) vs)) in
let e = sprintf "{%s}" (String.concat "; " (List.map (fun v -> sprintf "%s=__%s" v v) names)) in
enc.lang.mtch enc ("("^String.concat ",\n " labs^")") [
(p, enc.lang.make_some e);
("_", enc.lang.make_none);
]
else
sprintf "{%s}" (String.concat "; " (List.map2 (fun n l -> sprintf "%s=%s" n l) names labs))
let wrap_cons enc name reso =
if !(enc.prs.wrap_opt)
then
match reso with
| Some (te,res) ->
let v = enc.lang.tup_v te in
enc.lang.mtch enc res [(enc.lang.make_some v, enc.lang.make_some (enc.lang.make_cons name (Some v)));
("_", enc.lang.make_none);]
| None ->
enc.lang.make_some (enc.lang.make_cons name None)
else
enc.lang.make_cons name (Option.map snd reso)
(* End of wrappers for optional inputs *)
(* Abstract output *)
let tup_v = function
| O.TypeTuple ttes -> sprintf "(%s)" (String.concat "," (List.mapi (fun i _ -> sprintf "__v%d" i) ttes))
| _ -> "__v"
let abs_output_cte enc o t = function
| O.TypeString -> enc.lang.output_v enc (fst enc.enc.string_to_string) o t (snd enc.enc.string_to_string)
| O.TypeInt -> enc.lang.output_v enc (fst enc.enc.int_to_string) o t (snd enc.enc.int_to_string)
| O.TypeInt64 -> enc.lang.output_v enc (fst enc.enc.int64_to_string) o t (snd enc.enc.int64_to_string)
| O.TypeFloat -> enc.lang.output_v enc (fst enc.enc.float_to_string) o t (snd enc.enc.float_to_string)
| O.TypeBool -> enc.lang.output_v enc (fst enc.enc.bool_to_string) o t (snd enc.enc.bool_to_string)
| O.TypeUnit -> enc.lang.output_v enc (fst enc.enc.unit_to_string) o t (snd enc.enc.unit_to_string)
let rec abs_output_te enc o t tyns = function
| O.TypeName ([te],["option"]) ->
enc.lang.output_f enc o "__o"
(output_br enc o t enc.enc.option_pre enc.enc.option_post
(fun t te ->
enc.lang.output_m enc o t "__o"
[(enc.lang.make_some "__v",
(fun t ->
output_br enc o t (enc.enc.con_pre^(enc.enc.make_con "Some")^enc.enc.con_sep) enc.enc.con_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) "__v") te));
(enc.lang.make_none,
(fun t ->
enc.lang.output_s enc o t (enc.enc.con_pre^(enc.enc.make_con "None")^enc.enc.con_post)))]
) te)
| O.TypeName ([te],["list"]) ->
enc.lang.output_f enc o "__l"
(output_br enc o t enc.enc.list_pre enc.enc.list_post
(fun t te -> enc.lang.output_l enc o t "__l"
(fun t h ->
output_br enc o t enc.enc.lst_pre enc.enc.lst_post
(fun t te -> enc.lang.output_a enc o (abs_output_te enc o t tyns te) h)
te)
(fun t -> enc.lang.output_s enc o t enc.enc.lst_sep1)
) te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
enc.lang.output_f enc o (var_of_tyn tn) (make_ext enc o t tyns tn)
| ExternalTyn (tn,_) ->
(*enc.lang.output_f enc o (var_of_tyn tn)*) (make_ext5 enc o t tyns tn)
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_output_cte enc o t cte
| O.TypeTuple tes ->
let args = List.mapi (fun i _te -> sprintf "__%d" i) tes in
enc.lang.output_f enc o (enc.lang.pat_tup args)
(output_br enc o t (enc.enc.tuple_pre (List.length tes)) enc.enc.tuple_post
(fun t te ->
output_seq enc 0 o
(fun i t te ->
output_br enc o t enc.enc.tup_pre enc.enc.tup_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) (sprintf "__%d" i)) te)
enc.enc.tup_sep1 t tes) tes)
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
enc.lang.output_f enc o (enc.lang.pat_rec enc labs labs)
(output_br enc o t (enc.enc.record_pre enc) enc.enc.record_post
(fun t l ->
output_seq enc 0 o
(fun _ t (_,lab,te) ->
output_br enc o t (sprintf "%s%s%s" enc.enc.rec_pre (enc.enc.make_rec lab) enc.enc.rec_sep1)
enc.enc.rec_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) lab) te) enc.enc.rec_sep2 t l) l)
| O.TypeConstructor cl ->
enc.lang.output_f enc o "__c"
(output_br enc o t enc.enc.cons_pre enc.enc.cons_post
(fun t cl ->
enc.lang.output_m enc o t "__c" (
List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
(enc.lang.pat_con1 name v,
(fun t ->
output_br enc o t (sprintf "%s%s%s" enc.enc.con_pre (enc.enc.make_con name) enc.enc.con_sep)
enc.enc.con_post
(fun t te -> enc.lang.output_a enc o (abs_output_te enc o t tyns te) v) te))
| None ->
(enc.lang.pat_con0 name,(fun t ->
enc.lang.output_s enc o t (sprintf "%s%s%s" enc.enc.con_pre (enc.enc.make_con name)
enc.enc.con_post)))
) cl
)
) cl)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Abstract output *)
(* Abstract input2 *)
let abs_input2_cte enc = function
| O.TypeString -> enc.prs.input_v enc enc.prs.string_pat
| O.TypeInt -> enc.prs.input_v enc enc.prs.int_pat
| O.TypeInt64 -> enc.prs.input_v enc enc.prs.int64_pat
| O.TypeFloat -> enc.prs.input_v enc enc.prs.float_pat
| O.TypeBool -> enc.prs.input_v enc enc.prs.bool_pat
| O.TypeUnit -> enc.prs.input_v enc enc.prs.unit_pat
let input_fix enc str success =
if str = ""
then success
else sprintf "if input_fixed t \"%s\" then %s else %s" str success (enc.prs.fail enc str)
let make_list enc l = "["^String.concat enc.lang.list_sep l^"]"
let quote s = "\""^s^"\""
let input_rec enc recs =
let strs = List.map (fun (s,c) -> quote s) recs in
enc.lang.mtch enc
(enc.lang.app enc (enc.lang.app enc "input_fixeds" "t") (make_list enc strs))
((List.map (fun (s,c) -> (enc.lang.make_some (quote s),c)) recs)@[("_",enc.prs.fail enc (String.concat "," strs))])
let input_m enc v m s =
if !(enc.prs.wrap_opt)
then enc.lang.mtch enc m [((enc.lang.make_some v),s); ("_",enc.prs.fail enc m)]
else enc.lang.mtch enc m [(v,s)]
let input_seq enc pre sep post es output =
input_fix enc pre
(let rec aux l = function
| [] -> input_fix enc post (output (List.rev l))
| (v,e)::[] -> input_m enc v e (input_fix enc post (output (List.rev (v::l))))
| (v,e)::rest -> input_m enc v e (input_fix enc sep (aux (v::l) rest))
in
aux [] es)
let apps enc fs =
let rec aux = function
| [] -> assert false
| [a] -> a
| f::a::rest -> aux ((enc.lang.app enc f a)::rest)
in
aux fs
let rec abs_input2_te enc tyns = function
| O.TypeName ([te],["option"]) ->
input_fix enc enc.enc.option_pre
(input_fix enc enc.enc.con_pre
(input_rec enc
[(enc.enc.make_con "Some",
(input_fix enc enc.enc.con_sep
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.option_post
(enc.prs.succeed enc (enc.lang.make_some "__v")))))));
(enc.enc.make_con "None",
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.option_post (enc.prs.succeed enc enc.lang.make_none))))]))
| O.TypeName ([te],["list"]) ->
apps enc ["input_list"; (quote enc.enc.list_pre); (quote enc.enc.lst_sep1); (quote enc.enc.list_post);
(enc.lang.fnctn enc [("t",
(input_fix enc enc.enc.lst_pre
(if enc.enc.lst_post = ""
then (input_fix enc enc.enc.lst_pre
(abs_input2_te enc tyns te))
else (input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.lst_post
(enc.prs.succeed enc "__v"))))))]); "t"]
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
make_ext2 enc tyns tn "t"
| ExternalTyn (tn,_) ->
make_ext4 enc tyns tn "t"
| _ -> (eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_input2_cte enc cte
| O.TypeTuple tes ->
let es = List.mapi (fun i te ->
let arg = sprintf "__%d" i in
arg,
(input_fix enc enc.enc.tup_pre
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.tup_post
(enc.prs.succeed enc "__v"))))) tes in
input_seq enc (enc.enc.tuple_pre (List.length tes)) enc.enc.tup_sep1 enc.enc.tuple_post
es (fun s -> enc.prs.succeed enc (String.concat ", " s))
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
let es = List.map (fun (_,lab,te) ->
"__"^lab,
(input_fix enc enc.enc.rec_pre
(input_fix enc (enc.enc.make_con lab)
(input_fix enc enc.enc.rec_sep1
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.rec_post
(enc.prs.succeed enc "__v"))))))) l in
input_seq enc (enc.enc.record_pre enc) enc.enc.rec_sep2 enc.enc.record_post es
(fun ls -> enc.prs.succeed enc (enc.lang.pat_rec enc labs ls))
| O.TypeConstructor cl ->
input_fix enc enc.enc.cons_pre
(input_fix enc enc.enc.con_pre
(input_rec enc
(List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
((enc.enc.make_con name),
(input_fix enc enc.enc.con_sep
(input_m enc v (abs_input2_te enc tyns te)
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.cons_post
(enc.prs.succeed enc (enc.lang.make_cons name (Some v))))))))
| None ->
((enc.enc.make_con name),
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.cons_post (enc.prs.succeed enc (enc.lang.make_cons name None)))))) cl)))
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Abstract input2 *)
(* Abstract json output *)
(* Note: we only use Record and List here. *)
(* Note: we ignore the "o" and "t" parameters but we keep the same encoding function signatures. *)
let match_record enc v pes =
match pes, enc.prs.pre_rec with
| (pes, Some pr) -> enc.lang.output_f enc "" v (enc.lang.mtch enc (pr enc v) (pes@[("_",enc.lang.error "match_record")]))
| ([p,e], None) -> enc.lang.output_f enc "" p e
| (_, _) -> assert false
let match_tuple enc i v p e =
match enc.prs.pre_tup with
| Some pr -> enc.lang.output_f enc "" v (enc.lang.mtch enc (pr enc i v) [(p,e); ("_",enc.lang.error "match_tuple")])
| None -> enc.lang.output_f enc "" p e
let rec abs_tojson_te enc tyns = function
| O.TypeName ([te],["option"]) ->
enc.lang.output_m enc "" "" "__t"
[(enc.lang.make_some "__v", (make_rec enc "Some" (enc.lang.output_a enc "" (abs_tojson_te enc tyns te) "__v")));
(enc.lang.make_none, (make_rec enc "None" enc.enc.rec_void)); ]
| O.TypeName ([te],["list"]) ->
enc.lang.output_l enc "" "" "__l" (fun h _ -> enc.lang.output_a enc "" (abs_tojson_te enc tyns te) h) (fun x -> x)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn | ExternalTyn (tn,_) ->
enc.lang.output_f enc "" (var_of_tyn tn) (make_ext2 enc tyns tn (var_of_tyn tn))
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_output_cte enc "" "" cte
| O.TypeTuple tes ->
let args = List.mapi (fun i _te -> enc.prs.tup_field i) tes in
let nvs = List.mapi (fun i te -> (enc.prs.tup_field i,
sprintf "(%s(%s))" (abs_tojson_te enc tyns te) (enc.prs.tup_field i))) tes in (*FIXME!!!*)
enc.lang.output_f enc "" (enc.lang.pat_tup args) (make_tups enc nvs)
(*match_tuple enc (List.length tes) "__t" (enc.lang.pat_tup args) (make_tups enc nvs)*)
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
let nvs = List.map (fun (_,lab,te) -> lab, sprintf "(%s(%s))" (abs_tojson_te enc tyns te) lab) l in
enc.lang.output_f enc "" "__r" (enc.lang.mtch enc "__r" [(enc.lang.pat_rec enc labs labs),(make_recs enc nvs)])
(*match_record enc "__r" [(enc.lang.pat_rec enc labs labs),(make_recs enc nvs)]*)
| O.TypeConstructor cl ->
enc.lang.output_m enc "" "" "__t"
(List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
(enc.lang.pat_con1 name v,
(make_rec enc name (enc.lang.output_a enc "" (abs_tojson_te enc tyns te) v)))
| None ->
(enc.lang.pat_con0 name,
(make_rec enc name enc.enc.rec_void))) cl)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of abstract json output *)
(* Concrete wrap/unwrap output/input *)
let rec abs_un_wrap_te enc tyns = function
| O.TypeName ([te],["option"]) ->
(match enc.prefix with
| "wrap" -> sprintf "(fun __o -> wrap_opt %s __o)" (abs_un_wrap_te enc tyns te)
| "unwrap" -> sprintf "(fun __o -> (match unwrap_rcrd __o with [(\"some\",__v)] -> Some (%s __v) | [(\"none\",_)] -> None | _ -> raise (Failure \"match_option\")))" (abs_un_wrap_te enc tyns te)
| _ -> assert false)
| O.TypeName ([te],["list"]) ->
(match enc.prefix with
| "wrap" -> sprintf "(fun __l -> wrap_lst %s __l)" (abs_un_wrap_te enc tyns te)
| "unwrap" -> sprintf "(fun __l -> (match unwrap_lst %s __l with Some __l -> __l | _ -> raise (Failure \"match_list\")))"
(abs_un_wrap_te enc tyns te)
| _ -> assert false)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
enc.lang.output_f enc "" (var_of_tyn tn) (make_ext2 enc tyns tn (var_of_tyn tn))