-
Notifications
You must be signed in to change notification settings - Fork 125
/
qmlFlatServerLib.ml
112 lines (90 loc) · 3.95 KB
/
qmlFlatServerLib.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
(*
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/>.
*)
(* alias *)
module FField = Flat_Runtime.Field
module VTable = Flat_Runtime.VTable
(*
Magic traduction, because ocaml does not accept friend modules
*)
external field_t_of_field : ServerLib.field -> FField.t = "%identity"
external field_of_field_t : FField.t -> ServerLib.field = "%identity"
external ty_record_of_record : Flat_Runtime.record -> ServerLib.ty_record = "%identity"
external record_of_ty_record : ServerLib.ty_record -> Flat_Runtime.record = "%identity"
(* this module isn't meant to be used directly, call DebugPrint.print instead *)
module Debug : sig end =
struct
let check_vtable = VTable.check
let check_record_repr (x:Obj.t) : bool =
(Obj.tag x = 0) && (* array *)
Obj.size x >= 2 && (* vtable + option + flattened fields *)
check_vtable (Obj.field x 0) &&
DebugPrint.option (Obj.field x 1) &&
Obj.size x - 2 = Obj.size (Obj.field x 0) (* content and vtable have same size *)
(* cant't check anything on the content *)
let check_record (x:'a) : bool = check_record_repr (Obj.repr x)
(* printing by inspection of the values *)
let unsafe_print x =
Printf.sprintf "{%s}"
(ServerLib.fold_record
(fun field obj acc ->
let acc = if acc = "" then "" else acc^"; " in
let name_field = FField.name (field_t_of_field field) in
if Flat_Runtime.is_empty (Obj.magic obj)
then Printf.sprintf "%s%s" acc name_field
else Printf.sprintf "%s%s: %s" acc name_field (DebugPrint.print obj)
)
x
"")
let print_opt x =
if check_record x then (
if Flat_Runtime.is_empty (Obj.magic x) then
Some "{}"
else
Some (unsafe_print x)
) else
None
let () = DebugPrint.register {DebugPrint.f = print_opt}
end
type flat_record = Flat_Runtime.flat_record
module Field =
struct
type t = ServerLib.field
let register f = field_of_field_t (FField.register f)
end
module FieldAccess = Flat_Runtime.FieldAccess
type record = ServerLib.ty_record
module Simple =
struct
let register s = ty_record_of_record (Flat_Runtime.Simple.register s)
end
let runtime_error = Flat_Runtime.runtime_error
external unwrap_record : ServerLib.ty_record -> _ array = "%identity"
external get_vtable : ServerLib.ty_record -> VTable.t = "%field0"
let empty = ServerLib.empty_record
let true_ = ty_record_of_record Flat_Runtime.true_
let false_ = ty_record_of_record Flat_Runtime.false_
let wrap_bool b = ty_record_of_record (Flat_Runtime.wrap_bool b)
let unwrap_bool r = Flat_Runtime.unwrap_bool (record_of_ty_record r)
let none = ty_record_of_record Flat_Runtime.none
let some a = ty_record_of_record (Flat_Runtime.some a)
let unwrap_option r = Flat_Runtime.unwrap_option (record_of_ty_record r)
let dot f r = Flat_Runtime.dot (field_t_of_field f) (record_of_ty_record r)
let dot_opt f r = Flat_Runtime.dot_opt (field_t_of_field f) (record_of_ty_record r)
let unsafe_get i r = Flat_Runtime.unsafe_get i (record_of_ty_record r)
let dot_with_cache cache f r = Flat_Runtime.dot_with_cache cache (field_t_of_field f) (record_of_ty_record r)
let extend_with_array r a =
ty_record_of_record (Flat_Runtime.extend_with_array (record_of_ty_record r) (Obj.magic a))
external unsafe_init_static : flat_record -> record = "%identity"
let may_be_simple f = ty_record_of_record (Flat_Runtime.may_be_simple f)
let do_exit = ServerLib.do_exit