Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 664 lines (576 sloc) 19.737 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 (* depends in base *)
19 module Char = BaseChar
20 module Format = BaseFormat
21 module List = BaseList
22 module String = BaseString
23
24 let (|>) = InfixOperator.(|>)
25
26 (* refactoring in progress *)
27
28 (* shorthands *)
29 module E = OpaEnv
30 module P = Passes
31 module SA = SurfaceAst
32 module Q = QmlAst
33
34 (* type alias for clarty *)
35 type filename = string
36 type pos = int
37 type path = string list
38
39 type short_coll = path * Annot.label
40 type collection = path * filename * pos * QmlAst.ty
41
42
43 (*
44 traversed directive for finding fields of a module from a toplevel value
45 to add doc type api directives
46 *)
47 type ('a, 'b, 'c) traversed_directive = [
48 | `coerce
49 | `deprecated
50 | `local of 'a
51 | Q.slicer_directive
52 ]
53
54 (**
55 Merge access directive
56 *)
57 let merge_access (acc : SurfaceAst.access_directive) ( dir : SurfaceAst.access_directive ) : SurfaceAst.access_directive =
58 match acc, dir with
59 | `private_, _ -> acc
60 | _, `private_ -> dir
61 | `package, _ -> acc
62 | _, `package -> dir
63 | _ -> acc
64
65 (**
66 extract annotation type of top-level values and type of their eventual fields
67 (if the final expression of the top level value is a record)
68 *)
69 let add_code_doctype sa_code =
70 let keep_local modify e =
71 match fst e with
72 | SA.Directive(`local _ as l,[e],c) -> SA.Directive(l, [modify e], c), snd e
73 | _ -> assert false
74 in
75 let final_expr_sub_1 main_e sube =
76 let main_e, annot = main_e in
77 (match main_e with
78 | SA.Lambda(z,_) -> SA.Lambda(z,sube)
79 | SA.Directive(z0,[_],z2) -> SA.Directive(z0,[sube],z2)
80 | SA.LetIn(b, z, _) -> SA.LetIn(b, z, sube)
81 | _ -> assert false
82 ), annot
83 in
84 (**
85 add doctype directives to sub modules fields,
86 and returns the accessibility of the toplevel expression
87 *)
88 let rec add_e_doctype access path e : SA.access_directive * (_, _) SA.expr =
89 match fst e with
90
91 (* access *)
92 | SA.Directive ((#SA.access_directive as sub_access), [ sube ], _) ->
93 let access = merge_access access sub_access in
94 let access, sube = add_e_doctype access path sube in
95 access, final_expr_sub_1 e sube
96
97 (* go through for finding fields of modules *)
98 | SA.Lambda(_, sube)
99 | SA.Directive (#traversed_directive, [ sube ], _)
100 ->
101 let access, sube = add_e_doctype access path sube in
102 access, final_expr_sub_1 e sube
103
104 (* collect here and recurse *)
105 | SA.LetIn(x, l, sube) ->
106 let access, sube = add_e_doctype access path sube in
107 access, (SA.LetIn(x, l, sube), (snd e))
108
109 | SA.Directive(`module_ , [SA.Record( fields ), annot],ty)
110 when SurfaceAstHelper.Record.is_module e ->
111 (* since module header can be rewritten , we collect the annot here *)
112 let new_record = SA.Record (
113 List.map (
114 fun (f,e) ->
115 let npath = path @ [f] in
116 #<If:OPADOC> OManager.printf "Adding %s@." (String.concat "." npath) #<End>;
117 let modify e =
118 let access, sube = add_e_doctype access npath e in
119 keep_local
120 (SurfaceAstCons.ExprIdentCons.D.doctype ~label:(snd e) ~access npath)
121 sube
122 in
123 (f, modify e)
124 ) fields )
125 in
126 access, (SA.Directive(`module_, [new_record, annot], ty), snd e)
127
128 (* ignore *)
129 | _ -> access, e
130 in
131 let rec add_patt_doctype ((name,e) as decl) =
132 let rec getname name =
133 match fst name with
134 | SA.PatCoerce (n,_) -> getname n
135 | SA.PatVar n
136 | SA.PatAs (_,n) -> Some n
137 | _ -> None
138 in
139 match getname name with
140 |Some n ->
141 let path = [Ident.original_name n] in
142 #<If:OPADOC> OManager.printf "Fold %s@." (Ident.original_name n) #<End>;
143 let access, sube = add_e_doctype `public path e in
144 name, (SurfaceAstCons.ExprIdentCons.D.doctype ~label:(snd e) ~access path) sube
145 | _ -> decl
146 in
147 List.tail_map
148 (function
149 | SA.NewVal (l, b), annot ->
150 SA.NewVal (List.map add_patt_doctype l, b), annot
151 | t -> t) sa_code
152
153 let collect_type_doctype sa_code =
154 List.rev (List.fold_left (fun acc -> function (SA.NewType tds, _) -> tds @ acc | _ -> acc) [] sa_code)
155
156
157 (**
158 output top-level value type description for opa-doc
159 *)
160 let process_opa ~(options : E.opa_options) env =
161 if options.E.generate_interface || options.E.generate_interface_and_compile then
162 { env with Passes.
163 sa_lcode = add_code_doctype env.P.sa_lcode ;
164 sa_doc_types = collect_type_doctype env.P.sa_lcode }
165 else env
166
167
168 (* =========================================================== *)
169 (* SECOND PART; OpaDocApiGeneration *)
170 (* =========================================================== *)
171
172
173 (**
174 This function filter the code, by removing [`doctype] diretives
175 introduced by the first part (pass_AddDocApiDirecitves).
176
177 It returns the filtered annotmap, and collect all the decorated path,
178 in the form of an assoc list, binding pathes of decorated elements
179 with there label (so that we can find their types and position)
180 *)
181 let remove_code_doctype annotmap (qmlAst : QmlAst.code) :
182 (QmlAst.annotmap * (string list * Annot.label * QmlAst.doctype_access_directive) list) * QmlAst.code
183 =
184 let rec remove_expr_doctype (annotmap, acc) e =
185 match e with
186 | Q.Directive (label, `doctype (path, access), [sube], []) ->
187 let annot_e = Annot.annot label in
188 let tsc_opt =
189 QmlAnnotMap.find_tsc_opt annot_e annotmap in
190 let tsc_inst_opt =
191 QmlAnnotMap.find_tsc_inst_opt annot_e annotmap in
192 let annotmap =
193 QmlAnnotMap.remove_tsc annot_e annotmap in
194 let annotmap =
195 QmlAnnotMap.remove_tsc_inst annot_e annotmap in
196 let sube_tsc_opt =
197 QmlAnnotMap.find_tsc_opt annot_e annotmap in
198 let sube_tsc_inst_opt =
199 QmlAnnotMap.find_tsc_inst_opt annot_e annotmap in
200 let tsc_opt =
201 Option.merge (fun _ _ -> assert false) tsc_opt sube_tsc_opt in
202 let tsc_inst_opt =
203 Option.merge
204 (fun _ _ -> assert false) tsc_inst_opt sube_tsc_inst_opt in
205 let annot_sube = QmlAst.QAnnot.expr sube in
206 let annotmap =
207 QmlAnnotMap.add_tsc_opt annot_sube tsc_opt annotmap in
208 let annotmap =
209 QmlAnnotMap.add_tsc_inst_opt annot_sube tsc_inst_opt annotmap in
210 ((annotmap, (path, (QmlAst.Label.expr sube), access) :: acc), sube)
211 | _ -> ((annotmap, acc), e) in
212 let remove_patt_doctype acc e =
213 QmlAstWalk.Expr.foldmap_down remove_expr_doctype acc e
214 in
215 QmlAstWalk.CodeExpr.fold_map remove_patt_doctype (annotmap, []) qmlAst
216
217
218 module Api =
219 struct
220
221 (**
222 This module defines the ocaml structures corresponding to the opa structures
223 defined in [opaDocTy.opa].
224
225 This is not a code duplication, but an easyer way to ensure than this pass
226 generates serialized values corresponding to the value defined in opa.
227
228 The documentation of these types is in the opa code.
229 *)
230
231 type ty = QmlAst.ty
232
233 type pkg = string
234
235 type path = string list
236
237 (**
238 <!> The fields are there prefixed by ["value_"] but not in opa
239 *)
240 type value = {
241 value_ty : ty ;
242 value_visibility : QmlAst.doctype_access_directive ;
243 }
244
245 (**
246 <!> In opa, the fields contained in the type defs are flattened.
247 We keep it like this to possibly export for opadoc more infos
248 than infos contained in the QmlAst.typedef
249 *)
250 type type_def = {
251 type_def : QmlAst.typedef
252 }
253
254 type code_elt =
255 | Value of value
256 | Type of type_def
257
258 type file = string
259 type pos = int
260
261 type entry = {
262 pkg : pkg ;
263 path : path ;
264 code_elt : code_elt ;
265 fname : file ;
266 pos : pos ;
267 }
268
269 module Entry :
270 sig
271
272 (**
273 Build a value type from collected informations
274 *)
275
276 (**
277 Values
278 *)
279 val value :
280 gamma:QmlTypes.gamma ->
281 annotmap:QmlAst.annotmap ->
282 (string list * Annot.label * QmlAst.doctype_access_directive -> entry)
283
284 (**
285 Types definitions
286 *)
287 val type_def :
288 gamma:QmlTypes.gamma ->
289 annotmap:QmlAst.annotmap ->
290 (Ident.t SA.typedef -> entry)
291
292 (**
293 Pretty printing api-txt (for debuging)
294 *)
295 val pp : Format.formatter -> entry -> unit
296 end =
297 struct
298
299 let make_entry () =
300 let pkg = ObjectFiles.get_current_package_name () in
301 let make ~path ~filepos ~code_elt =
302 let fname = FilePos.get_file filepos in
303 let pos = FilePos.get_first_char filepos in
304 let entry = {
305 pkg ;
306 path ;
307 code_elt ;
308 fname ;
309 pos ;
310 } in
311 entry
312 in
313 make
314
315 let value ~gamma:_ ~annotmap =
316 let make_entry = make_entry () in
317 let value (path, label, visibility) =
318 let filepos = Annot.pos label in
319 let annot = Annot.annot label in
320 let ty = QmlAnnotMap.find_ty annot annotmap in
321 let code_elt = Value {
322 value_ty = ty ;
323 value_visibility = visibility ;
324 } in
325 make_entry ~path ~filepos ~code_elt
326 in
327 value
328
329 let type_def ~gamma:_ ~annotmap:_ =
330 let make_entry = make_entry () in
331 let type_ typedef =
332 let typedef, loc = typedef in
333 let filepos = loc.QmlLoc.pos in
334 let SA.Typeident ident = typedef.SA.ty_def_name in
335 let ident = Ident.original_name ident in
336 let path = [ ident ] in
337 let typedef = OpaToQml.UidsOpaToQml.typedef typedef in
338 let code_elt = Type {
339 type_def = typedef ;
340 } in
341 make_entry ~path ~filepos ~code_elt
342 in
343 type_
344
345 let pp_path_elt fmt elt =
346 let elt =
347 if String.length elt > 0 && Char.is_alpha elt.[0] && String.is_word elt
348 then elt
349 else "`" ^ elt ^ "`"
350 in
351 Format.pp_print_string fmt elt
352
353 let pp_light_ident = new QmlPrint.light_ident_printer
354
355 let pp_value_visibility fmt = function
356 | `public -> ()
357 | `private_ -> Format.pp_print_string fmt "@private "
358 | `package -> Format.pp_print_string fmt "@package "
359
360 let pp_value fmt path value =
361 let visibility = value.value_visibility in
362 let ty = value.value_ty in
363 Format.fprintf fmt
364 "%a%a : %a@\n@\n"
365 pp_value_visibility visibility
366 (Format.pp_list "." pp_path_elt) path
367 pp_light_ident#ty_new_scope ty
368
369 let pp_type fmt type_def =
370 pp_light_ident#reset_typevars ;
371 let typedef = type_def.type_def in
372 Format.fprintf fmt
373 "%a@\n@\n"
374 pp_light_ident#typedef typedef
375
376 let pp fmt entry =
377 match entry.code_elt with
378 | Value value -> pp_value fmt entry.path value
379 | Type type_def -> pp_type fmt type_def
380 end
381 end
382
383
384 (**
385 Json serialization, from Api structure (module above) to Json structures
386 ready to be loaded by opa.
387 *)
388 module Serialize :
389 sig
390 val entry :
391 gamma:QmlTypes.gamma ->
392 annotmap:QmlAst.annotmap ->
393 (Api.entry -> JsonTypes.json)
394 end =
395 struct
396 module J = JsonTypes
397
398 let string s = J.String s
399 let pkg pkg = J.String pkg
400 let file file = J.String file
401 let pos pos = J.Int pos
402 let path path = J.Array (List.map string path)
403
404 (**
405 Given a Qml Expression representing an OpaTy.ty (runtime type ast),
406 returns its serialized version (json)
407 *)
408 let rec opaty_to_json expr =
409 match expr with
410 | Q.Coerce (_, expr, _ty) -> opaty_to_json expr
411 | Q.Const (_, (Q.String s)) -> string s
412 | Q.Directive (_, `tagged_string (tyname, _kind), [], []) -> string tyname
413 | Q.Record (_, fields) ->
414 let fold acc (field, expr) =
415 (field, opaty_to_json expr) :: acc
416 in
417 let fields = List.sort (fun (s1, _) (s2, _) -> String.compare s2 s1) fields in
418 J.Record (List.fold_left fold [] (List.rev fields))
419 | _ -> OManager.i_error "Unexpected expr in opaty_to_json: %a@." QmlPrint.pp#expr expr
420
421
422 class serializer ~gamma ~annotmap =
423 let ty_to_opaty_for_opadoc =
424 Pass_ExplicitInstantiation.ty_to_opaty_for_opadoc
425 ~val_:OpaMapToIdent.val_
426 ~gamma
427 ~annotmap
428 in
429 object(self)
430
431 val gamma = gamma
432 val annotmap = annotmap
433
434 (** Variables scope for type variables *)
435 val typevar_scope = QmlTypeVars.TypeVarPrint.new_scope ()
436 val rowvar_scope = QmlTypeVars.RowVarPrint.new_scope ()
437 val colvar_scope = QmlTypeVars.ColVarPrint.new_scope ()
438
439 method reset_typevars =
440 QmlTypeVars.TypeVarPrint.reset typevar_scope ;
441 QmlTypeVars.RowVarPrint.reset rowvar_scope ;
442 QmlTypeVars.ColVarPrint.reset colvar_scope ;
443 ()
444
445 method typevar var = QmlTypeVars.TypeVarPrint.get typevar_scope var
446 method rowvar var = QmlTypeVars.RowVarPrint.get rowvar_scope var
447 method colvar var = QmlTypeVars.ColVarPrint.get colvar_scope var
448
449 (**
450 Given a Qml Types, and typer environment, transform it into a runtime type expression.
451
452 This use a normalization specialized for the documentation, preserving original names when
453 there are some provided, and generated pretty names ('a, 'b, 'c, etc.) when there
454 is no name provided.
455 This is a normalization at compile time.
456 *)
457 method ty ty =
458 let ty = ty_to_opaty_for_opadoc typevar_scope rowvar_scope colvar_scope ty in
459 opaty_to_json ty
460
461 method visibility (vis : QmlAst.doctype_access_directive) =
462 (*
463 <!> keep synchronized with opa names, cf OpaDocTy
464 *)
465 let field =
466 match vis with
467 | `private_ -> "private"
468 | `public -> "public"
469 | `package -> "package_"
470 in
471 J.Record [
472 field, J.Void ;
473 ]
474
475 method value v =
476 (*
477 <!> OPA magic serialize, reverse of alphabetic order between fields
478 *)
479 J.Record [
480 "visibility", self#visibility v.Api.value_visibility ;
481 "ty", self#ty v.Api.value_ty ;
482 ]
483
484 (*
485 FIXME:
486 currently, the representation of type def is a tuple Api.ty * Api.ty
487 in opadoc, which is not extensible enough to cover directives, and visibility.
488 This will change for a record containing visibility informations.
489 *)
490 method type_def type_def =
491 let type_def = type_def.Api.type_def in
492 let name =
493 string
494 (Q.TypeIdent.to_string type_def.QmlAst.ty_def_name)
495 in
496 let params =
497 let param tyvar = string (self#typevar tyvar) in
498 let params = List.map param type_def.QmlAst.ty_def_params in
499 JsonTypes.Array params
500 in
501 let visibility =
502 match type_def.QmlAst.ty_def_visibility with
503 | Q.TDV_public ->
504 J.Record [
505 "TDV_public", J.Void ;
506 ]
507 | Q.TDV_abstract package_name ->
508 J.Record [
509 "TDV_abstract", string package_name ;
510 ]
511 | Q.TDV_private package_name ->
512 J.Record [
513 "TDV_private", string package_name ;
514 ]
515 in
516 let body = self#ty type_def.QmlAst.ty_def_body in
517 (*
518 <!> OPA magic serialize, reverse of alphabetic order between fields
519 *)
520 let tuple = JsonTypes.Record [
521 "ty_def_visibility", visibility ;
522 "ty_def_params", params ;
523 "ty_def_name", name ;
524 "ty_def_body", body ;
525 ] in
526 tuple
527
528 method code_elt api =
529 match api with
530 | Api.Value value ->
531 J.Record [
532 "value", self#value value ;
533 ]
534
535 | Api.Type type_def ->
536 J.Record [
537 "type_def", self#type_def type_def ;
538 ]
539
540 method entry e =
541 (*
542 <!> OPA magic serialize, reverse of alphabetic order between fields
543 *)
544 J.Record [
545 "pos", pos e.Api.pos ;
546 "pkg", pkg e.Api.pkg ;
547 "path", path e.Api.path ;
548 "fname", file e.Api.fname ;
549 "code_elt", self#code_elt e.Api.code_elt ;
550 ]
551 end
552
553 let entry ~gamma ~annotmap =
554 let serializer = new serializer ~gamma ~annotmap in
555 let map entry =
556 (*
557 The scope of type variables is reset between each new entry
558 *)
559 serializer#reset_typevars ;
560 serializer#entry entry
561 in
562 map
563
564 end
565
566 (**
567 Print an error if a filename cannot be created
568 *)
569 let on_error filename error =
570 match error with
571 | None -> ()
572 | Some msg ->
573 OManager.error (
574 "cannot output file %S@\n"^^
575 "@[<2>@{<bright>Hint@}:@\n"^^
576 "%s@]"
577 ) filename msg
578
579 (**
580 FileMap:
581 A polymorphic map for storing a list of 'a associated to a filename
582 *)
583 module FileMap = ListMap.Make(Order.String)
584
585 (**
586 Process the qml code, meaning remove the previously inserted doctypes directives,
587 and generate api files (opadoc), as well as humain readable api-txt files (for debug)
588 *)
589 let process_qml ~(options : E.opa_options)
590 (env : 'tmp_env Passes.env_Gen) : 'tmp_env Passes.env_Gen =
591 let annotmap = env.P.typerEnv.QmlTypes.annotmap in
592 let gamma = env.P.typerEnv.QmlTypes.gamma in
593
594 let make_value = Api.Entry.value ~gamma ~annotmap in
595 let make_type_def = Api.Entry.type_def ~gamma ~annotmap in
596
597 (*
598 Remove `doctype directives, filter annotmap, and collect doc values
599 *)
600 let ((annotmap, coll), qmlAst) = remove_code_doctype annotmap env.P.qmlAst in
601
602 (* OUTPUTS *)
603 if options.E.generate_interface || options.E.generate_interface_and_compile then (
604
605 (*
606 Construct the map filenames --> data
607 *)
608 let byfile = FileMap.empty in
609
610 (*
611 1. add Value data, collected by [remove_code_doctype]
612 *)
613 let byfile =
614 List.fold_left
615 (fun byfile ((_, label, _) as value) ->
616 let filename = FilePos.get_file (Annot.pos label) in
617 let entry = make_value value in
618 FileMap.append filename entry byfile)
619 byfile coll
620 in
621
622 (*
623 2. add Type data, from doc_types stored in the environment
624 *)
625 let byfile =
626 List.fold_left
627 (fun byfile ((_, a) as typedef) ->
628 let filename = FilePos.get_file a.QmlLoc.pos in
629 let entry = make_type_def typedef in
630 FileMap.append filename entry byfile)
631 byfile (List.rev env.P.doc_types)
632 in
633
634 (* JSON OUTPUT *)
635 let entry_to_json = Serialize.entry ~gamma ~annotmap in
636 FileMap.iter (fun file entries ->
637 let filename = file ^ ".api" in
638 let jsonl = JsonTypes.Array (List.tail_map entry_to_json entries) in
639 OManager.verbose "generating %S" filename ;
640 let error = File.oc_output filename JsonPrint.Output.json jsonl in
641 on_error filename error ;
642 ) byfile ;
643
644 (* HUMAN OUTPUT *)
645 FileMap.iter (fun file entries ->
646 let filename = file ^ ".api-txt" in
647 OManager.verbose "generating %S" filename ;
648 let error = File.pp_output filename (Format.pp_list "" Api.Entry.pp) entries in
649 on_error filename error ;
650 ) byfile ;
651
652 (* EXITING PASS *)
653 if not options.E.generate_interface_and_compile then
654 exit 0
655
656 );
657
658 { env with Passes.
659 qmlAst = qmlAst;
660 typerEnv = { env.P.typerEnv with
661 QmlTypes.annotmap = annotmap;
662 };
663 }
Something went wrong with that request. Please try again.