Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 715 lines (624 sloc) 21.435 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
6 Opa is free software: you can redistribute it and/or modify it under the
fccc685 Initial open-source release
MLstate authored
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
10 Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc685 Initial open-source release
MLstate authored
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
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
16 along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc685 Initial open-source release
MLstate authored
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
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to dis...
OpaOnWindowsNow authored
136 | SA.PatAs (_,n) -> Some n.SA.ident
fccc685 Initial open-source release
MLstate authored
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
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
175 introduced by the first part (pass_AddDocApiDirectives).
fccc685 Initial open-source release
MLstate authored
176
177 It returns the filtered annotmap, and collect all the decorated path,
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
178 in the form of an assoc list, binding paths of decorated elements
179 with their label (so that we can find their types and position)
fccc685 Initial open-source release
MLstate authored
180 *)
181 let remove_code_doctype annotmap (qmlAst : QmlAst.code) :
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
182 (QmlAst.annotmap * (string list * QmlAst.expr * QmlAst.doctype_access_directive * QmlAst.doctype_info list) list) * QmlAst.code
fccc685 Initial open-source release
MLstate authored
183 =
184 let rec remove_expr_doctype (annotmap, acc) e =
185 match e with
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
186 | Q.Directive (label, `doctype (path, access, info), [sube], []) ->
fccc685 Initial open-source release
MLstate authored
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
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
210 ((annotmap, (path, sube, access, info) :: acc), sube)
fccc685 Initial open-source release
MLstate authored
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 = {
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
241 value_args : string list;
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
242 value_is_module : bool ;
243 value_opacapi : bool ;
fccc685 Initial open-source release
MLstate authored
244 value_ty : ty ;
245 value_visibility : QmlAst.doctype_access_directive ;
246 }
247
248 (**
249 <!> In opa, the fields contained in the type defs are flattened.
250 We keep it like this to possibly export for opadoc more infos
251 than infos contained in the QmlAst.typedef
252 *)
253 type type_def = {
254 type_def : QmlAst.typedef
255 }
256
257 type code_elt =
258 | Value of value
259 | Type of type_def
260
261 type file = string
262 type pos = int
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
263 type line = int
fccc685 Initial open-source release
MLstate authored
264
265 type entry = {
266 pkg : pkg ;
267 path : path ;
268 code_elt : code_elt ;
269 fname : file ;
270 pos : pos ;
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
271 line : line ;
fccc685 Initial open-source release
MLstate authored
272 }
273
274 module Entry :
275 sig
276
277 (**
278 Build a value type from collected informations
279 *)
280
281 (**
282 Values
283 *)
284 val value :
285 gamma:QmlTypes.gamma ->
286 annotmap:QmlAst.annotmap ->
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
287 (string list * QmlAst.expr * QmlAst.doctype_access_directive * QmlAst.doctype_info list -> entry)
fccc685 Initial open-source release
MLstate authored
288
289 (**
290 Types definitions
291 *)
292 val type_def :
293 gamma:QmlTypes.gamma ->
294 annotmap:QmlAst.annotmap ->
295 (Ident.t SA.typedef -> entry)
296
297 (**
298 Pretty printing api-txt (for debuging)
299 *)
300 val pp : Format.formatter -> entry -> unit
301 end =
302 struct
303
304 let make_entry () =
305 let pkg = ObjectFiles.get_current_package_name () in
306 let make ~path ~filepos ~code_elt =
307 let fname = FilePos.get_file filepos in
308 let pos = FilePos.get_first_char filepos in
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
309 let line = try snd(FilePos.get_line fname pos) with _ -> (-1) in
fccc685 Initial open-source release
MLstate authored
310 let entry = {
311 pkg ;
312 path ;
313 code_elt ;
314 fname ;
315 pos ;
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
316 line ;
fccc685 Initial open-source release
MLstate authored
317 } in
318 entry
319 in
320 make
321
322 let value ~gamma:_ ~annotmap =
323 let make_entry = make_entry () in
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
324 let value (path, expr, visibility, _info) =
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
325 let label = QmlAst.Label.expr expr in
fccc685 Initial open-source release
MLstate authored
326 let filepos = Annot.pos label in
327 let annot = Annot.annot label in
328 let ty = QmlAnnotMap.find_ty annot annotmap in
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
329 let args =
330 match ty with
331 | Q.TypeArrow(_, _) ->
332 begin match expr with
333 | Q.Lambda(_, args, _) ->
334 List.map Ident.original_name args
335 | _ -> []
336 end
337 | _ -> []
338 in
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
339 let rec is_module expr =
340 match expr with
341 | QmlAst.Directive (_, `module_, [_e], _) -> true
342 | QmlAst.Directive (_, `doctype(_, _, l), [_e], _) -> List.mem `module_ l
343 | QmlAst.Directive (_, _, [e], _) -> is_module e
344 | QmlAst.Lambda (_, _, e) -> is_module e
345 | QmlAst.LetIn (_, _, e) -> is_module e
346 | _ -> false
347 in
348 let is_module = is_module expr in
349 let opacapi =
350 match expr with
351 | QmlAst.Directive (_, `doctype(_, _, l), [_e], _) -> List.mem `opacapi l
352 | _ -> false
353 in
fccc685 Initial open-source release
MLstate authored
354 let code_elt = Value {
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
355 value_args = args ;
fccc685 Initial open-source release
MLstate authored
356 value_ty = ty ;
357 value_visibility = visibility ;
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
358 value_is_module = is_module ;
359 value_opacapi = opacapi
fccc685 Initial open-source release
MLstate authored
360 } in
361 make_entry ~path ~filepos ~code_elt
362 in
363 value
364
365 let type_def ~gamma:_ ~annotmap:_ =
366 let make_entry = make_entry () in
367 let type_ typedef =
368 let typedef, loc = typedef in
369 let filepos = loc.QmlLoc.pos in
370 let SA.Typeident ident = typedef.SA.ty_def_name in
371 let ident = Ident.original_name ident in
372 let path = [ ident ] in
373 let typedef = OpaToQml.UidsOpaToQml.typedef typedef in
374 let code_elt = Type {
375 type_def = typedef ;
376 } in
377 make_entry ~path ~filepos ~code_elt
378 in
379 type_
380
381 let pp_path_elt fmt elt =
382 let elt =
383 if String.length elt > 0 && Char.is_alpha elt.[0] && String.is_word elt
384 then elt
385 else "`" ^ elt ^ "`"
386 in
387 Format.pp_print_string fmt elt
388
389 let pp_light_ident = new QmlPrint.light_ident_printer
390
391 let pp_value_visibility fmt = function
392 | `public -> ()
393 | `private_ -> Format.pp_print_string fmt "@private "
394 | `package -> Format.pp_print_string fmt "@package "
395
396 let pp_value fmt path value =
397 let visibility = value.value_visibility in
398 let ty = value.value_ty in
399 Format.fprintf fmt
400 "%a%a : %a@\n@\n"
401 pp_value_visibility visibility
402 (Format.pp_list "." pp_path_elt) path
403 pp_light_ident#ty_new_scope ty
404
405 let pp_type fmt type_def =
406 pp_light_ident#reset_typevars ;
407 let typedef = type_def.type_def in
408 Format.fprintf fmt
409 "%a@\n@\n"
410 pp_light_ident#typedef typedef
411
412 let pp fmt entry =
413 match entry.code_elt with
414 | Value value -> pp_value fmt entry.path value
415 | Type type_def -> pp_type fmt type_def
416 end
417 end
418
419
420 (**
421 Json serialization, from Api structure (module above) to Json structures
422 ready to be loaded by opa.
423 *)
424 module Serialize :
425 sig
426 val entry :
427 gamma:QmlTypes.gamma ->
428 annotmap:QmlAst.annotmap ->
429 (Api.entry -> JsonTypes.json)
430 end =
431 struct
432 module J = JsonTypes
433
434 let string s = J.String s
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
435 let bool b = J.Bool b
fccc685 Initial open-source release
MLstate authored
436 let pkg pkg = J.String pkg
437 let file file = J.String file
438 let pos pos = J.Int pos
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
439 let line line = J.Int line
fccc685 Initial open-source release
MLstate authored
440 let path path = J.Array (List.map string path)
441
442 (**
443 Given a Qml Expression representing an OpaTy.ty (runtime type ast),
444 returns its serialized version (json)
445 *)
446 let rec opaty_to_json expr =
447 match expr with
448 | Q.Coerce (_, expr, _ty) -> opaty_to_json expr
449 | Q.Const (_, (Q.String s)) -> string s
450 | Q.Directive (_, `tagged_string (tyname, _kind), [], []) -> string tyname
451 | Q.Record (_, fields) ->
452 let fold acc (field, expr) =
453 (field, opaty_to_json expr) :: acc
454 in
455 let fields = List.sort (fun (s1, _) (s2, _) -> String.compare s2 s1) fields in
456 J.Record (List.fold_left fold [] (List.rev fields))
457 | _ -> OManager.i_error "Unexpected expr in opaty_to_json: %a@." QmlPrint.pp#expr expr
458
459
460 class serializer ~gamma ~annotmap =
461 let ty_to_opaty_for_opadoc =
462 Pass_ExplicitInstantiation.ty_to_opaty_for_opadoc
463 ~val_:OpaMapToIdent.val_
464 ~gamma
465 ~annotmap
466 in
467 object(self)
468
469 val gamma = gamma
470 val annotmap = annotmap
471
472 (** Variables scope for type variables *)
473 val typevar_scope = QmlTypeVars.TypeVarPrint.new_scope ()
474 val rowvar_scope = QmlTypeVars.RowVarPrint.new_scope ()
475 val colvar_scope = QmlTypeVars.ColVarPrint.new_scope ()
476
477 method reset_typevars =
478 QmlTypeVars.TypeVarPrint.reset typevar_scope ;
479 QmlTypeVars.RowVarPrint.reset rowvar_scope ;
480 QmlTypeVars.ColVarPrint.reset colvar_scope ;
481 ()
482
483 method typevar var = QmlTypeVars.TypeVarPrint.get typevar_scope var
484 method rowvar var = QmlTypeVars.RowVarPrint.get rowvar_scope var
485 method colvar var = QmlTypeVars.ColVarPrint.get colvar_scope var
486
487 (**
488 Given a Qml Types, and typer environment, transform it into a runtime type expression.
489
490 This use a normalization specialized for the documentation, preserving original names when
491 there are some provided, and generated pretty names ('a, 'b, 'c, etc.) when there
492 is no name provided.
493 This is a normalization at compile time.
494 *)
495 method ty ty =
496 let ty = ty_to_opaty_for_opadoc typevar_scope rowvar_scope colvar_scope ty in
497 opaty_to_json ty
498
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
499 method args args = J.Array (List.map string args)
500
fccc685 Initial open-source release
MLstate authored
501 method visibility (vis : QmlAst.doctype_access_directive) =
502 (*
503 <!> keep synchronized with opa names, cf OpaDocTy
504 *)
505 let field =
506 match vis with
507 | `private_ -> "private"
508 | `public -> "public"
509 | `package -> "package_"
510 in
511 J.Record [
512 field, J.Void ;
513 ]
514
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
515 method is_module im = bool im
516
517 method opacapi o = bool o
518
fccc685 Initial open-source release
MLstate authored
519 method value v =
520 (*
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
521 <!> Opa magic serialize, reverse of alphabetic order between fields
fccc685 Initial open-source release
MLstate authored
522 *)
523 J.Record [
524 "visibility", self#visibility v.Api.value_visibility ;
525 "ty", self#ty v.Api.value_ty ;
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
526 "opacapi", self#opacapi v.Api.value_opacapi ;
527 "is_module", self#is_module v.Api.value_is_module ;
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
528 "args", self#args v.Api.value_args ;
fccc685 Initial open-source release
MLstate authored
529 ]
530
531 (*
532 FIXME:
533 currently, the representation of type def is a tuple Api.ty * Api.ty
534 in opadoc, which is not extensible enough to cover directives, and visibility.
535 This will change for a record containing visibility informations.
536 *)
537 method type_def type_def =
538 let type_def = type_def.Api.type_def in
539 let name =
540 string
541 (Q.TypeIdent.to_string type_def.QmlAst.ty_def_name)
542 in
543 let params =
544 let param tyvar = string (self#typevar tyvar) in
545 let params = List.map param type_def.QmlAst.ty_def_params in
546 JsonTypes.Array params
547 in
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
548 let opacapi = bool type_def.QmlAst.ty_def_options.QmlAst.opacapi in
fccc685 Initial open-source release
MLstate authored
549 let visibility =
550 match type_def.QmlAst.ty_def_visibility with
551 | Q.TDV_public ->
552 J.Record [
553 "TDV_public", J.Void ;
554 ]
555 | Q.TDV_abstract package_name ->
556 J.Record [
557 "TDV_abstract", string package_name ;
558 ]
559 | Q.TDV_private package_name ->
560 J.Record [
561 "TDV_private", string package_name ;
562 ]
563 in
564 let body = self#ty type_def.QmlAst.ty_def_body in
565 (*
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
566 <!> Opa magic serialize, reverse of alphabetic order between fields
fccc685 Initial open-source release
MLstate authored
567 *)
568 let tuple = JsonTypes.Record [
569 "ty_def_visibility", visibility ;
570 "ty_def_params", params ;
2009fdd @Aqua-Ye [enhance] opadoc: added opacapi field for type_def
Aqua-Ye authored
571 "ty_def_opacapi", opacapi ;
fccc685 Initial open-source release
MLstate authored
572 "ty_def_name", name ;
573 "ty_def_body", body ;
574 ] in
575 tuple
576
577 method code_elt api =
578 match api with
579 | Api.Value value ->
580 J.Record [
581 "value", self#value value ;
582 ]
583
584 | Api.Type type_def ->
585 J.Record [
586 "type_def", self#type_def type_def ;
587 ]
588
589 method entry e =
590 (*
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
591 <!> Opa magic serialize, reverse of alphabetic order between fields
fccc685 Initial open-source release
MLstate authored
592 *)
593 J.Record [
594 "pos", pos e.Api.pos ;
595 "pkg", pkg e.Api.pkg ;
596 "path", path e.Api.path ;
069836f @Aqua-Ye [enhance] api: improved api doc by adding line info to api entry
Aqua-Ye authored
597 "line", line e.Api.line ;
fccc685 Initial open-source release
MLstate authored
598 "fname", file e.Api.fname ;
599 "code_elt", self#code_elt e.Api.code_elt ;
600 ]
601 end
602
603 let entry ~gamma ~annotmap =
604 let serializer = new serializer ~gamma ~annotmap in
605 let map entry =
606 (*
607 The scope of type variables is reset between each new entry
608 *)
609 serializer#reset_typevars ;
610 serializer#entry entry
611 in
612 map
613
614 end
615
616 (**
617 Print an error if a filename cannot be created
618 *)
619 let on_error filename error =
620 match error with
621 | None -> ()
622 | Some msg ->
623 OManager.error (
624 "cannot output file %S@\n"^^
625 "@[<2>@{<bright>Hint@}:@\n"^^
626 "%s@]"
627 ) filename msg
628
629 (**
630 FileMap:
631 A polymorphic map for storing a list of 'a associated to a filename
632 *)
633 module FileMap = ListMap.Make(Order.String)
634
635 (**
636 Process the qml code, meaning remove the previously inserted doctypes directives,
637 and generate api files (opadoc), as well as humain readable api-txt files (for debug)
638 *)
639 let process_qml ~(options : E.opa_options)
640 (env : 'tmp_env Passes.env_Gen) : 'tmp_env Passes.env_Gen =
641 let annotmap = env.P.typerEnv.QmlTypes.annotmap in
642 let gamma = env.P.typerEnv.QmlTypes.gamma in
643
644 let make_value = Api.Entry.value ~gamma ~annotmap in
645 let make_type_def = Api.Entry.type_def ~gamma ~annotmap in
646
647 (*
648 Remove `doctype directives, filter annotmap, and collect doc values
649 *)
650 let ((annotmap, coll), qmlAst) = remove_code_doctype annotmap env.P.qmlAst in
651
652 (* OUTPUTS *)
653 if options.E.generate_interface || options.E.generate_interface_and_compile then (
654
655 (*
656 Construct the map filenames --> data
657 *)
658 let byfile = FileMap.empty in
659
660 (*
661 1. add Value data, collected by [remove_code_doctype]
662 *)
663 let byfile =
664 List.fold_left
4495235 @Aqua-Ye [enhance] opadoc, surfaceAst, qmlAst: transfer opacapi and module info f...
Aqua-Ye authored
665 (fun byfile ((_, expr, _, _) as value) ->
2384a5f @Aqua-Ye [enhance] api: improved api info by giving the complete QmlAst.expr inst...
Aqua-Ye authored
666 let label = QmlAst.Label.expr expr in
fccc685 Initial open-source release
MLstate authored
667 let filename = FilePos.get_file (Annot.pos label) in
668 let entry = make_value value in
669 FileMap.append filename entry byfile)
670 byfile coll
671 in
672
673 (*
674 2. add Type data, from doc_types stored in the environment
675 *)
676 let byfile =
677 List.fold_left
678 (fun byfile ((_, a) as typedef) ->
679 let filename = FilePos.get_file a.QmlLoc.pos in
680 let entry = make_type_def typedef in
681 FileMap.append filename entry byfile)
682 byfile (List.rev env.P.doc_types)
683 in
684
685 (* JSON OUTPUT *)
686 let entry_to_json = Serialize.entry ~gamma ~annotmap in
687 FileMap.iter (fun file entries ->
688 let filename = file ^ ".api" in
689 let jsonl = JsonTypes.Array (List.tail_map entry_to_json entries) in
690 OManager.verbose "generating %S" filename ;
691 let error = File.oc_output filename JsonPrint.Output.json jsonl in
692 on_error filename error ;
693 ) byfile ;
694
695 (* HUMAN OUTPUT *)
696 FileMap.iter (fun file entries ->
697 let filename = file ^ ".api-txt" in
698 OManager.verbose "generating %S" filename ;
699 let error = File.pp_output filename (Format.pp_list "" Api.Entry.pp) entries in
700 on_error filename error ;
701 ) byfile ;
702
703 (* EXITING PASS *)
704 if not options.E.generate_interface_and_compile then
705 exit 0
706
707 );
708
709 { env with Passes.
710 qmlAst = qmlAst;
711 typerEnv = { env.P.typerEnv with
712 QmlTypes.annotmap = annotmap;
713 };
714 }
Something went wrong with that request. Please try again.