/
bslValue.ml
161 lines (114 loc) · 5.57 KB
/
bslValue.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
(*
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/>.
*)
(** Provides some functions for manipulate runtime values on Opa. *)
(** Type of field of records. *)
##extern-type Record.field = ServerLib.field
(** Type of record constructor. *)
##extern-type Record.constructor = ServerLib.record_constructor
(** Type of record patterns indexes. *)
##extern-type Record.patterns_indexes = ServerLib.patterns_indexes
(** Type of record fields indexes. *)
##extern-type Record.fields_indexes = ServerLib.fields_indexes
(** Type of record field index. *)
##extern-type Record.field_index = ServerLib.field_index
(** A module for manipulate and construct records. It's just alias to
some functions of the [ServerLib].
@see <./BslServerLib.S.html> Interface of the server lib
*)
##module record
##register dot : 'a, Record.field -> option('b)
let dot r f = ServerLib.dot (Obj.magic r) f
##register unsafe_dot : 'a, Record.field -> 'b
let unsafe_dot r f = ServerLib.unsafe_dot (Obj.magic r) f
##register fold_record : (Record.field, 'a, 'b -> 'b), 'c, 'b -> 'b
let fold_record = ServerLib.fold_record
##register fold_2_record : (Record.field, 'a, 'a, 'b -> 'b), 'c, 'c, 'b -> 'b
let fold_2_record = ServerLib.fold_2_record
##register name_of_field : Record.field -> option(string)
let name_of_field = ServerLib.name_of_field
##register field_of_name : string -> option(Record.field)
let field_of_name = ServerLib.field_of_name
(** The empty record constructor. *)
##register empty_constructor : -> Record.constructor
let empty_constructor _ = ServerLib.empty_record_constructor
##register add_field : Record.constructor, Record.field, 'c -> Record.constructor
let add_field = ServerLib.add_field
##register make_record : Record.constructor -> 'c
let make_record c = Obj.magic (ServerLib.make_record c)
##register make_simple_record : Record.field -> _
let make_simple_record field =
Obj.magic (ServerLib.make_simple_record field)
##register fields_indexes : llarray(Record.field) -> Record.fields_indexes
let fields_indexes fields = ServerLib.fields_indexes (Obj.magic (fields:Obj.t array): ServerLib.field array)
##register field_index \ `ServerLib.field_index` : Record.fields_indexes,Record.field -> Record.field_index
##register dot_with_field_index : 'record,Record.field_index -> 'field_content
let dot_with_field_index record field_index = ServerLib.dot_with_field_index (Obj.magic record:ServerLib.ty_record) field_index
##register patterns_indexes : llarray(Record.fields_indexes) -> Record.patterns_indexes
let patterns_indexes patterns = ServerLib.patterns_indexes (Obj.magic (patterns:Obj.t array): ServerLib.fields_indexes array)
##register compare_structure \ `ServerLib.compare_structure` : Record.patterns_indexes,'record,'record -> int
let compare_structure pi r1 r2 = ServerLib.compare_structure pi (Obj.magic r1:ServerLib.ty_record) (Obj.magic r2:ServerLib.ty_record)
##endmodule
(** This module is very dangerous, don't use it directly. It's a
module for explicit instantiation. It allow to associated a string
with type scheme.*)
##module tsc
(** The association table. *)
let tsctbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 1024
(** Register a type scheme. *)
##register [opacapi] add : string, 'c -> void
let add name tsc =
Hashtbl.add tsctbl name (Obj.repr tsc)
(** Get the type scheme as an option. *)
##register get : string -> option('c)
let get name =
try
Some (Obj.obj (Hashtbl.find tsctbl name))
with Not_found -> None
##endmodule
(** Used for register and get some specialized function for magic
function. *)
##module MagicContainer
let to_string_tbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 16
##register to_string_add : string, 'a -> void
let to_string_add k o = Hashtbl.add to_string_tbl k (Obj.repr o)
##register to_string_get : string -> option('a)
let to_string_get k =
try
Some (Obj.obj (Hashtbl.find to_string_tbl k))
with Not_found -> None
let compare_tbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 16
##register compare_add : string, 'a -> void
let compare_add k o = Hashtbl.add compare_tbl k (Obj.repr o)
##register compare_get : string -> option('a)
let compare_get k =
try
Some (Obj.obj (Hashtbl.find compare_tbl k))
with Not_found -> None
let serializer_tbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 16
##register serializer_add : string, 'a -> void
let serializer_add k o = Hashtbl.add serializer_tbl k (Obj.repr o)
##register serializer_get : string -> option('a)
let serializer_get k =
try
Some (Obj.obj (Hashtbl.find serializer_tbl k))
with Not_found -> None
let xmlizer_tbl : (string, Obj.t) Hashtbl.t = Hashtbl.create 16
##register xmlizer_add : string, 'a -> void
let xmlizer_add k o = Hashtbl.add xmlizer_tbl k (Obj.repr o)
##register xmlizer_get : string -> option('a)
let xmlizer_get k =
try
Some (Obj.obj (Hashtbl.find xmlizer_tbl k))
with Not_found -> None
##endmodule