Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 392 lines (327 sloc) 14.492 kb
fccc685 Initial open-source release
MLstate authored
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
77
78 | Some (Q.TypeName (_, ident)) when (QmlAst.TypeIdent.is_abstract ident) ->
79 Format.pp_print_string fmt "<abstr>"
80
81 | Some (Q.TypeVar _) ->
82 Format.pp_print_string fmt "<poly>"
83
84 | _ ->
85 (* Pretty printing of list *)
86 (* Return also Some _ for non-homogene list *)
87 let rec to_list value =
88 match value with
89 | V_record(_, fds, _) ->
90 let s = StringMap.size fds in
91 if s = 2 then
92 Option.bind (fun tl -> Option.map (fun hd -> hd::tl) (StringMap.find_opt "hd" fds))
93 (Option.bind
94 (fun x -> if force || Lazy.lazy_is_val x then to_list (Lazy.force x) else None)
95 (StringMap.find_opt "tl" fds))
96 else if s = 1 then
97 if StringMap.mem "nil" fds then Some [] else None
98 else None
99 | _ -> None
100 in
101 let rec aux fmt value =
102 let lazy_aux fmt value =
103 if force || Lazy.lazy_is_val value
104 then aux fmt (Lazy.force value)
105 else Format.pp_print_string fmt "<lazy>" in
106 match value with
107 | V_const (_, c) -> QmlAst.Const.pp_expr fmt c
108 | V_record (_, fields, _) ->
109 let size = StringMap.size fields in
110 if size = 0 then
111 Format.pp_print_string fmt "void"
112 else (
113 (* this may be a list *)
114 match to_list value with
115 | Some values ->
116 Format.fprintf fmt "[@ %a@ ]" (Base.Format.pp_list " ;@ " lazy_aux) values
117 | None ->
118 (* TODO: use LangPrint.pp_fields *)
119 if size > 3
120 then
121 Format.fprintf fmt "{@\n%a@\n}"
122 (StringMap.pp " ;@\n" (LangPrint.pp_field " =@ " lazy_aux)) fields
123 else
124 Format.fprintf fmt "{ %a }"
125 (StringMap.pp " ; " (LangPrint.pp_field " = " lazy_aux)) fields
126 )
127 | V_closure (_, _, Q.Lambda _) -> Format.pp_print_string fmt "<fun>"
128 | V_closure _ ->
129 Format.pp_print_string fmt "<clos>"
130 | V_extern (_, n, p, _) ->
131 Format.fprintf fmt "<extern[%a]>" (LangPrint.pp_parameters BslTypes.pp n) p
132
133 | V_bypass (pos, a, b, _) ->
134 Format.fprintf fmt "<bypass[%a]>" BslTypes.pp (BslTypes.Fun (pos, a, b))
135
136 in aux fmt value
137
138 let pp fmt x = pp_value fmt x
139
140 let pp_type fmt v =
141 match v with
142 | V_const (_, c) -> QmlAst.Const.pp_ty fmt (QmlAst.Const.type_of c)
143 | V_record (_, fields, _) ->
144 let pp_field fmt field _ = Format.pp_print_string fmt field in
145 Format.fprintf fmt "{ %a }" (StringMap.pp " ; " pp_field) fields
146 | V_closure _ -> Format.pp_print_string fmt "<fun>"
147 | V_extern _
148 | V_bypass _ -> pp fmt v
149
150 (* comparaison *)
151
152 let compare ?(strong=false) a b =
153 let rec compare a b =
154 match a, b with
155 | V_const (_, a), V_const (_, b) ->
156 let c = Pervasives.compare (QmlAst.Const.type_of a) (QmlAst.Const.type_of b) in
157 if c = 0 && strong then Pervasives.compare a b else c
158 | V_const _, _ -> -1
159 | _, V_const _ -> 1
160 | V_record (_, fields, _), V_record (_, fields', _) ->
161 StringMap.compare (fun x y -> compare (Lazy.force x) (Lazy.force y)) fields fields'
162 | V_record _, _ -> -1
163 | _, V_record _ -> 1
164 | V_closure _, V_closure _ -> -1 (* YAGNI *)
165 | V_closure _, _ -> -1
166 | _, V_closure _ -> 1
167 | V_extern (_, a, tl, _), V_extern (_, b, ttl, _) ->
168 let r = String.compare a b in
169 if r <> 0 then r
170 else
171 let rec aux = function
172 | [], [] -> 0
173 | [], _::_ -> -1
174 | _::_, [] -> 1
175 | t::q, t2::q2 ->
176 let r = BslTypes.compare ~normalize:(not strong) t t2 in
177 if r <> 0 then r else aux (q, q2)
178 in aux (tl, ttl)
179 | V_extern _, _ -> -1
180 | _, V_extern _ -> 1
181 | V_bypass (_, a, b, _), V_bypass (_, c, d, _) ->
182 if strong then
183 let r = List.make_compare (BslTypes.compare ~normalize:(not strong)) a c in
184 if r <> 0 then r
185 else BslTypes.compare ~normalize:(not strong) b d
186 else 1
187
188 in compare a b
189
190 let nopos = FilePos.nopos "opatop:value"
191 let t_null ?(pos=nopos) () = V_extern (pos, "null", [], Obj.repr 0)
192
193 (* value env *)
194
195 type env = t IdentMap.t
196
197 (*
198 Note for hackers :
199
200 This part of the code provides transcription functions between ocaml and qmltop for bsl types
201 !!!!! CRITICAL SECTION !!!!!
202 be carrefully by hacking this code, there could be seg-faulting consequences
203
204 If you are wondering why [ocaml_of_t] and [t_of_ocaml] are not mutually recursive,
205 like in the compiled back-end's, you're a specialist :), congratulations.
206
207 It is because we project function in a currified way, and dynamically. The rest of the projection
208 is done argument by argument.
209 *)
210 module Proj =
211 struct
212 module B = BslTypes
213
214 let t_int ?(pos=nopos) i = V_const (pos, Q.Int i)
215 let t_float ?(pos=nopos) f = V_const (pos, Q.Float f)
216 let t_string ?(pos=nopos) s = V_const (pos, Q.String s)
217 let t_char ?(pos=nopos) c = V_const (pos, Q.Char c)
218 let t_void ?(pos=nopos) () = V_record (pos, StringMap.empty, ref None)
219 let t_int64 ?(pos=nopos) i = V_const (pos, Q.Int (Int64.to_int i))
220
221 let shared_void = t_void ()
222 let shared_lazy_void = Lazy.lazy_from_val shared_void
223 let shared_simple field = StringMap.add field shared_lazy_void StringMap.empty
224 let shared_true = shared_simple "true"
225 let shared_false = shared_simple "false"
226 let shared_none = shared_simple "none"
227
228 let t_true ?(pos=nopos) () = V_record (pos, shared_true, ref None)
229 let t_false ?(pos=nopos) () = V_record (pos, shared_false, ref None)
230
231 let t_bool ?(pos=nopos) b = if b then t_true ~pos () else t_false ~pos ()
232
233 let t_none ?(pos=nopos) () = V_record (pos, shared_none, ref None)
234 let t_some ?(pos=nopos) t =
235 V_record (pos, StringMap.add "some" (Lazy.lazy_from_val t) StringMap.empty, ref None)
236
237 let t_option ?(pos=nopos) = function
238 | None -> t_none ~pos ()
239 | Some v -> t_some ~pos v
240
241 let t_extern ?(pos=nopos) name params x = V_extern (pos, name, params, Obj.repr x)
242
243 let rec t_of_ocaml ty x =
244 match ty with
245 | B.OpaValue _ ->
246 (* A value manipluated by the ServerLib in the external primitive library *)
247 Obj.magic x
248
249 | B.Const (pos, Q.TyInt) -> t_int ~pos (Obj.magic x)
250 | B.Const (pos, Q.TyFloat) -> t_float ~pos (Obj.magic x)
251 | B.Const (pos, Q.TyString) -> t_string ~pos (Obj.magic x)
252 | B.Const (pos, Q.TyChar) -> t_char ~pos (Obj.magic x)
253 | B.Const (pos, Q.TyNull) -> t_null ~pos ()
254
255 (* If a type is still an alpha, that means that it is a opa-value represented by itself *)
256 | B.TypeVar _ -> Obj.magic x
257
258 | B.Void pos -> t_void ~pos ()
259 | B.Bool pos -> t_bool ~pos (Obj.magic x)
260
261
262 | B.Option (pos, o) -> (
263 match Obj.magic x with
264 | None -> t_none ~pos ()
265 | Some ocaml -> t_some ~pos (t_of_ocaml o ocaml)
266 )
267
268 | B.External (pos, name, params) -> t_extern ~pos name params x
269
270 | B.Fun (pos, u, v) ->
271 (* x is a ocaml function *)
272 (* we generate dynamically a new ocaml function *)
273 (* Note: The projections will be done currified way, application by application *)
274 V_bypass (pos, u, v, Obj.repr x)
275
276
277 let rec ocaml_of_t ~eval:eval ty value =
278 let rec aux ty value =
279 (* FIXME: see what kind of citation are given *)
280 let clash ?(extra="") () =
281 fail "Type Citation:%aValue Citation:%aContext requires a value of type %a@\nbut got a value of type %a@\nThe value is %a%s"
282 FilePos.pp_citation (BslTypes.pos ty)
283 FilePos.pp_citation (pos value)
284 BslTypes.pp ty
285 pp_type value
286 pp value
287 extra
288 in
289 match ty, value with
290 | B.TypeVar _, _ ->
291 (* Note that in this case, we give direct the opa-value 'as is' *)
292 (* there is no probleme, because the ocaml-function which will take it is polymorphic *)
293 Obj.magic value
294
295 | B.OpaValue _, _ ->
296 (* Value manipulated through the ServerLib API *)
297 Obj.magic value
298
299 (* Consts *)
300 | B.Const (_, Q.TyInt) , V_const (_, Q.Int i) -> Obj.magic i
301 | B.Const (_, Q.TyFloat) , V_const (_, Q.Float f) -> Obj.magic f
302 | B.Const (_, Q.TyString) , V_const (_, Q.String s) -> Obj.magic s
303 | B.Const (_, Q.TyChar) , V_const (_, Q.Char c) -> Obj.magic c
304 | B.Const (_, Q.TyNull) , _ -> Obj.magic 0
305
306 | B.Void _, V_record (_, m, r) when StringMap.is_empty m && !r = None -> Obj.magic ()
307
308 (* bool *)
309 | B.Bool _, V_record (_, fields, _) ->
310 let semantic_bool = (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) in
311 Obj.magic semantic_bool
312
313 (* option *)
314 | B.Option (_, o), V_record (_, fds, _) ->
315 let semantic_option =
316 match StringMap.find_opt "some" fds with
317 | None -> if not (StringMap.mem "none" fds) then clash () else None
318 | Some v -> Some (aux o (Lazy.force v))
319 in
320 Obj.magic semantic_option
321
322 | B.External (_, name_exp, param_exp), V_extern (_, name, params, obj) ->
323 (*
324 The typer should have done his work, we could actually just give
325 the value as it is : Obj.obj obj, but we add some runtime checks
326 because opatop can work in #typer off mode.
327 TODO: maybe add an option for desactivating checks, and let
328 opatop just segfauls.
329 *)
330 let _ = (* check *)
331 if name_exp <> name
332 then clash ()
333 else
334 (* verification of parametres - specialisation of parametric types in externs types *)
335 let rec fold subst = function
336 | [], [] -> subst
337 | a::u, b::v ->
338 let expected = a in
339 let found = b in
340 let subst = BslTypes.check_inclusion ~static_strict_check:false subst ~expected ~found in
341 fold subst (u, v)
342 | _ -> clash ()
343 in
344 let subst = BslTypes.empty_substitution in
345 let _ = fold subst (param_exp, params) in
346 ()
347 in
348 (* the extern must not be projected *)
349 Obj.obj obj
350
351 | B.External _, _ ->
352 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"
353 in
354 clash ~extra ()
355
356 (* Here, if the arg-sig or ret_sig are more general that the typ in the real function
357 We must add some qml-conversion *)
358 | B.Fun _, V_bypass (pos, args, ret, obj) -> (
359 (* A value in a V_bypass is an ocaml function. It can be passed 'as is' *)
360 (* We perform some checks (cf documentation [Runtime type checking) of this module) *)
361 let _ =
362 BslTypes.check ~static_strict_check:false ~expected:ty ~found:(B.Fun (pos, args, ret))
363 in
364 Obj.obj obj
365 )
366
367 (* Here is the mixte-functionnal conversion qml --> ocaml : Good Luck to have something like it in C ;) *)
368 | B.Fun (_, tys, tyres), V_closure (_, env, Q.Lambda (_, ids, body)) ->
369 let rec caml_lambda rtys rids env = match rtys, rids with
370 | [], [] ->
371 Obj.magic (fun () -> aux tyres (eval env body) )
372 | [ty], [id] ->
373 Obj.magic (fun v ->
374 let qml = t_of_ocaml ty v in
375 let env = IdentMap.add id qml env in
376 aux tyres (eval env body)
377 )
378 | ty::rtys, id::rids ->
379 Obj.magic (fun v ->
380 let qml = t_of_ocaml ty v in
381 let env = IdentMap.add id qml env in
382 caml_lambda rtys rids env
383 )
384 | _ -> assert false
385 in caml_lambda tys ids (!env)
386
387 | _, _ -> clash ()
388 in
389 aux ty value
390
391 end
Something went wrong with that request. Please try again.