Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 597 lines (511 sloc) 20.478 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 (*
21 Note about some duplication of code between BslOCaml and BslJs:
22
23 The previous of libbsl was implemented using a functor for sharing some part of this process.
24 The experience has shown that the tratement done on Javascript and Ocaml is quite different,
25 which has lead to have a complexe code in the argument of the functor, not very natural.
26
27 I (mathieu) think that proceding now with 2 different files is more relax, the implementation
28 can be different, without hacking the interfaces of functors and args.
29 *)
30
31 module Format = BaseFormat
32 module String = BaseString
33 let (|>) = InfixOperator.(|>)
34
35 module BPI = BslPluginInterface
36 module D = BslDirectives
37
38 type filename = string
39 type contents = string
40 type module_name = string
41 type skey = string
42 type pos = FilePos.pos
43 type opaname = string
44
45 type js_file = FBuffer.t
46
47
48 let fbuffer () = FBuffer.create (8 * 1024)
49
50 type ty_spec_map = (opaname * module_name list) BslKeyMap.t
51 type renaming = string StringMap.t
52
53 type env = {
54 (* this is just for error messages *)
55 last_module : FilePos.pos ;
56 last_endmodule : FilePos.pos ;
57
58 (* accumulating files in a fold *)
59 rev_files_js_code : (filename * contents) list ;
60
61 rev_path : ( skey * module_name * pos ) list ;
62
63 ty_spec_map : ty_spec_map ;
64 renaming : renaming ;
65 warn_x_field : unit ;
66 }
67
68 module SeparatedEnv :
69 sig
70 type t
71
72 val init : ty_spec_map:ty_spec_map -> renaming:renaming -> t
73 val fold : t -> BslPluginInterface.plugin -> t
74
75 val ty_spec_map : t -> ty_spec_map
76 val renaming : t -> renaming
77
78 module SideEffect :
79 sig
80 val get_javascript_env : unit -> BslPluginInterface.javascript_env
81 val add_ty_spec_map : BslKey.t -> (opaname * module_name list) -> unit
82 val add_renaming : string -> string -> unit
83 end
84 end =
85 struct
86 type t = {
87 ty_spec_map : ty_spec_map ;
88 renaming : renaming ;
89 }
90 let init ~ty_spec_map ~renaming = {
91 ty_spec_map ;
92 renaming ;
93 }
94 let ty_spec_map t = t.ty_spec_map
95 let renaming t = t.renaming
96 external wrap : t -> BslPluginInterface.javascript_env = "%identity"
97 external unwrap : BslPluginInterface.javascript_env -> t = "%identity"
98
99 let fold t plugin =
100 let tp = unwrap plugin.BPI.javascript_env in
101 let ty_spec_map =
102 let fold key ((_opaname, path1) as value) ty_spec_map =
103 BslKeyMap.replace key
104 (function
105 | None -> value
106 | Some ((_, path2) as value2) ->
107 OManager.warning ~wclass:WarningClass.bsl_register (
108 "@[<2>The type @{<bright>%a@} is defined in several imported plugins:@\n"^^
109 "path1: %a@\n"^^
110 "path2: %a@\n"^^
111 "This plugin will use the path2.@]"
112 )
113 BslKey.pp key
114 (Format.pp_list "." Format.pp_print_string) path1
115 (Format.pp_list "." Format.pp_print_string) path2
116 ;
117 value2
118 ) ty_spec_map
119 in
120 BslKeyMap.fold fold tp.ty_spec_map t.ty_spec_map
121 in
122 let renaming =
123 let fold key value renaming =
124 StringMap.replace key
125 (function
126 | None -> value
127 | Some value2 when value = value2 -> value
128 | Some value2 ->
129 OManager.warning ~wclass:WarningClass.bsl_register (
130 "@[<2>The key @{<bright>%s@} is maped to different primitives:@\n"^^
131 "renaming1: %s@\n"^^
132 "renaming2: %s@\n"^^
133 "This plugin will use the renaming2.@]"
134 )
135 key
136 value
137 value2
138 ;
139 value2
140 ) renaming
141 in
142 StringMap.fold fold tp.renaming t.renaming
143 in
144 {
145 renaming ;
146 ty_spec_map ;
147 }
148
149 module SideEffect =
150 struct
151 let ty_spec_map = BslKeyTable.create 16
152 let add_ty_spec_map key value = BslKeyTable.replace ty_spec_map key value
153
154 let renaming = Hashtbl.create 16
155 let add_renaming key value = Hashtbl.replace renaming key value
156
157 let get_javascript_env () =
158 let ty_spec_map = BslKeyTable.fold BslKeyMap.add ty_spec_map BslKeyMap.empty in
159 let renaming = Hashtbl.fold StringMap.add renaming StringMap.empty in
160 let t = {
161 ty_spec_map ;
162 renaming ;
163 } in
164 wrap t
165 end
166 end
167
168 let nopos = FilePos.nopos "BslJs"
169
170 let empty =
171 let empty = {
172 last_module = nopos ;
173 last_endmodule = nopos ;
174
175 rev_files_js_code = [] ;
176
177 rev_path = [] ;
178 ty_spec_map = BslKeyMap.empty ;
179 renaming = StringMap.empty ;
180 warn_x_field = () ;
181 } in
182 ( empty : env )
183
184
185 let (!!) pos fmt =
186 OManager.printf "%a" FilePos.pp_citation pos ;
187 OManager.error fmt
188
189 let warning pos fmt =
190 let wclass = WarningClass.bsl_register in
191 OManager.warning ~wclass ("%a"^^fmt) FilePos.pp_citation pos
192
193 (*
194 Map a name of type, taking in consederation the current path,
195 and the ty_spec_map of the env.
196 @raise Not_found if the type reference does not correspond to
197 any known type.
198 *)
199 let find name ty_spec_map rev_path =
200 let skey = String.rev_concat_map "_" BslKey.normalize_string (name :: rev_path) in
201 let key = BslKey.of_string skey in
202 let result = BslKeyMap.find_opt key ty_spec_map in
203 result
204
205 let check ~options ~depends files_js_code =
206 ignore options ;
207 (* appending all the code *)
208 let all_files_js_code = depends @ files_js_code in
209 let all_js_code = String.concat_map "\n" snd all_files_js_code in
210 ignore all_js_code ;
211 ()
212
213 let js_module skey =String.capitalize ( skey )
214 let js_module_of_filename skey =
215 let skey = String.capitalize (
216 Filename.chop_extension ( Filename.basename skey )
217 ) in
218 let skey = String.multi_replace skey [
219 "-", "_dash_" ;
220 ".", "_dot_" ;
221 ] in
222 skey
223
224 let env_add_module pos skey implementation env =
225 let implementation = Option.default skey implementation in
226 let name = js_module skey in
227 let implementation = js_module implementation in
228 let add_module = name, implementation, pos in
229 let rev_path = add_module :: env.rev_path in
230 let env = {
231 env with
232 rev_path = rev_path ;
233 last_module = pos;
234 } in
235
236 env
237
238 let env_rt_ty_skey env tags skey =
239 match tags.BslTags.opaname with
240 | false ->
241 let skey_rev_path = List.map (fun (s, _, _) -> s) env.rev_path in
242 String.rev_concat_map "_" BslKey.normalize_string ( skey :: skey_rev_path )
243 | true -> skey
244
245 let env_add_endmodule pos env =
246 let rev_path =
247 match env.rev_path with
248 | [] ->
249 let pos = List.fold_left FilePos.merge_pos pos [ env.last_module ; env.last_endmodule ] in
250 !! pos "This @{<bright>##endmodule@} does not match any @{<bright>##module@}@\n"
251
252 | _::tl -> tl
253 in
254 let env = {
255 env with
256 rev_path = rev_path ;
257 last_endmodule = pos;
258 } in
259
260 env
261
262 let env_rp_ks env skey =
263 let skey_rev_path = List.map (fun (s, _, _) -> s) env.rev_path in
264 List.rev (skey :: skey_rev_path)
265
266 let env_map_ty_reference env pos skey =
267 let ty_spec_map = env.ty_spec_map in
268 let rev_pwd_keys = List.map (fun (s, _, _) -> s) env.rev_path in
269 let _js_ocaml = List.rev_map (fun (_, m, _) -> m) env.rev_path in
270 (fun name ->
271 (* 1) find the type reference *)
272 let rec aux = function
273 | [] -> (
274 match find name ty_spec_map [] with
275 | Some found -> found
276 | None -> (
277 (* inefficient, but it is just for an error message (computed once) *)
278 let keys = BslKeyMap.keys_as_string ty_spec_map in
279 OManager.printf "%a" FilePos.pp_citation pos ;
280 OManager.printf "Cannot resolve the reference to the type @{<bright>%s@}@\n" name ;
281 let _ = OManager.printf "%a" (HintUtils.pp_suggestion keys) name in
282 OManager.error "##register: @{<bright>failing type resolution@} for key '@{<brigth>%s@}'@\n" skey
283 )
284 )
285 | ( _::tl ) as rev_path -> (
286 match find name ty_spec_map rev_path with
287 | Some found -> found
288 | None -> aux tl
289 )
290 in
291 match aux rev_pwd_keys with
292 | opaname, path ->
293 let module_path = path in
294 opaname, String.concat_map "." (fun s -> s) module_path
295 )
296
297
298 let env_map_ty_reference_for_select ~select env pos skey ty =
299 let map_ref = env_map_ty_reference env pos skey in
300 BslTypes.Walk.map
301 (function
302 | BslTypes.External (p, name, vs) ->
303 let name' = select (map_ref name) in
304 BslTypes.External (p, name', vs)
305
306 | t -> t) ty
307
308 let env_map_ty_reference_for_opa env pos skey bslty =
309 env_map_ty_reference_for_select ~select:fst env pos skey bslty
310
311 let env_rp_implementation env implementation injected =
312 if injected then implementation
313 else
314 let impl_rev_path = List.map (fun (_, m, _) -> m) env.rev_path in
315 let impl_rev_path = implementation :: impl_rev_path in
316 let implementation = String.rev_sconcat "_" impl_rev_path in
317 implementation
318
319 let env_js_path = env_rp_ks
320
321 (*
322 The fold update the FBuffer
323 *)
324 let debug fmt =
325 OManager.printf ("@[<2>"^^fmt^^"@]@.")
326
327
328
329 (**
330 regexp used to process bypass alias : when a user use %%BslSource.BslModule.bslkey%%,
331 the bsl preprocessor replace the alias by it's implementation
332 Str.full_split split_regexp "texte %%BslCps.Notcps_compatibility.thread_context%%; texte ";;
333 *)
334 let split_regexp = Str.regexp "%%[ ]*[a-zA-Z\\._]+[ ]*%%";;
335
336
337 let rec fold_source_elt ~dynloader_interface ~filename (env, js_file) source_elt =
338
339 let env, js_file =
340 match source_elt with
341 | D.Source (pos, source) ->
342 let splitted = Str.full_split split_regexp source in
343 let source = String.concat "" (List.map
344 (function
345 | Str.Text t -> t
346 | Str.Delim d ->
347 let d = String.sub d 2 ( (String.length d) - 4 ) in
348 let d' = BslKey.normalize (String.trim d) |> BslKey.to_string in
349 match StringMap.find_opt d' env.renaming with
350 | Some s -> s
351 | None ->
352 let _ =
353 let keys =
354 StringMap.fold
355 (fun k _v acc -> k :: acc)
356 env.renaming
357 []
358 in
359 let _ = OManager.printf "%a" (HintUtils.pp_suggestion keys) d' in
360 ()
361 in
362 OManager.error "cannot replace @{<bright>%s@} by the javascript implementation@\nKey not found, position : %a@\n@." d FilePos.pp_citation pos
363 )
364 splitted) in
365 let js_file = FBuffer.addln js_file source in
366 env, js_file
367
368 | D.Directive (pos, tags, directive) -> (
369 match directive with
370 | D.OpaTypeDef (skey, params) ->
371 let () =
372 if not tags.BslTags.opaname
373 then
374 !! pos "an opa-type cannot be @{<brigth>normalized@}"
375 in
376
377 (* for opa types, all rt_ty_skey are opaname *)
378 let rt_ty_skey = skey in
379
380 let skey = "opa_" ^ skey in
381 let rt_ks = env_rp_ks env skey in
382 let key = BslKey.normalize rt_ty_skey in
383 let skey = BslKey.normalize_string skey in
384 let tyitem = rt_ty_skey, env_js_path env skey in
385
386 let ty_spec_map =
387 let replace = function
388 | None ->
389 tyitem
390 | Some (_opaname, conflict_path) ->
391 let path = String.concat "." conflict_path in
392 (* Check of overwrite of key in ty_spec_map *)
393 warning pos (
394 "an opa-type with the same opa name is already defined:@\n"^^
395 "key: %a@\n"^^
396 "path: %s@\n"^^
397 "This is allowed, but this is a bad practice because this hides the@ "^^
398 "previous definition, and this will lead to code duplication.@\n"^^
399 "@[<2>@{<bright>Hint@}:@\n"^^
400 "Use rather functions working on type %s"^^
401 "@]"
402 )
403 BslKey.pp key
404 path
405 path
406 ;
407 tyitem
408 in
409 let () = SeparatedEnv.SideEffect.add_ty_spec_map key tyitem in
410 BslKeyMap.replace key replace env.ty_spec_map
411 in
412
413 let params = List.map (fun v -> BslTypes.TypeVar (pos, v)) params in
414
415 let rt_ty = BslTypes.External (pos, rt_ty_skey, params) in
416
417 let rt = { BslPluginInterface.
418 rt_ks ;
419 rt_ty ;
420 } in
421 let () = BslPluginInterface.apply_register_type dynloader_interface.BslPluginInterface.register_type rt in
422 let env = {
423 env with
424 ty_spec_map ;
425 } in
426 env, js_file
427
428 | D.ExternalTypeDef (skey, params, implementation) ->
429 let () =
430 match implementation with
431 | None -> ()
432 | Some code ->
433 warning pos (
434 "In javascript, type implementation are ignored.@\n"^^
435 "@[<2>@{<bright>Hint@}:@\n"^^
436 "remove this part: ' = %s'@]"
437 ) code
438 in
439 let rt_ks = env_rp_ks env skey in
440 let rt_ty_skey = env_rt_ty_skey env tags skey in
441 let key = BslKey.normalize rt_ty_skey in
442 let skey = BslKey.normalize_string skey in
443 let tyitem = rt_ty_skey, env_js_path env skey in
444
445 let ty_spec_map =
446 let replace = function
447 | None ->
448 tyitem
449 | Some (_, conflict_path) ->
450 (* Check of overwrite of key in ty_spec_map *)
451 warning pos (
452 "an extern-type with the same opa name is already defined:@\n"^^
453 "key: %a@\n"^^
454 "path: %a@\n"^^
455 "This is a bad practice, and will be rejected in a further version of Opa"
456 )
457 BslKey.pp key
458 (Format.pp_list "." Format.pp_print_string) conflict_path
459 ;
460 tyitem
461 in
462 let () = SeparatedEnv.SideEffect.add_ty_spec_map key tyitem in
463 BslKeyMap.replace key replace env.ty_spec_map
464 in
465
466 let params = List.map (fun v -> BslTypes.TypeVar (pos, v)) params in
467
468 let rt_ty = BslTypes.External (pos, rt_ty_skey, params) in
469
470 let rt = { BslPluginInterface.
471 rt_ks ;
472 rt_ty ;
473 } in
474 let () = BslPluginInterface.apply_register_type dynloader_interface.BslPluginInterface.register_type rt in
475 let env = {
476 env with
477 ty_spec_map = ty_spec_map ;
478 } in
479 env, js_file
480
481 | D.Module (skey, implementation) ->
482 env_add_module pos skey implementation env, js_file
483
484 | D.EndModule ->
485 env_add_endmodule pos env, js_file
486
487 | D.Register (skey, source_implementation, injected, bslty) ->
488 let rp_ks = env_rp_ks env skey in
489 let rp_ty = env_map_ty_reference_for_opa env pos skey bslty in
490 let parsed_t = BslTags.parsed_t tags in
491
492 let implementation =
493 match source_implementation with
494 | Some source -> source
495 | None ->
496 if injected then assert false
497 else
498 env_rp_implementation env skey injected
499 in
500 let rp_ips = [ BslLanguage.js, filename, parsed_t, implementation ] in
501 let rp = { BslPluginInterface.
502 rp_ks = rp_ks ;
503 rp_ty = rp_ty ;
504 rp_ips = rp_ips ;
505 rp_obj = None ;
506 } in
507 let key = BslKey.normalize (String.concat "." rp_ks) |> BslKey.to_string in
508 let source_option =
509 match source_implementation with
510 | None -> ""
511 | Some source -> " \\ "^source^" "
512 in
513 let js_file = FBuffer.printf js_file "/* %s%s : @[%a@] */\n" (String.concat "." rp_ks) source_option BslTypes.pp bslty in
514
515 let js_file = FBuffer.printf js_file "/* resolution: %%%%%s%%%% --> %s */\n" key implementation in
516 let () = SeparatedEnv.SideEffect.add_renaming key implementation in
517 let env = {env with renaming = StringMap.add key implementation env.renaming } in
518 BslPluginInterface.apply_register_primitive dynloader_interface.BslPluginInterface.register_primitive rp ;
519 env, js_file
520
521 | D.Args (name, args, _bslty) ->
522 (* BslTypes.pp bslty *)
523 let print_args li = String.concat ", " li in
524 let argsname = List.map fst args in
525 let funname = env_rp_implementation env name false in
526 let js_file = FBuffer.printf js_file "function %s (%s)\n" funname (print_args argsname) in
527 env, js_file
528
529 | D.Property _ ->
530 (* keep coherence for line count in the js *)
531 let js_file = FBuffer.add js_file "\n" in
532 env, js_file
533 )
534 in
535 env, js_file
536
537
538 let env_add_file_line ~filename env js_file =
539 let js_file = FBuffer.printf js_file "// file %S, line 1@\n" filename in
540 js_file, env
541
542
543 let fold_decorated_file ~dynloader_interface env decorated_file =
544 let filename = decorated_file.D.filename in
545 let source = decorated_file.D.decorated_source in
546 let implementation = js_module_of_filename filename in
547 (* we add a module for each file *)
548 let env = env_add_module nopos implementation None env in
549 (* For each file, we create a FBuffer, updated in a fold on decorated lines *)
550 let js_file = fbuffer () in
551 let js_file, env = env_add_file_line ~filename env js_file in
552
553 let env, js_file =
554 List.fold_left (fold_source_elt ~dynloader_interface ~filename) (env, js_file) source
555 in
556 let js_code = FBuffer.contents js_file in
557 let file_js_code = filename, js_code in
558 let rev_files_js_code = env.rev_files_js_code in
559 let rev_files_js_code = file_js_code :: rev_files_js_code in
560 let env = { env with rev_files_js_code = rev_files_js_code } in
561 let env = env_add_endmodule nopos env in
562 let _ =
563 match env.rev_path with
564 | [] -> ()
565 | list ->
566 let list = List.rev (List.tl (List.rev list)) in
567 List.iter (
568 fun (_, _, pos) ->
569 OManager.printf "%a" FilePos.pp_citation pos ;
570 ) list;
571 OManager.error
572 "File %S: unclosed module(s)@\n@[<2>@{<bright>Hint@}:@\nAdd the corresponding @{<bright>##endmodule@}@]@\n"
573 filename
574 in
575 env
576
577
578 let preprocess ~options ~plugins ~dynloader_interface ~depends decorated_files =
579 let env = empty in
580 let sep_env = SeparatedEnv.init ~ty_spec_map:env.ty_spec_map ~renaming:env.renaming in
581 let sep_env = List.fold_left SeparatedEnv.fold sep_env plugins in
582 let ty_spec_map = SeparatedEnv.ty_spec_map sep_env in
583 let renaming = SeparatedEnv.renaming sep_env in
584 let env = {
585 env with
586 ty_spec_map ;
587 renaming ;
588 } in
589 let env =
590 List.fold_left (fold_decorated_file ~dynloader_interface) env decorated_files in
591 let files_js_code = List.rev env.rev_files_js_code in
592
593 check ~options ~depends files_js_code ;
594
595 let javascript_env = SeparatedEnv.SideEffect.get_javascript_env () in
596 javascript_env, files_js_code
Something went wrong with that request. Please try again.