-
Notifications
You must be signed in to change notification settings - Fork 125
/
dbGenHelpers.ml
807 lines (649 loc) · 28.7 KB
/
dbGenHelpers.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
(*
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/>.
*)
(*
@author Louis Gesbert
**)
(* This file uses bindings from BSL: to make sense, it uses the files:
libqml.git/libqmlcompil/dbGen/dbGenByPass.ml (interface & impl for BSL)
libqml.git/libbsl/mlbsl/dbgenlink.ml
Don't forget to also check out the backwards-compatibility hack in
qml2llvm.git/qml/qmlCommonCompiler.ml
*)
(* shorthands *)
module Q = QmlAst
(* Bypasses from Opacapi *)
module Badoplink = Opacapi.Opabsl.Badoplink
module BadopEngine = Opacapi.Opabsl.BadopEngine
module BslNativeLib = Opacapi.Opabsl.BslNativeLib
module Transactions = Opacapi.Opabsl.Transactions
module Path = Opacapi.Opabsl.Path
module Dbgraph = Opacapi.Opabsl.Dbgraph
#<Debugvar:DBGEN_DEBUG>
let warn fmt = OManager.warning ~wclass:WarningClass.dbgen fmt
let verb fmt = OManager.verbose ("DbGenHelpers: "^^fmt)
(* DbGen uses two imperative structures defined here. One annot-table for
typing, with only add and get operations, and a read-only reference to
the external env used to obtain the ValInitial *)
let current_built_pos = ref (None : FilePos.pos option)
let start_built_pos p = current_built_pos := Some p
let end_built_pos () = current_built_pos := None
(* Local imperative annotmap. *)
module AnnotTable =
struct
let dummy = ref false
let is_open = ref false
let annots_base = (ref QmlAnnotMap.empty: Q.annotmap ref)
module AnTbl = QmlAnnotMap.Ref.Make (struct
type ty = Q.ty
type bonus = unit
let _global = ref QmlAnnotMap.empty
end)
let open_table ?(annotmap=None) ?silent:(_silent=false) () =
if !is_open then failwith "DbGen internal: re-opening annot table"
else
(is_open := true;
assert (QmlAnnotMap.is_empty !annots_base);
assert (QmlAnnotMap.is_empty (AnTbl.export ()));
match annotmap with
| None ->
#<If> if not _silent then verb "Entering DbGen in typing off mode" #<End>;
dummy := true
| Some annotmap ->
#<If> if not _silent then verb "Entering DbGen, annotmap size @{<bright>%d@}" (QmlAnnotMap.size annotmap) #<End>;
annots_base := annotmap;
dummy := false)
let getTypeOfAnnot a =
assert !is_open;
if !dummy then Q.typeNull else
match AnTbl.get_ty_opt a with
| Some ty -> ty
| None -> match QmlAnnotMap.find_ty_opt a !annots_base with
| Some ty -> ty
| None -> warn "Error: annot not found in DbGen, and typing wasn't disabled"; assert false
(* Q.typeNull *)
let newAnnot ty =
assert !is_open;
let a = Annot.next () in
if !dummy then a else (AnTbl.set_ty a ty; a)
let close_table ?silent:(_silent=false) () =
assert !is_open;
let annotmap = if !dummy then None else Some (AnTbl.export ()) in
#<If>
if not _silent then (match annotmap with
| None -> verb "DbGen in typer-off mode, not returning any annotmap"
| Some a -> verb "DbGen: closing annot table with size @{<bright>%d@}" (QmlAnnotMap.size a))
#<End>;
AnTbl.clear ();
annots_base := QmlAnnotMap.empty;
is_open := false;
annotmap
let emergency_close () = (* use in case of error *)
AnTbl.clear ();
annots_base := QmlAnnotMap.empty;
is_open := false
end
(* ------- AST building helper functions -------- *)
let equalsty ty1 ty2 =
ty1 = Q.typeNull || ty2 = Q.typeNull || Q.EqualsTy.equal ty1 ty2
let new_ident =
#<If:DBGEN_FLAGS$flag "source">
let x = ref 0 in
fun n -> incr x; Ident.source ("__db_internal__" ^ string_of_int !x ^ "__" ^ n)
#<Else>
fun n -> Ident.next n (* because OCaml is stupid *)
#<End>
let newexpr_annot_nocoerce e t =
let annot = AnnotTable.newAnnot t in
QmlAst.QAnnot.New.expr e annot
(* activate for full-coerce of generated code, useful to pinpoint typing errors *)
let newexpr_annot e ty =
#<If:DBGEN_FLAGS$flag "fullcoerce">
let label = QmlAst.Label.expr e in
newexpr_annot_nocoerce (Q.Coerce (label, newexpr_annot_nocoerce e ty, ty)) ty
#<Else>
newexpr_annot_nocoerce e ty
#<End>
let newpatt_annot p t =
let annot = AnnotTable.newAnnot t in
QmlAst.QAnnot.New.pat p annot
let id_expr id ty =
let label = Annot.nolabel "dbgen" in
newexpr_annot (Q.Ident (label, id)) ty
let (@:) = id_expr
let copy_expr e =
if !AnnotTable.dummy then e else
let fresh_expr_annots e =
let annot = AnnotTable.newAnnot (AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr e)) in
QmlAst.QAnnot.New.expr e annot
in
let fresh_pat_annots e =
let annot = AnnotTable.newAnnot (AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.pat e)) in
QmlAst.QAnnot.New.pat e annot
in QmlAstWalk.ExprPatt.map_down fresh_expr_annots fresh_pat_annots e
(* Assumes the expr is alpha-converted *)
let is_id_free_in_expr id e =
(*
FIXME: this looks like an exists
*)
try QmlAstWalk.Expr.iter_up (
function
| Q.Ident (_, id') -> if id = id' then raise Exit
| _ -> ()
) e; true
with Exit -> false
let are_ids_free_in_expr ids e =
(*
FIXME: this looks like an exists
*)
try
QmlAstWalk.Expr.iter_up
(function
| Q.Ident (_, id) -> if List.mem id ids then raise Exit
| _ -> ())
e ;
true
with Exit -> false
let tyunit = Q.TypeRecord (Q.TyRow ([], None))
let tyint = Q.TypeConst Q.TyInt
let tystring = Q.TypeConst Q.TyString
let tyfloat = Q.TypeConst Q.TyFloat
let tybool = tyint (* C-style: <> 0 is true *)
let args_ret l =
let rec aux acc = function
| [] -> assert false (* wrong construction of static args passed to tyfun *)
| [ret] -> List.rev acc, ret
| arg::tl -> aux (arg::acc) tl
in aux [] l
let tyfun l =
let args, ret = args_ret l in
Q.TypeArrow (args, ret)
let tylist ty = Q.TypeName ([ty], Q.TypeIdent.of_string Opacapi.Types.list)
let tycaml_list ty = Q.TypeName ([ty], Q.TypeIdent.of_string Opacapi.Types.caml_list)
let tycont ty = Q.TypeName ([ty], Q.TypeIdent.of_string Opacapi.Types.continuation)
let tyfun_cps_firstclass l =
match List.rev l with
| retty::args -> Q.TypeArrow (( List.rev args @ [tycont retty] ), tyunit)
| [] -> assert false
let typemap ty ty' =
if ty = Q.typeNull || ty' = Q.typeNull then Q.typeNull
else Q.TypeName ([ty;ty'], Q.TypeIdent.of_string Opacapi.Types.map)
let typeoption ty =
if ty = Q.typeNull then Q.typeNull
else Q.TypeName ([ty], Q.TypeIdent.of_string Opacapi.Types.option)
let typevirtualhandler realty rty wty =
let rty = Q.TypeArrow ([realty], rty) in
let wty = Q.TypeArrow ([wty], realty) in
Q.TypeRecord (Q.TyRow ([("read", rty);("write", wty)], None))
let type_from_annot e = AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr e)
let type_from_pat_annot e = AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.pat e)
let type_inside_option e = match type_from_annot e with
| Q.TypeName ([ty], id_option) when Q.TypeIdent.to_string id_option = "option" -> ty
| ty when ty = Q.typeNull -> Q.typeNull
| _ -> assert false
(* FIXME: is there a way to share with QmlAstCons ? *)
let make_lambda' par_ty_list body =
let params, typarams = Base.List.split par_ty_list in
let ty = Q.TypeArrow (typarams, AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr body)) in
let label = QmlAst.Label.expr body in
newexpr_annot (Q.Lambda (label, params, body)) ty
let make_lambda par_ty = make_lambda' [par_ty]
let apply_lambda' lambda params =
let params_len = List.length params in
match type_from_annot lambda with
| (Q.TypeArrow (typarams, tyret)) as ty ->
let arity = List.length typarams in
(if arity <> params_len then
let context = QmlError.Context.expr (QmlAstCons.UntypedExpr.apply lambda params) in
QmlError.i_error None context (
"DbGen: trying to apply an arrow type of arity %d on %d parameter(s)"^^
"Type of the fct is : %a@\n"
)
arity params_len
QmlPrint.pp#ty ty
);
(* assert (List.fold_left2 -- we need a gamma in equalsty for this *)
(* (fun ok param ty -> ok && *)
(* (equalsty (AnnotTable.getTypeOfAnnot param.Q.annot) ty || (Format.eprintf "Unification failed: [1m%a[24m vs [1m%a[24m\n" QmlPrint.pp#ty (AnnotTable.getTypeOfAnnot param.Q.annot) QmlPrint.pp#ty ty; false))) *)
(* true params typarams); *)
let label = QmlAst.Label.expr lambda in
newexpr_annot (Q.Apply (label, lambda, params)) tyret
| ty when ty = Q.typeNull ->
let label = QmlAst.Label.expr lambda in
newexpr_annot (Q.Apply (label, lambda, params)) Q.typeNull
| ty ->
let context = QmlError.Context.expr (QmlAstCons.UntypedExpr.apply lambda params) in
QmlError.i_error None context (
"DbGen: trying to apply non-arrow type %a"
)
QmlPrint.pp#ty ty
let apply_lambda lambda e = apply_lambda' lambda [e]
let make_letand defs in_e =
let label = QmlAst.Label.expr in_e in
newexpr_annot (Q.LetIn (label, defs, in_e)) (AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr in_e))
let make_letin (id, e1) e2 =
match e1 with
| Q.Ident (_, id1) when id1 = id -> e2
| Q.Ident (_, id1) when is_id_free_in_expr id1 e2 ->
QmlAstWalk.Expr.map_up (
function
| Q.Ident (label, i) when i = id -> Q.Ident (label, id1)
| e -> e
)
e2
(* isn't that a bit dangerous ? *)
| _ -> make_letand [id,e1] e2
let make_letin' id_e_lst e =
List.fold_right (fun id_e e -> make_letin id_e e) id_e_lst e
(* newexpr_annot (Q.LetIn (id_e_lst,e)) (AnnotTable.getTypeOfAnnot e.Q.annot) -- we want letin, not letand *)
let make_coerce ?ty e =
let ty = match ty with
| Some ty -> ty
| None -> AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr e) in
(* assert (ty = None || Some ty' = ty || (jlog (PrettyPrint.string_of_ty (let Some tyx = ty in tyx) ^ "~=~" ^ PrettyPrint.string_of_ty ty'); false)); -- sometimes we want to coerce to a slightly different type *)
if ty = Q.typeNull then e
else match e with
| Q.Coerce (_, _e0, ty0) when ty0 = ty -> e
| _ ->
let label = QmlAst.Label.expr e in
newexpr_annot_nocoerce (Q.Coerce (label, e, ty)) ty
let make_match e matchcaselist =
let tye = type_from_annot e in
let tylst = List.map (fun mc -> type_from_pat_annot (fst mc), type_from_annot (snd mc)) matchcaselist
in
let ty = snd (List.hd tylst) in
(* assert (snd (List.fold_left (fun (ty0,s) ty -> *)
(* Base.jlog (QmlPrint.ty (snd ty0) ^ "~=~" ^ QmlPrint.ty (snd ty)); *)
(* ty0,s && (equalsty (snd ty0) (snd ty))) (List.hd tylst, true) (List.tl tylst))); *)
(* **doesn't work properly on named types** *)
let label = QmlAst.Label.expr e in
newexpr_annot
(Q.Match (label, make_coerce ~ty:tye e, matchcaselist))
ty
let tyrecord ?(extend=false) lst = Q.TypeRecord (QmlAstCons.Type.Row.make ~extend lst)
let tytuple t1 t2 = tyrecord [ "f1", t1; "f2", t2]
let make_record lst =
let tyl = List.map (fun (fld,e) -> fld, type_from_annot e) lst in
let label = Annot.nolabel "dbgen.make_record" in
newexpr_annot (Q.Record (label, lst)) (tyrecord tyl)
let make_tuple e1 e2 =
make_record ["f1",e1; "f2",e2]
let make_dot ?ty record fld =
let ty = match ty with
| Some ty -> ty
| None -> match type_from_annot record with
| Q.TypeRecord row ->
(match QmlAstWalk.Row.get_field fld row with
| Some ty -> ty
| None -> assert false)
| Q.TypeConst Q.TyNull -> Q.typeNull
| _ -> assert false
in
let label = Annot.nolabel "dbgen.make_dot" in
newexpr_annot (Q.Dot (label, record, fld)) ty
let make_fst tuple = make_dot tuple "f1"
let make_snd tuple = make_dot tuple "f2"
let over_valpath_ty ty =
ty
let callcc e ty =
let label = QmlAst.Label.expr e in
newexpr_annot (Q.Directive (label, `callcc, [e], [])) ty
let make_lazyrecord param fldmap ty =
let pos = FilePos.nopos "make_lazyrecord" in
#<If:DBGEN_FLAGS$flag "nolazy">
let label = Annot.next_label pos in
make_coerce (newexpr_annot (Q.Record (label, fldmap)) ty)
#<Else>
let ret_ty = over_valpath_ty ty in
newexpr_annot
(Q.Directive
(
Annot.next_label pos,
`create_lazy_record,
[(newexpr_annot_nocoerce (Q.Record (Annot.next_label pos, fldmap)) ty);param],
[]
)
)
ret_ty
#<End>
(* useful for converting one case of a sum type to the more general sum type (eg {hd;tl} to list) *)
let expand_record ?(lazy_param=None) id tyrec tysum =
let pos = FilePos.nopos "dbgen.expand_record" in
match tyrec with
| Q.TypeRecord row ->
let fldmap =
QmlAstWalk.Row.fold_right
(fun f tyfld acc -> (f, newexpr_annot (Q.Dot (Annot.next_label pos, id @: tyrec, f)) tyfld) :: acc)
row [] in
(match lazy_param with
| Some param -> make_lazyrecord param fldmap tysum
| None -> newexpr_annot (Q.Record (Annot.next_label pos, fldmap)) tysum)
| _ -> id @: tysum
(* Only needed because of gramp's backend *)
let convert_case_to_sum ?(lazy_param=None) tysum e =
let var = new_ident "res" in
make_letin (var, e)
(make_coerce
(expand_record ~lazy_param var (AnnotTable.getTypeOfAnnot (QmlAst.QAnnot.expr e)) tysum))
let freshid = let z = ref 0 in fun () -> let a = !z in incr z; "dbpathid_" ^ string_of_int a
(*
This is the default (position + dummy annot)
for generated ast. In case we use newexpr_annot,
the annot is refreshed, and we can share the label
used to initialize the construction.
*)
let nolabel = Annot.nolabel "dbgen"
let expr_unit () = newexpr_annot (Q.Record (nolabel, [])) tyunit
let patt_unit () = newpatt_annot (Q.PatRecord (nolabel, [], `closed)) tyunit
let const_int i = newexpr_annot (Q.Const (nolabel, (Q.Int i))) tyint
let patt_const_int i = newpatt_annot (Q.PatConst (nolabel, (Q.Int i))) tyint
let const_string s = newexpr_annot (Q.Const (nolabel, (Q.String s))) tystring
let patt_const_string s = newpatt_annot (Q.PatConst (nolabel, (Q.String s))) tystring
let expr_true () = const_int 1
let expr_false () = const_int 0
let expr_and x y = match x, y with
| Q.Const (_, (Q.Int i)), z
| z, Q.Const (_, (Q.Int i)) -> if i <> 0 then z else expr_false ()
| _ -> make_match x [patt_const_int 0, expr_false(); newpatt_annot (Q.PatAny nolabel) tybool, y]
let make_ifthenelse x ethen eelse = match x with
| Q.Const (_, Q.Int i) -> if i <> 0 then ethen else eelse
| _ -> make_match x [patt_const_int 0, eelse; newpatt_annot (Q.PatAny nolabel) tybool, ethen]
let make_list l ty =
let make_nil () = newexpr_annot (Q.Record (nolabel, [("nil",expr_unit())])) (tylist ty) in
let make_hdtl hd tl = newexpr_annot (Q.Record (nolabel, [("hd",hd);("tl",tl)])) (tylist ty) in
let rec make_list l =
match l with
| [] -> make_nil()
| hd::tl -> make_hdtl hd (make_list tl)
in
make_list l
let patt_emptyrec () =
newpatt_annot
(Q.PatRecord (nolabel, [], `closed))
(Q.TypeRecord (QmlAstCons.Type.Row.make ~extend:false []))
let patt_some p =
newpatt_annot
(Q.PatRecord (nolabel, ["some", p], `closed))
(typeoption (type_from_pat_annot p))
let patt_some_var id ty =
patt_some (newpatt_annot (Q.PatVar (nolabel, id)) ty)
let patt_none ty =
newpatt_annot
(Q.PatRecord (nolabel, ["none", patt_unit()], `closed))
(typeoption ty)
let patt_none_p p =
patt_none (type_from_annot p)
module Helpers_gen = functor ( Arg: DbGenByPass.S ) ->
struct
let valinitial_env_ref = ref Arg.ValInitial.empty
(* Should correspond to stg defined in initial *)
(* These are the only code called from qml within ocaml *)
(* let expr_none ty = make_coerce (id_expr (Arg.ValInitial.none !valinitial_env_ref) (typeoption ty)) *)
(* let expr_none _ty = make_record ["none", expr_unit()] *)
let expr_none ty = newexpr_annot (QmlAst.Record (nolabel, ["none", expr_unit()])) (typeoption ty)
let id_some () = Arg.ValInitial.some !valinitial_env_ref
let expr_some ty = id_expr (Arg.ValInitial.some !valinitial_env_ref) (tyfun [ty; typeoption ty])
let expr_dbset_empty ty =
id_expr (Arg.ValInitial.dbset_empty !valinitial_env_ref) ty
let expr_intmap_empty ty =
id_expr (Arg.ValInitial.intmap_empty !valinitial_env_ref) ty
let expr_stringmap_empty ty =
id_expr (Arg.ValInitial.stringmap_empty !valinitial_env_ref) ty
let expr_intmap_add ty ty' =
id_expr (Arg.ValInitial.intmap_add !valinitial_env_ref)
(tyfun [ty; ty'; typemap ty ty'; typemap ty ty'])
let expr_stringmap_add ty ty' =
id_expr (Arg.ValInitial.stringmap_add !valinitial_env_ref)
(tyfun [ty; ty'; typemap ty ty'; typemap ty ty'])
let expr_intmap_fold ty ty' tyacc =
id_expr (Arg.ValInitial.intmap_fold !valinitial_env_ref)
(tyfun [tyfun [ty;ty';tyacc;tyacc]; typemap ty ty'; tyacc; tyacc])
let expr_stringmap_fold ty ty' tyacc =
id_expr (Arg.ValInitial.stringmap_fold !valinitial_env_ref)
(tyfun [tyfun [ty;ty';tyacc;tyacc]; typemap ty ty'; tyacc; tyacc])
let expr_make_virtual_val real_ty vread_ty =
id_expr (Arg.ValInitial.make_virtual_val !valinitial_env_ref)
(tyfun [DbGen_common.val_path_ty real_ty; tyfun [real_ty; vread_ty]; DbGen_common.virtual_val_path_ty vread_ty])
let expr_make_virtual_ref real_ty vread_ty vwrite_ty =
id_expr (Arg.ValInitial.make_virtual_ref !valinitial_env_ref)
(tyfun [DbGen_common.ref_path_ty real_ty;
tyfun [real_ty; vread_ty];
tyfun [vwrite_ty; real_ty];
DbGen_common.virtual_ref_path_ty vread_ty vwrite_ty])
let expr_val_to_val ty =
let tydb3path = DbGen_common.ref_path_ty ty in
id_expr (Arg.ValInitial.val_to_val !valinitial_env_ref)
(tyfun [tydb3path; DbGen_common.Db.val_path_ty ty])
let expr_ref_to_ref ty =
let tydb3path = DbGen_common.ref_path_ty ty in
id_expr (Arg.ValInitial.ref_to_ref !valinitial_env_ref)
(tyfun [tydb3path; DbGen_common.Db.ref_path_ty ty])
let expr_write ty =
id_expr (Arg.ValInitial.write !valinitial_env_ref)
(tyfun [DbGen_common.ref_path_ty ty; ty; tyunit])
(* Also used above: type-identifier option and field labels "some", "none" *)
(*let ti ?(modul="badoplink") ?(param=[]) s =
Q.TypeName (param, Q.TypeIdent.of_string*)
let ti ?(param=[]) s () =
Q.TypeName (param, DbGen_common.typ s)
(* These type idents are defined in the mlBSL. Do they need type_of_type ? *)
(* beware, there is also the types from mlbsl/path.ml in DbGen_common (since
they may be used by Schema) *)
let typath = ti Opacapi.Types.badoplink_path
let tytrans = ti Opacapi.Types.badoplink_transaction
let tydbset ty =
ti ~param:[ty] Opacapi.Types.dbset ()
let tykey = ti Opacapi.Types.badoplink_db_path_key
let typartialkey = ti Opacapi.Types.badoplink_db_partial_key
let tydata = ti Opacapi.Types.badoplink_data_d
let tyhltrans ty =
ti ~param:[ty] Opacapi.Types.transactions_t ()
let tydiff = ti Opacapi.Types.dbgraph_diff
let ty_lazy_data = ti Opacapi.Types.path_embed_info
let tyobj = ti Opacapi.Types.path_embedded_obj
let tyengine = ti Opacapi.Types.badop_engine_t
let tyoptions = ti Opacapi.Types.badop_engine_database_options
let tynodeconfig = ti Opacapi.Types.badoplink_node_config
module Bypass = struct
(** All bypasses used by dbGen are linked here and defined in one of
dbgenlink.ml, transactions.ml, path.ml. The types given here are not
checked directly (but indirectly with option retype_dbgen) *)
(** returns an expr from a bypass key and its type *)
let expr key ty =
let dbgen_id = "dbgen" in
let bypass = newexpr_annot_nocoerce (Q.Bypass (nolabel, key)) ty in
newexpr_annot
(Q.Directive(nolabel, `restricted_bypass dbgen_id, [bypass], [])) ty
(** A non-cps bypass function with its arrow-type as list *)
let func s tyl =
expr s (tyfun tyl)
(** -- Bypasses from mlbsl/dbgenlink --*)
let jlog() = func (Badoplink.jlog) [tystring;tyunit]
let fatal_error ty =
func (Badoplink.fatal_error) [tystring;tystring;tystring;ty]
let error ty =
func (Badoplink.error) [tystring;ty]
let db_prefix tydb = func (Badoplink.db_prefix) [tydb; tystring]
let make_engine() = func (BadopEngine.get) [(tyoptions ()); (tyengine ())]
let local_options() =
func (BadopEngine.local_options) [typeoption tystring; typeoption tystring; (tyoptions ())]
let light_options =
#<Ifstatic:HAS_DBM 1>
fun () -> func (BadopEngine.light_options) [typeoption tystring; typeoption tystring; (tyoptions ())]
#<Else>
let haswarn = ref false in
fun () ->
if not !haswarn then
(warn (
"The compiler was compiled without support for dblight, which is\n" ^^
"set as default in your source (using \"@{<bright>database @@light@}\").\n" ^^
"Defaulting to the normal database."
);
haswarn := true);
local_options()
#<End>
let client_options() =
func (BadopEngine.client_options) [typeoption tystring; typeoption tystring; typeoption tyint; (tyoptions ())]
let check_remaining_arguments() =
func (BadopEngine.check_remaining_arguments) [ tyunit ]
let open_db() =
func (Badoplink.open_db) [(tyengine ()); DbGen_common.Db.t ()]
let node_properties() =
func (Badoplink.node_properties) [DbGen_common.Db.t (); (tynodeconfig ()); tyunit]
let node_config_construct() =
func (Badoplink.node_config_construct) [tystring; (tynodeconfig ())]
let is_db_new() =
func (Badoplink.is_db_new) [DbGen_common.Db.t (); tyint]
let key_int() = func (Badoplink.key_int) [tyint;(tykey ())]
let key_string() = func (Badoplink.key_string) [tystring;(tykey ())]
let key_value_int() = func (Badoplink.key_value_int) [(tykey ());tyint]
let key_value_string() = func (Badoplink.key_value_string) [(tykey ());tystring]
let make_ocaml_list l ty =
let make_nil () = expr BslNativeLib.empty_list (tycaml_list ty) in
let make_hdtl hd tl = apply_lambda' (expr BslNativeLib.cons (tyfun [ty;tycaml_list ty;tycaml_list ty])) [hd;tl] in
let rec make_list l =
match l with
| [] -> make_nil()
| hd::tl -> make_hdtl hd (make_list tl)
in
make_list l
let key_list() = func (Badoplink.key_list) [tycaml_list (tykey ());(tykey ())]
let empty_partial_key () =
expr (Badoplink.empty_partial_key) (typartialkey ())
let add_hole () = func (Badoplink.add_hole) [(typartialkey ()); (typartialkey ())]
let add_key () = func (Badoplink.add_key) [(typartialkey ()); (tykey ()); (typartialkey ())]
let dbpath_root() = expr (Badoplink.dbpath_root) (typath ())
let dbpath_add() = func (Badoplink.dbpath_add) [(typath ());(tykey ());(typath ())]
let trans_start() =
func (Badoplink.trans_start) [DbGen_common.Db.t (); (tytrans ())]
let trans_commit() =
func (Badoplink.trans_commit) [(tytrans ());tyunit]
let trans_abort() =
func (Badoplink.trans_abort) [(tytrans ());tyunit]
let data_int() = func (Badoplink.data_int) [tyint;(tydata ())]
let data_text() =
func (Badoplink.data_text) [tystring;(tydata ())]
let data_binary() =
func (Badoplink.data_binary) [tystring;(tydata ())]
let data_float() =
func (Badoplink.data_float) [tyfloat;(tydata ())]
let data_unit() =
func (Badoplink.data_unit) [(tydata ())]
let proj_dbtype leaf_t =
let proj_fun, ty = match leaf_t with
| DbGen_common.Leaf_int -> (Badoplink.data_obj_int), tyint
| DbGen_common.Leaf_float -> (Badoplink.data_obj_float), tyfloat
| DbGen_common.Leaf_text -> (Badoplink.data_obj_text), tystring
| DbGen_common.Leaf_binary -> (Badoplink.data_obj_binary), tystring
in func proj_fun [(tydata ());ty]
let get_opt() =
func (Badoplink.get_opt) [(tytrans ()); (typath ()); typeoption (tydata ())]
let get_new_key() =
func(Badoplink.get_new_key) [(tytrans ()); (typath ()); tyint]
let exists() =
func (Badoplink.exists) [(tytrans ()); (typath ()); tyint]
let uppath() =
func (Badoplink.uppath) [(tytrans ()); (typath ()); (typath ())]
let set() =
func (Badoplink.set) [(tytrans ()); (typath ()); (tydata ()); (tytrans ())]
let clear() =
func (Badoplink.clear) [(tytrans ()); (typath ()); (tytrans ())]
let remove_children () =
func (Badoplink.remove_children) [(tytrans ()); (typath ()); (tytrans ())]
let set_link() =
func (Badoplink.set_link) [(tytrans ()); (typath ()); (typath ()); (tytrans ())]
let set_current_copy() =
func (Badoplink.set_current_copy) [(tytrans ()); (typath ()); (typath ()); (tytrans ())]
let fold_children ty tyacc =
func Badoplink.fold_children [
(tytrans ()); (typath ());
tyfun [(tytrans ());(typath ());ty];
tyfun [tyacc;(tykey ());ty;tyacc];
tyacc;
tyacc;
]
(*
let fold_int_keys ty =
func (Badoplink.fold_int_keys)
[(tytrans ());(typath ());tyfun [tyint;ty;ty];ty;typeoption ty]
let fold_string_keys ty =
func (Badoplink.fold_string_keys)
[(tytrans ());(typath ());tyfun [tystring;ty;ty];ty;typeoption ty]
*)
let compare ty = func Opacapi.Opabsl.BslPervasives.compare_raw [ty;ty;tyint]
let get_registered_db_ident tydb =
func (Badoplink.get_registered_db_ident) [tystring; tydb]
let register_db_ident tydb =
func (Badoplink.register_db_ident) [tystring; tydb; tyunit]
let get_registered_root_edge() =
func (Badoplink.get_registered_root_edge) [tystring;tystring;tyint;tyint]
let register_root_edge() =
func (Badoplink.register_root_edge) [tystring;tystring;tyint;tyint;tyunit]
(** -- Bypasses from mlbsl/transactions --*)
let highlevel_trans_start ty =
func (Transactions.start) [ty;tyhltrans ty]
let highlevel_trans_continue ty1 ty2 =
func (Transactions.continue)
[tyhltrans ty1; tyfun [ty1;ty2]; tyfun [ty1;ty2]; tyhltrans ty2]
let highlevel_trans_commit ty =
func (Transactions.commit) [tyhltrans ty; ty]
let get_global_transaction_opt() =
func (Transactions.get_global_transaction_opt) [DbGen_common.Db.t (); typeoption (tytrans ())]
let set_global_transaction() =
func (Transactions.set_global_transaction)
[DbGen_common.Db.t (); (tytrans ()); tyunit]
let fail ty = func (Transactions.fail) [tystring; ty; ty]
(** -- Bypasses from mlbsl/path --*)
let embedded_path () =
func (Path.embedded_path) [(tytrans ()); (typath ()); (tyobj ())]
let get_ref_path ty =
func (Path.get_ref_path)
[DbGen_common.Db.t ();
(typath ());
tyfun [(tytrans ()); ty];
tyfun [(tytrans ()); ty; (tytrans ())];
DbGen_common.ref_path_ty ty]
let get_val_path ty =
func (Path.get_val_path)
[(tytrans ());
(typath ());
tyfun [(tytrans ()); ty];
DbGen_common.val_path_ty ty]
let create_dbset ty =
func (Badoplink.create_dbset)
[(tytrans ());
(typath ());
tyfun [(tytrans ()); (typath ()); ty];
tydbset ty]
let set_dbset_keys dbsetty =
func (Badoplink.set_dbset_keys)
[dbsetty;
(typartialkey ());
dbsetty]
let copy ty =
func (Path.copy)
[(tytrans ()); DbGen_common.val_path_ty ty; (typath ()); (tytrans ())]
let get_lazy_info_opt ty = func (Path.get_lazy_info_opt) [ty; typeoption (ty_lazy_data ())]
let embed_record_data ty = func (Path.embed_record_data) [ty; typeoption (tyobj ()); ty]
let inject_record_data ty = func (Path.inject_record_data) [ty; typeoption (tyobj ()); tyunit]
(** -- Bypasses from mlbsl/dbgraph *)
let matching_edge() = func (Dbgraph.matching_edge) [(tydiff ());tystring;tyint;tyint]
let diff() = func (Dbgraph.diff) [tystring;tystring;(tydiff ())]
let empty_diff() = expr (Dbgraph.empty_diff) (tydiff ())
let diff_status() = func (Dbgraph.diff_status) [(tydiff ());tyint]
let diff_message() = func (Dbgraph.diff_message) [tystring;(tydiff ());tystring]
let get_diffed_schema() = func (Dbgraph.get_diffed_schema) [(tydiff ());tystring]
let print_tree() = func (Dbgraph.print_tree) [tystring;tyunit]
let shall_i_upgrade() = func (Badoplink.shall_i_upgrade) [DbGen_common.Db.t ();tybool]
end
end