Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 466 lines (388 sloc) 14.001 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 (**
19 Interface of generated loaders and plugins
20
21 @author Mathieu Barbin
22 @author Mehdi Bouaziz
23 *)
24
25 module Format = BaseFormat
26
27 (** {6 Type alias (just for lisibility) } *)
28 (** *)
29 type filename = string
30 type contents = string
31 type ocaml_module_name = string (* OcamlUtils.module_name *)
32
33 (** the implementation name, expressed as concrete syntax of the target language *)
34 type implementation = string
35
36 (** the string version of the bsl key *)
37 type skey = string
38
39 (** the extension, like ["ml", "js", "c"] *)
40 type language = BslLanguage.t
41
42 (** a uniq id for identifying the plugin *)
43 type uniq_id = string
44
45 (**
46 The name of the opp directory, without the 'opp' extension
47 *)
48 type plugin_basename = string
49
50 (** {6 Plugin interface} *)
51
52 (**
53 Dealing with external primitives for opa.
54 *)
55
56 (**
57 Marshalable environment for separation of plugin building
58 These types are magically produced by [BslOcaml] and [BslJs]
59 *)
60
61 type javascript_env
62 type ocaml_env
63
64 (**
65 The type of the function that the plugin use to register external primitives.
66 It works with a side effect on some table in BslLib.
67
68 Label are volontary short for minimizing the generated code of plugins.
69
70 + [ks] the hieararchy path until this primitive. The final bslkey will be
71 built by lowercase all the path, and separated items with an underscore.
72 + [ty] the type of the primitive
73 + [ips] all informations about the implementations in all target languages
74 + [language] the extension of the language
75 + [filename] the complete filname with dirname where is the file
76 + [parsed_t] the row tags.
77 + [implementation] the complete identifier for the implementation.
78 ["OpabslgenMLRuntime.Foo.Bar.function"]
79 + [obj] optional, a pointer to the function (in this case, the code is linked
80 with the runtime, this is no more just a plugin, but a loader for the interpreter)
81 *)
82 type register_primitive =
83 ks:skey list ->
84 ty:BslTypes.t ->
85 ips:(language * filename * BslTags.parsed_t * implementation) list ->
86 ?obj:Obj.t ->
87 unit -> unit
88
89
90 type register_primitive_arguments = {
91 rp_ks : skey list ;
92 rp_ty : BslTypes.t ;
93 rp_ips : ( language * filename * BslTags.parsed_t * implementation ) list ;
94 rp_obj : Obj.t option ;
95 }
96
97
98 let apply_register_primitive ( register_primitive : register_primitive ) rp =
99 let ks = rp.rp_ks in
100 let ty = rp.rp_ty in
101 let ips = rp.rp_ips in
102 let obj = rp.rp_obj in
103 register_primitive ~ks ~ty ~ips ?obj ()
104
105
106 let (~>) buf = FBuffer.printf buf
107
108 let pp_escaped fmt s = Format.fprintf fmt "%S" s
109 let pp_fc fmt (f, c) = Format.fprintf fmt "(%S,@\n %S)@\n" f c
110 let pp_ml_list p = Base.Format.pp_list " ; " p
111
112 let pp_js_conf fmt conf =
113 if BslJsConf.is_default conf
114 then
115 Format.pp_print_string fmt "BslJsConf.default"
116 else
117 Format.fprintf fmt "(Marshal.from_string %S 0)"
118 (Marshal.to_string (conf : BslJsConf.conf) [])
119
120 let pp_fc_conf fmt (f, c, conf) =
121 Format.fprintf fmt "(%S,@\n %S,@\n %a)@\n"
122 f
123 c
124 pp_js_conf conf
125
126 let pp_conf fmt conf =
127 if BslConf.is_default conf
128 then
129 Format.pp_print_string fmt "BslConf.default_conf"
130 else
131 Format.fprintf fmt "(Marshal.from_string %S 0)"
132 (Marshal.to_string (conf : BslConf.conf) [])
133
134 (**
135 Meta Generation of code for [register_primitive].
136 *)
137 let meta_register_primitive buf ~ks ~ty ~ips ?obj () =
138 let register = "register" in
139 let b = buf in
140 let b = ~>b "%s " register in
141 let b = ~>b "~ks:[ %a ] " (pp_ml_list pp_escaped) ks in
142 let b = ~>b "~ty:(%a) " BslTypes.pp_meta ty in
143 let b =
144 let pp_impl fmt impl =
145 let lang, filename, parsed_t, implementation = impl in
146 Format.fprintf fmt "(%a, %S, %a, %S)"
147 BslLanguage.pp_meta lang filename BslTags.pp_meta parsed_t implementation
148 in
149 ~>b "~ips:[ %a ] " (pp_ml_list pp_impl) ips
150 in
151 let b =
152 let pp_obj fmt obj = Format.fprintf fmt "~obj:(Obj.repr %s) " obj in
153 ~>b "%a" (Option.pp pp_obj) obj
154 in
155 let b =
156 ~>b "();@\n"
157 in
158 b
159
160
161 (**
162 The type of the function that the plugin use to register external types.
163 It works with a side effect on some table in BslLib.
164
165 + [ks] the hieararchy path until this type defition
166 + [ty] An External type, defined in the target language.
167 *)
168 type register_type =
169 ks:skey list ->
170 ty:BslTypes.t ->
171 unit
172
173
174 type register_type_arguments = {
175 rt_ks : skey list ;
176 rt_ty : BslTypes.t ;
177 }
178
179
180 let apply_register_type ( register_type : register_type ) rt =
181 let ks = rt.rt_ks in
182 let ty = rt.rt_ty in
183 register_type ~ks ~ty
184
185
186 (**
187 Meta Generation of code for [register_type].
188 *)
189 let meta_register_type buf ~ks ~ty =
190 let register = "register_type" in
191 let b = buf in
192 let b = ~>b "%s " register in
193 let b = ~>b "~ks:[ %a ] " (pp_ml_list pp_escaped) ks in
194 let b = ~>b "~ty:(%a) " BslTypes.pp_meta ty in
195 let b = ~>b ";@\n" in
196 b
197
198 (**
199 When the plugin ask for regestering things, it could get such a record,
200 so that it can perform its registering.
201 *)
202 type dynloader_interface = {
203 register_primitive : register_primitive ;
204 register_type : register_type ;
205 }
206
207 (**
208 Whenever a plugin want to register some function, we should actually check
209 if it was not already registred. For that, there is an abtraction, handled
210 via a function named [multi_loading_safe_get_dynloader_interface], which given
211 an uniq id and the runtime name, will let the plugin have acces or not
212 to register funciton.
213 <!> This is the only chance for the plugin to register anything in
214 the bsl table. The next time it will ask, it will get a [None]
215 *)
216 type multi_loading_safe_get_dynloader_interface =
217 uniq_id:string ->
218 plugin_name:plugin_basename ->
219 dynloader_interface option
220
221 (**
222 So, a dynloader in a plugin, is the function which is in charge
223 to get a dynloader_interface, and using it.
224 *)
225 type dynloader = multi_loading_safe_get_dynloader_interface -> unit
226
227 (**
228 Showing what is actually going on in the plugin ["examplePlugin.ml"] generated e.g. with {[bslregister -o example]}
229
230 {[
231 module Self : BslPluginInterface.PLUGIN =
232 struct
233 (* This is an example of minimal plugin *)
234 let self_module_name = "ExamplePlugin"
235 let uniq_id = "ExamplePlugin_17431-2010-08-08-(368c3b4-75fe11b-21cbb74)"
236 let ml_runtime_module_name = "ExampleMLRuntime"
237 let depends = [ "opabslgen" ]
238 let opa_code = [...]
239 let js_code = [...]
240 let dynloader ( get_register : BslPluginInterface.multi_loading_safe_get_dynloader_interface) : unit =
241 match get_register ~uniq_id ~plugin_name:basename with
242 | None ->
243 (* I should have been already loaded *)
244 ()
245 | Some { register = register ; register_type = register_type } ->
246 begin
247 ... (* a lot of code to use register and register_type for registering primitives *)
248 end
249
250 let self = {
251 self_module_name ;
252 uniq_id ;
253 ml_runtime_module_name ;
254 depends ;
255 opa_code ;
256 js_code ;
257 dynloader ;
258 ocaml_env ;
259 javascript_env ;
260 }
261
262 let self_store () = BslPluginTable.store self
263
264 end
265
266 let _ = Self.self_store ()
267
268 ]}
269
270 *)
271 (** *)
272
273 let meta_plugin__01 buf
274 ~basename
275 ~self_module_name
276 ~uniq_id
277 ~conf
278 ~ml_runtime
279 ~depends
280 ~js_code
281 ~opa_code
282 ~ocaml_env
283 ~javascript_env
284 =
285 let static_part =
286 "(* Auto generated plugin / loader, DO NOT EDIT BY HAND *)
287 (* Part of this code is static and comes from BslPluginInterface.ml *)
288 open BslPluginInterface
289 module Self : BslPluginInterface.PLUGIN =
290 struct
291 "
292 in
293 (* I someone find something |> more style, bravo :) - hard to reverse ()format arguemnts... *)
294
295 let b = buf in
296 let b = FBuffer.add b static_part in
297
298 let b = ~> b "let basename = %S\n" basename in
299 let b = ~> b "let self_module_name = %S\n" self_module_name in
300 let b = ~> b "let uniq_id = %S\n" uniq_id in
301 let b = ~> b "let conf = %a\n" pp_conf conf in
302 let b = ~> b "let ml_runtime = %S\n" ml_runtime in
303 let b = ~> b "let depends = [ %a ]\n" (pp_ml_list pp_escaped) depends in
304 let b = ~> b "let js_code = ( [ %a ] : (string * string * BslJsConf.conf) list )\n"
305 (pp_ml_list pp_fc_conf)
306 js_code
307 in
308 let b = ~> b "let opa_code = [ %a ]\n" (pp_ml_list pp_fc) opa_code in
309 let b = ~> b "let ocaml_env = (Marshal.from_string %S 0)\n" (Marshal.to_string (ocaml_env : ocaml_env) []) in
310 let b = ~> b "let javascript_env = (Marshal.from_string %S 0)\n" (Marshal.to_string (javascript_env : javascript_env) []) in
311 b
312
313 let meta_plugin__02 = "
314 (* the generated code seems to enjoy following some weird guidelines *)
315 module Q = QmlAst
316 module B = BslTypes
317 let (~$) = B.(~$)
318 module BPI = BslPluginInterface
319 module L = BslLanguage
320 let dynloader ( get_register : BPI.multi_loading_safe_get_dynloader_interface ) : unit =
321 match get_register ~uniq_id ~plugin_name:basename with
322 | None ->
323 (* I should have been already loaded *)
324 ()
325 | Some { BPI.register_primitive = register ; BPI.register_type = register_type } ->
326 begin
327 let mp = B.meta_pos in
328 (* from there, the code is generated, cf in BslRegisterLib and in BslPluginInterface *)
329 "
330 let meta_plugin__03 = "
331 ()
332 end
333 (* Back there, the code in staticly known, cf BslPluginInterface.meta_plugin__03 *)
334 let self = {
335 basename ;
336 self_module_name ;
337 uniq_id ;
338 conf ;
339 ml_runtime ;
340 depends ;
341 opa_code ;
342 js_code ;
343 dynloader ;
344 ocaml_env ;
345 javascript_env ;
346 }
347
348 let self_store () = BslPluginTable.store self
349
350 end
351
352 let _ = Self.self_store ()
353 "
354
355 (**
356 The type record use for manipulating the module as a first level value
357 Each field correspond to a value of the interface [PLUGIN].
358 The documentation is in the documentation of this interface.
359
360 This is an unmodularization of the plugin, used to access dynamicly
361 the value of a plugin Module.
362 *)
363 type plugin = {
364 basename : plugin_basename ;
365 self_module_name : ocaml_module_name ;
366 uniq_id : uniq_id ;
367 conf : BslConf.conf ;
368 ml_runtime : ocaml_module_name ;
369 depends : plugin_basename list ;
370 opa_code : (filename * contents) list ;
371 js_code : (filename * contents * BslJsConf.conf) list ;
372 dynloader : dynloader ;
373 ocaml_env : ocaml_env ;
374 javascript_env : javascript_env ;
375 }
376
377 let pp fmt plugin =
378 Format.fprintf fmt "@[<2>%s.opp: {@\n" plugin.basename ;
379 Format.fprintf fmt "plugin: %S@\n" plugin.self_module_name ;
380 Format.fprintf fmt "id: %S@\n" plugin.uniq_id ;
381 Format.fprintf fmt "conf: %a@\n" BslConf.pp plugin.conf ;
382 Format.fprintf fmt "mlruntime: %S@\n" plugin.ml_runtime ;
383 Format.fprintf fmt "depends: %a@\n" (Format.pp_list " ; " Format.pp_print_string) plugin.depends ;
384 Format.fprintf fmt "@]}" ;
385
386 module type PLUGIN =
387 sig
388
389 (** {6 Identification} *)
390
391 (**
392 The name asked for the plugin, without the extension opp.
393 *)
394 val basename : plugin_basename
395
396 (**
397 The name of the Ocaml module corresponding to this plugin.
398 This name is already capitalized.
399 e.g. [OpabslgenPlugin]
400 *)
401 val self_module_name : ocaml_module_name
402
403 (**
404 Used to identify different conflicting version of the same Plugin
405 This contains the version of the compiler, and the date of generation.
406 *)
407 val uniq_id : string
408
409 (**
410 Configuration
411 *)
412 val conf : BslConf.conf
413
414 (**
415 This is the name of the ML runtime corresponding to this plugin.
416 When we generate code, we need to know where are the bypass.
417 *)
418 val ml_runtime : ocaml_module_name
419
420 (**
421 The module_name list from parents.
422 This correspond to the list of all [basename] of plugins
423 which was loaded when [bslregister] generated this plugin.
424 (cf option --use-plugin of bslregister)
425 *)
426 val depends : plugin_basename list
427
428 (** {6 Embeded code} *)
429
430 (**
431 This is an escaped string optained by preprocessing {b opa} files
432 with [bslregister].
433 The files are given file by file, indexed by the name of the file.
434 *)
435 val opa_code : (filename * contents) list
436
437 (**
438 This is an escaped string optained by preprocessing {b javascript} files
439 with [bslregister].
440 The files are given file by file, indexed by the name of the file.
441 *)
442 val js_code : (filename * contents * BslJsConf.conf) list
443
444 (** {6 Registering primitives and types} *)
445
446 val dynloader : dynloader
447
448 (**
449 The plugin defines a record with its contains
450 *)
451 val self : plugin
452
453 (**
454 Make the plugin store itself in the BslPluginTable.
455 It works with a side-effect on the plugin table,
456 after that, we have a structure for folding plugins,
457 etc...
458 *)
459 val self_store : unit -> unit
460
461 (**
462 A side effect at the end call the function [self_store]
463 *)
464
465 end
Something went wrong with that request. Please try again.