-
Notifications
You must be signed in to change notification settings - Fork 125
/
opaTopValue.ml
382 lines (321 loc) · 13.8 KB
/
opaTopValue.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
(*
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/>.
*)
(* cf mli *)
(* libbase *)
module List = Base.List
(* Refactoring WIP *)
(* opa compiler *)
module Schema = QmlDbGen.Schema
(* TODO: is there not a default DbGen in the framework ? *)
module DbGen = QmlDbGen.DbGen(QmlDbGen.DbGenByPass.BSLDbGenAlpha)
(* shorthand *)
module Q = QmlAst
(* Error managment *)
let fail fmt = OManager.error ("@[<2>@{<bright>RuntimeError@}:@\n"^^fmt^^"@]@\n")
(* type alias *)
type pos = FilePos.pos
type 't pprinter = 't Base.Format.pprinter
(* Runtime Value Algebra *)
(*
Although QmlAst fun are Nary, the interpreter can not do a generic apply
We could also do something like :
let apply1 =
let apply2 =
let apply3 = ...
and decrete that there is a hard encoded limit...
This code could be generated, but anyway performance are not the target of qmltop.
To deal with function of arity 0, the first argument is an option.
If the type is None, in the implementation the function expects unit
*)
(*
TODO: in V_closure change the type so that
by construction, it must be a lambda node
(todo that in Nary version, even in master
*)
type t =
| V_const of pos * QmlAst.const_expr
| V_record of pos * (t Lazy.t) StringMap.t * t option ref
| V_closure of pos * (t IdentMap.t) ref * QmlAst.expr
| V_extern of pos * string * BslTypes.t list * Obj.t
| V_bypass of pos * BslTypes.t list * BslTypes.t * Obj.t
let pos = LangAst.pos
let reset_pos = LangAst.reset_pos
let merge_pos = LangAst.merge_pos
(* Printing *)
let pp_value ?ty ?(force=false) fmt value =
match ty with
| Some (Q.TypeVar _) -> Format.pp_print_string fmt "<poly>"
| _ ->
(* Pretty printing of list *)
(* Return also Some _ for non-homogene list *)
let rec to_list value =
match value with
| V_record(_, fds, _) ->
let s = StringMap.size fds in
if s = 2 then
Option.bind (fun tl -> Option.map (fun hd -> hd::tl) (StringMap.find_opt "hd" fds))
(Option.bind
(fun x -> if force || Lazy.lazy_is_val x then to_list (Lazy.force x) else None)
(StringMap.find_opt "tl" fds))
else if s = 1 then
if StringMap.mem "nil" fds then Some [] else None
else None
| _ -> None
in
let rec aux fmt value =
let lazy_aux fmt value =
if force || Lazy.lazy_is_val value
then aux fmt (Lazy.force value)
else Format.pp_print_string fmt "<lazy>" in
match value with
| V_const (_, c) -> QmlAst.Const.pp_expr fmt c
| V_record (_, fields, _) ->
let size = StringMap.size fields in
if size = 0 then
Format.pp_print_string fmt "void"
else (
(* this may be a list *)
match to_list value with
| Some values ->
Format.fprintf fmt "[@ %a@ ]" (Base.Format.pp_list " ;@ " lazy_aux) values
| None ->
(* TODO: use LangPrint.pp_fields *)
if size > 3
then
Format.fprintf fmt "{@\n%a@\n}"
(StringMap.pp " ;@\n" (LangPrint.pp_field " =@ " lazy_aux)) fields
else
Format.fprintf fmt "{ %a }"
(StringMap.pp " ; " (LangPrint.pp_field " = " lazy_aux)) fields
)
| V_closure (_, _, Q.Lambda _) -> Format.pp_print_string fmt "<fun>"
| V_closure _ ->
Format.pp_print_string fmt "<clos>"
| V_extern (_, n, p, _) ->
Format.fprintf fmt "<extern[%a]>" (LangPrint.pp_parameters BslTypes.pp n) p
| V_bypass (pos, a, b, _) ->
Format.fprintf fmt "<bypass[%a]>" BslTypes.pp (BslTypes.Fun (pos, a, b))
in aux fmt value
let pp fmt x = pp_value fmt x
let pp_type fmt v =
match v with
| V_const (_, c) -> QmlAst.Const.pp_ty fmt (QmlAst.Const.type_of c)
| V_record (_, fields, _) ->
let pp_field fmt field _ = Format.pp_print_string fmt field in
Format.fprintf fmt "{ %a }" (StringMap.pp " ; " pp_field) fields
| V_closure _ -> Format.pp_print_string fmt "<fun>"
| V_extern _
| V_bypass _ -> pp fmt v
(* comparaison *)
let compare ?(strong=false) a b =
let rec compare a b =
match a, b with
| V_const (_, a), V_const (_, b) ->
let c = Pervasives.compare (QmlAst.Const.type_of a) (QmlAst.Const.type_of b) in
if c = 0 && strong then Pervasives.compare a b else c
| V_const _, _ -> -1
| _, V_const _ -> 1
| V_record (_, fields, _), V_record (_, fields', _) ->
StringMap.compare (fun x y -> compare (Lazy.force x) (Lazy.force y)) fields fields'
| V_record _, _ -> -1
| _, V_record _ -> 1
| V_closure _, V_closure _ -> -1 (* YAGNI *)
| V_closure _, _ -> -1
| _, V_closure _ -> 1
| V_extern (_, a, tl, _), V_extern (_, b, ttl, _) ->
let r = String.compare a b in
if r <> 0 then r
else
let rec aux = function
| [], [] -> 0
| [], _::_ -> -1
| _::_, [] -> 1
| t::q, t2::q2 ->
let r = BslTypes.compare ~normalize:(not strong) t t2 in
if r <> 0 then r else aux (q, q2)
in aux (tl, ttl)
| V_extern _, _ -> -1
| _, V_extern _ -> 1
| V_bypass (_, a, b, _), V_bypass (_, c, d, _) ->
if strong then
let r = List.make_compare (BslTypes.compare ~normalize:(not strong)) a c in
if r <> 0 then r
else BslTypes.compare ~normalize:(not strong) b d
else 1
in compare a b
let nopos = FilePos.nopos "opatop:value"
let t_null ?(pos=nopos) () = V_extern (pos, "null", [], Obj.repr 0)
(* value env *)
type env = t IdentMap.t
(*
Note for hackers :
This part of the code provides transcription functions between ocaml and qmltop for bsl types
!!!!! CRITICAL SECTION !!!!!
be carrefully by hacking this code, there could be seg-faulting consequences
If you are wondering why [ocaml_of_t] and [t_of_ocaml] are not mutually recursive,
like in the compiled back-end's, you're a specialist :), congratulations.
It is because we project function in a currified way, and dynamically. The rest of the projection
is done argument by argument.
*)
module Proj =
struct
module B = BslTypes
let t_int ?(pos=nopos) i = V_const (pos, Q.Int i)
let t_float ?(pos=nopos) f = V_const (pos, Q.Float f)
let t_string ?(pos=nopos) s = V_const (pos, Q.String s)
let t_void ?(pos=nopos) () = V_record (pos, StringMap.empty, ref None)
let t_int64 ?(pos=nopos) i = V_const (pos, Q.Int (Int64.to_int i))
let shared_void = t_void ()
let shared_lazy_void = Lazy.lazy_from_val shared_void
let shared_simple field = StringMap.add field shared_lazy_void StringMap.empty
let shared_true = shared_simple "true"
let shared_false = shared_simple "false"
let shared_none = shared_simple "none"
let t_true ?(pos=nopos) () = V_record (pos, shared_true, ref None)
let t_false ?(pos=nopos) () = V_record (pos, shared_false, ref None)
let t_bool ?(pos=nopos) b = if b then t_true ~pos () else t_false ~pos ()
let t_none ?(pos=nopos) () = V_record (pos, shared_none, ref None)
let t_some ?(pos=nopos) t =
V_record (pos, StringMap.add "some" (Lazy.lazy_from_val t) StringMap.empty, ref None)
let t_option ?(pos=nopos) = function
| None -> t_none ~pos ()
| Some v -> t_some ~pos v
let t_extern ?(pos=nopos) name params x = V_extern (pos, name, params, Obj.repr x)
let rec t_of_ocaml ty x =
match ty with
| B.OpaValue _ ->
(* A value manipluated by the ServerLib in the external primitive library *)
Obj.magic x
| B.Const (pos, Q.TyInt) -> t_int ~pos (Obj.magic x)
| B.Const (pos, Q.TyFloat) -> t_float ~pos (Obj.magic x)
| B.Const (pos, Q.TyString) -> t_string ~pos (Obj.magic x)
| B.Const (pos, Q.TyNull) -> t_null ~pos ()
(* If a type is still an alpha, that means that it is a opa-value represented by itself *)
| B.TypeVar _ -> Obj.magic x
| B.Void pos -> t_void ~pos ()
| B.Bool pos -> t_bool ~pos (Obj.magic x)
| B.Option (pos, o) -> (
match Obj.magic x with
| None -> t_none ~pos ()
| Some ocaml -> t_some ~pos (t_of_ocaml o ocaml)
)
| B.External (pos, name, params) -> t_extern ~pos name params x
| B.Fun (pos, u, v) ->
(* x is a ocaml function *)
(* we generate dynamically a new ocaml function *)
(* Note: The projections will be done currified way, application by application *)
V_bypass (pos, u, v, Obj.repr x)
let rec ocaml_of_t ~eval:eval ty value =
let rec aux ty value =
(* FIXME: see what kind of citation are given *)
let clash ?(extra="") () =
fail "Type Citation:%aValue Citation:%aContext requires a value of type %a@\nbut got a value of type %a@\nThe value is %a%s"
FilePos.pp_citation (BslTypes.pos ty)
FilePos.pp_citation (pos value)
BslTypes.pp ty
pp_type value
pp value
extra
in
match ty, value with
| B.TypeVar _, _ ->
(* Note that in this case, we give direct the opa-value 'as is' *)
(* there is no probleme, because the ocaml-function which will take it is polymorphic *)
Obj.magic value
| B.OpaValue _, _ ->
(* Value manipulated through the ServerLib API *)
Obj.magic value
(* Consts *)
| B.Const (_, Q.TyInt) , V_const (_, Q.Int i) -> Obj.magic i
| B.Const (_, Q.TyFloat) , V_const (_, Q.Float f) -> Obj.magic f
| B.Const (_, Q.TyString) , V_const (_, Q.String s) -> Obj.magic s
| B.Const (_, Q.TyNull) , _ -> Obj.magic 0
| B.Void _, V_record (_, m, r) when StringMap.is_empty m && !r = None -> Obj.magic ()
(* bool *)
| B.Bool _, V_record (_, fields, _) ->
let semantic_bool = (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) in
Obj.magic semantic_bool
(* option *)
| B.Option (_, o), V_record (_, fds, _) ->
let semantic_option =
match StringMap.find_opt "some" fds with
| None -> if not (StringMap.mem "none" fds) then clash () else None
| Some v -> Some (aux o (Lazy.force v))
in
Obj.magic semantic_option
| B.External (_, name_exp, param_exp), V_extern (_, name, params, obj) ->
(*
The typer should have done his work, we could actually just give
the value as it is : Obj.obj obj, but we add some runtime checks
because opatop can work in #typer off mode.
TODO: maybe add an option for desactivating checks, and let
opatop just segfauls.
*)
let _ = (* check *)
if name_exp <> name
then clash ()
else
(* verification of parametres - specialisation of parametric types in externs types *)
let rec fold subst = function
| [], [] -> subst
| a::u, b::v ->
let expected = a in
let found = b in
let subst = BslTypes.check_inclusion ~static_strict_check:false subst ~expected ~found in
fold subst (u, v)
| _ -> clash ()
in
let subst = BslTypes.empty_substitution in
let _ = fold subst (param_exp, params) in
()
in
(* the extern must not be projected *)
Obj.obj obj
| B.External _, _ ->
let extra = "@\nHowever, if this opa value is really@ the extern type the bypass is waiting for,@ consider that this bypass is doing @{<bright>illicit things@}...@ The implementation of this bypass should be@ patched to use the type constructor opa[]@\n"
in
clash ~extra ()
(* Here, if the arg-sig or ret_sig are more general that the typ in the real function
We must add some qml-conversion *)
| B.Fun _, V_bypass (pos, args, ret, obj) -> (
(* A value in a V_bypass is an ocaml function. It can be passed 'as is' *)
(* We perform some checks (cf documentation [Runtime type checking) of this module) *)
let _ =
BslTypes.check ~static_strict_check:false ~expected:ty ~found:(B.Fun (pos, args, ret))
in
Obj.obj obj
)
(* Here is the mixte-functionnal conversion qml --> ocaml : Good Luck to have something like it in C ;) *)
| B.Fun (_, tys, tyres), V_closure (_, env, Q.Lambda (_, ids, body)) ->
let rec caml_lambda rtys rids env = match rtys, rids with
| [], [] ->
Obj.magic (fun () -> aux tyres (eval env body) )
| [ty], [id] ->
Obj.magic (fun v ->
let qml = t_of_ocaml ty v in
let env = IdentMap.add id qml env in
aux tyres (eval env body)
)
| ty::rtys, id::rids ->
Obj.magic (fun v ->
let qml = t_of_ocaml ty v in
let env = IdentMap.add id qml env in
caml_lambda rtys rids env
)
| _ -> assert false
in caml_lambda tys ids (!env)
| _, _ -> clash ()
in
aux ty value
end