Skip to content
This repository
Newer
Older
100644 382 lines (321 sloc) 14.168 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* cf mli *)
19
20 (* libbase *)
21 module List = Base.List
22
23 (* Refactoring WIP *)
24 (* opa compiler *)
25 module Schema = QmlDbGen.Schema
26 (* TODO: is there not a default DbGen in the framework ? *)
27 module DbGen = QmlDbGen.DbGen(QmlDbGen.DbGenByPass.BSLDbGenAlpha)
28
29 (* shorthand *)
30 module Q = QmlAst
31
32 (* Error managment *)
33 let fail fmt = OManager.error ("@[<2>@{<bright>RuntimeError@}:@\n"^^fmt^^"@]@\n")
34
35 (* type alias *)
36 type pos = FilePos.pos
37 type 't pprinter = 't Base.Format.pprinter
38
39 (* Runtime Value Algebra *)
40 (*
41 Although QmlAst fun are Nary, the interpreter can not do a generic apply
42
43 We could also do something like :
44
45 let apply1 =
46 let apply2 =
47 let apply3 = ...
48
49 and decrete that there is a hard encoded limit...
50 This code could be generated, but anyway performance are not the target of qmltop.
51
52 To deal with function of arity 0, the first argument is an option.
53 If the type is None, in the implementation the function expects unit
54 *)
55 (*
56 TODO: in V_closure change the type so that
57 by construction, it must be a lambda node
58 (todo that in Nary version, even in master
59 *)
60
61
62 type t =
63 | V_const of pos * QmlAst.const_expr
64 | V_record of pos * (t Lazy.t) StringMap.t * t option ref
65 | V_closure of pos * (t IdentMap.t) ref * QmlAst.expr
66 | V_extern of pos * string * BslTypes.t list * Obj.t
67 | V_bypass of pos * BslTypes.t list * BslTypes.t * Obj.t
68
69 let pos = LangAst.pos
70 let reset_pos = LangAst.reset_pos
71 let merge_pos = LangAst.merge_pos
72
73 (* Printing *)
74
75 let pp_value ?ty ?(force=false) fmt value =
76 match ty with
f87e8a57 » fpessaux
2011-07-01 [cleanup] QML types: Removed test that never succeeded and moreover u…
77 | Some (Q.TypeVar _) -> Format.pp_print_string fmt "<poly>"
fccc6851 » MLstate
2011-06-21 Initial open-source release
78 | _ ->
79 (* Pretty printing of list *)
80 (* Return also Some _ for non-homogene list *)
81 let rec to_list value =
82 match value with
83 | V_record(_, fds, _) ->
84 let s = StringMap.size fds in
85 if s = 2 then
86 Option.bind (fun tl -> Option.map (fun hd -> hd::tl) (StringMap.find_opt "hd" fds))
87 (Option.bind
88 (fun x -> if force || Lazy.lazy_is_val x then to_list (Lazy.force x) else None)
89 (StringMap.find_opt "tl" fds))
90 else if s = 1 then
91 if StringMap.mem "nil" fds then Some [] else None
92 else None
93 | _ -> None
94 in
95 let rec aux fmt value =
96 let lazy_aux fmt value =
97 if force || Lazy.lazy_is_val value
98 then aux fmt (Lazy.force value)
99 else Format.pp_print_string fmt "<lazy>" in
100 match value with
101 | V_const (_, c) -> QmlAst.Const.pp_expr fmt c
102 | V_record (_, fields, _) ->
103 let size = StringMap.size fields in
104 if size = 0 then
105 Format.pp_print_string fmt "void"
106 else (
107 (* this may be a list *)
108 match to_list value with
109 | Some values ->
110 Format.fprintf fmt "[@ %a@ ]" (Base.Format.pp_list " ;@ " lazy_aux) values
111 | None ->
112 (* TODO: use LangPrint.pp_fields *)
113 if size > 3
114 then
115 Format.fprintf fmt "{@\n%a@\n}"
116 (StringMap.pp " ;@\n" (LangPrint.pp_field " =@ " lazy_aux)) fields
117 else
118 Format.fprintf fmt "{ %a }"
119 (StringMap.pp " ; " (LangPrint.pp_field " = " lazy_aux)) fields
120 )
121 | V_closure (_, _, Q.Lambda _) -> Format.pp_print_string fmt "<fun>"
122 | V_closure _ ->
123 Format.pp_print_string fmt "<clos>"
124 | V_extern (_, n, p, _) ->
125 Format.fprintf fmt "<extern[%a]>" (LangPrint.pp_parameters BslTypes.pp n) p
126
127 | V_bypass (pos, a, b, _) ->
128 Format.fprintf fmt "<bypass[%a]>" BslTypes.pp (BslTypes.Fun (pos, a, b))
129
130 in aux fmt value
131
132 let pp fmt x = pp_value fmt x
133
134 let pp_type fmt v =
135 match v with
136 | V_const (_, c) -> QmlAst.Const.pp_ty fmt (QmlAst.Const.type_of c)
137 | V_record (_, fields, _) ->
138 let pp_field fmt field _ = Format.pp_print_string fmt field in
139 Format.fprintf fmt "{ %a }" (StringMap.pp " ; " pp_field) fields
140 | V_closure _ -> Format.pp_print_string fmt "<fun>"
141 | V_extern _
142 | V_bypass _ -> pp fmt v
143
144 (* comparaison *)
145
146 let compare ?(strong=false) a b =
147 let rec compare a b =
148 match a, b with
149 | V_const (_, a), V_const (_, b) ->
150 let c = Pervasives.compare (QmlAst.Const.type_of a) (QmlAst.Const.type_of b) in
151 if c = 0 && strong then Pervasives.compare a b else c
152 | V_const _, _ -> -1
153 | _, V_const _ -> 1
154 | V_record (_, fields, _), V_record (_, fields', _) ->
155 StringMap.compare (fun x y -> compare (Lazy.force x) (Lazy.force y)) fields fields'
156 | V_record _, _ -> -1
157 | _, V_record _ -> 1
158 | V_closure _, V_closure _ -> -1 (* YAGNI *)
159 | V_closure _, _ -> -1
160 | _, V_closure _ -> 1
161 | V_extern (_, a, tl, _), V_extern (_, b, ttl, _) ->
162 let r = String.compare a b in
163 if r <> 0 then r
164 else
165 let rec aux = function
166 | [], [] -> 0
167 | [], _::_ -> -1
168 | _::_, [] -> 1
169 | t::q, t2::q2 ->
170 let r = BslTypes.compare ~normalize:(not strong) t t2 in
171 if r <> 0 then r else aux (q, q2)
172 in aux (tl, ttl)
173 | V_extern _, _ -> -1
174 | _, V_extern _ -> 1
175 | V_bypass (_, a, b, _), V_bypass (_, c, d, _) ->
176 if strong then
177 let r = List.make_compare (BslTypes.compare ~normalize:(not strong)) a c in
178 if r <> 0 then r
179 else BslTypes.compare ~normalize:(not strong) b d
180 else 1
181
182 in compare a b
183
184 let nopos = FilePos.nopos "opatop:value"
185 let t_null ?(pos=nopos) () = V_extern (pos, "null", [], Obj.repr 0)
186
187 (* value env *)
188
189 type env = t IdentMap.t
190
191 (*
192 Note for hackers :
193
194 This part of the code provides transcription functions between ocaml and qmltop for bsl types
195 !!!!! CRITICAL SECTION !!!!!
196 be carrefully by hacking this code, there could be seg-faulting consequences
197
198 If you are wondering why [ocaml_of_t] and [t_of_ocaml] are not mutually recursive,
199 like in the compiled back-end's, you're a specialist :), congratulations.
200
201 It is because we project function in a currified way, and dynamically. The rest of the projection
202 is done argument by argument.
203 *)
204 module Proj =
205 struct
206 module B = BslTypes
207
208 let t_int ?(pos=nopos) i = V_const (pos, Q.Int i)
209 let t_float ?(pos=nopos) f = V_const (pos, Q.Float f)
210 let t_string ?(pos=nopos) s = V_const (pos, Q.String s)
211 let t_void ?(pos=nopos) () = V_record (pos, StringMap.empty, ref None)
212 let t_int64 ?(pos=nopos) i = V_const (pos, Q.Int (Int64.to_int i))
213
214 let shared_void = t_void ()
215 let shared_lazy_void = Lazy.lazy_from_val shared_void
216 let shared_simple field = StringMap.add field shared_lazy_void StringMap.empty
217 let shared_true = shared_simple "true"
218 let shared_false = shared_simple "false"
219 let shared_none = shared_simple "none"
220
221 let t_true ?(pos=nopos) () = V_record (pos, shared_true, ref None)
222 let t_false ?(pos=nopos) () = V_record (pos, shared_false, ref None)
223
224 let t_bool ?(pos=nopos) b = if b then t_true ~pos () else t_false ~pos ()
225
226 let t_none ?(pos=nopos) () = V_record (pos, shared_none, ref None)
227 let t_some ?(pos=nopos) t =
228 V_record (pos, StringMap.add "some" (Lazy.lazy_from_val t) StringMap.empty, ref None)
229
230 let t_option ?(pos=nopos) = function
231 | None -> t_none ~pos ()
232 | Some v -> t_some ~pos v
233
234 let t_extern ?(pos=nopos) name params x = V_extern (pos, name, params, Obj.repr x)
235
236 let rec t_of_ocaml ty x =
237 match ty with
238 | B.OpaValue _ ->
239 (* A value manipluated by the ServerLib in the external primitive library *)
240 Obj.magic x
241
242 | B.Const (pos, Q.TyInt) -> t_int ~pos (Obj.magic x)
243 | B.Const (pos, Q.TyFloat) -> t_float ~pos (Obj.magic x)
244 | B.Const (pos, Q.TyString) -> t_string ~pos (Obj.magic x)
245 | B.Const (pos, Q.TyNull) -> t_null ~pos ()
246
247 (* If a type is still an alpha, that means that it is a opa-value represented by itself *)
248 | B.TypeVar _ -> Obj.magic x
249
250 | B.Void pos -> t_void ~pos ()
251 | B.Bool pos -> t_bool ~pos (Obj.magic x)
252
253
254 | B.Option (pos, o) -> (
255 match Obj.magic x with
256 | None -> t_none ~pos ()
257 | Some ocaml -> t_some ~pos (t_of_ocaml o ocaml)
258 )
259
260 | B.External (pos, name, params) -> t_extern ~pos name params x
261
262 | B.Fun (pos, u, v) ->
263 (* x is a ocaml function *)
264 (* we generate dynamically a new ocaml function *)
265 (* Note: The projections will be done currified way, application by application *)
266 V_bypass (pos, u, v, Obj.repr x)
267
268
269 let rec ocaml_of_t ~eval:eval ty value =
270 let rec aux ty value =
271 (* FIXME: see what kind of citation are given *)
272 let clash ?(extra="") () =
273 fail "Type Citation:%aValue Citation:%aContext requires a value of type %a@\nbut got a value of type %a@\nThe value is %a%s"
274 FilePos.pp_citation (BslTypes.pos ty)
275 FilePos.pp_citation (pos value)
276 BslTypes.pp ty
277 pp_type value
278 pp value
279 extra
280 in
281 match ty, value with
282 | B.TypeVar _, _ ->
283 (* Note that in this case, we give direct the opa-value 'as is' *)
284 (* there is no probleme, because the ocaml-function which will take it is polymorphic *)
285 Obj.magic value
286
287 | B.OpaValue _, _ ->
288 (* Value manipulated through the ServerLib API *)
289 Obj.magic value
290
291 (* Consts *)
292 | B.Const (_, Q.TyInt) , V_const (_, Q.Int i) -> Obj.magic i
293 | B.Const (_, Q.TyFloat) , V_const (_, Q.Float f) -> Obj.magic f
294 | B.Const (_, Q.TyString) , V_const (_, Q.String s) -> Obj.magic s
295 | B.Const (_, Q.TyNull) , _ -> Obj.magic 0
296
297 | B.Void _, V_record (_, m, r) when StringMap.is_empty m && !r = None -> Obj.magic ()
298
299 (* bool *)
300 | B.Bool _, V_record (_, fields, _) ->
301 let semantic_bool = (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) in
302 Obj.magic semantic_bool
303
304 (* option *)
305 | B.Option (_, o), V_record (_, fds, _) ->
306 let semantic_option =
307 match StringMap.find_opt "some" fds with
308 | None -> if not (StringMap.mem "none" fds) then clash () else None
309 | Some v -> Some (aux o (Lazy.force v))
310 in
311 Obj.magic semantic_option
312
313 | B.External (_, name_exp, param_exp), V_extern (_, name, params, obj) ->
314 (*
315 The typer should have done his work, we could actually just give
316 the value as it is : Obj.obj obj, but we add some runtime checks
317 because opatop can work in #typer off mode.
318 TODO: maybe add an option for desactivating checks, and let
319 opatop just segfauls.
320 *)
321 let _ = (* check *)
322 if name_exp <> name
323 then clash ()
324 else
325 (* verification of parametres - specialisation of parametric types in externs types *)
326 let rec fold subst = function
327 | [], [] -> subst
328 | a::u, b::v ->
329 let expected = a in
330 let found = b in
331 let subst = BslTypes.check_inclusion ~static_strict_check:false subst ~expected ~found in
332 fold subst (u, v)
333 | _ -> clash ()
334 in
335 let subst = BslTypes.empty_substitution in
336 let _ = fold subst (param_exp, params) in
337 ()
338 in
339 (* the extern must not be projected *)
340 Obj.obj obj
341
342 | B.External _, _ ->
343 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"
344 in
345 clash ~extra ()
346
347 (* Here, if the arg-sig or ret_sig are more general that the typ in the real function
348 We must add some qml-conversion *)
349 | B.Fun _, V_bypass (pos, args, ret, obj) -> (
350 (* A value in a V_bypass is an ocaml function. It can be passed 'as is' *)
351 (* We perform some checks (cf documentation [Runtime type checking) of this module) *)
352 let _ =
353 BslTypes.check ~static_strict_check:false ~expected:ty ~found:(B.Fun (pos, args, ret))
354 in
355 Obj.obj obj
356 )
357
358 (* Here is the mixte-functionnal conversion qml --> ocaml : Good Luck to have something like it in C ;) *)
359 | B.Fun (_, tys, tyres), V_closure (_, env, Q.Lambda (_, ids, body)) ->
360 let rec caml_lambda rtys rids env = match rtys, rids with
361 | [], [] ->
362 Obj.magic (fun () -> aux tyres (eval env body) )
363 | [ty], [id] ->
364 Obj.magic (fun v ->
365 let qml = t_of_ocaml ty v in
366 let env = IdentMap.add id qml env in
367 aux tyres (eval env body)
368 )
369 | ty::rtys, id::rids ->
370 Obj.magic (fun v ->
371 let qml = t_of_ocaml ty v in
372 let env = IdentMap.add id qml env in
373 caml_lambda rtys rids env
374 )
375 | _ -> assert false
376 in caml_lambda tys ids (!env)
377
378 | _, _ -> clash ()
379 in
380 aux ty value
381
382 end
Something went wrong with that request. Please try again.