]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/pxp/pxp/pxp_codewriter.ml
exported hbugsClient class so that it can be used from outside
[helm.git] / helm / DEVEL / pxp / pxp / pxp_codewriter.ml
1 (* $Id$
2  * ----------------------------------------------------------------------
3  * PXP: The polymorphic XML parser for Objective Caml.
4  * Copyright by Gerd Stolpmann. See LICENSE for details.
5  *)
6
7 open Pxp_document
8 open Pxp_yacc
9 open Pxp_dtd
10 open Pxp_types
11
12 let write_expr_ext_id out extid =
13   match extid with
14       System s ->
15         output_string out ("(Pxp_types.System\"" ^ String.escaped s ^ "\")")
16     | Public(s,t) ->
17         output_string out ("(Pxp_types.Public(\"" ^ String.escaped s ^ 
18                            "\",\"" ^
19                            String.escaped t ^ "\"))")
20     | Anonymous ->
21         output_string out "Pxp_types.Anonymous"
22 ;;
23
24
25 let rec write_expr_content_model out cm =
26   match cm with
27       Unspecified -> output_string out "Pxp_types.Unspecified"
28     | Empty       -> output_string out "Pxp_types.Empty"
29     | Any         -> output_string out "Pxp_types.Any"
30     | Mixed msl   -> output_string out "(Pxp_types.Mixed [";
31                      List.iter
32                        (fun ms ->
33                           write_expr_mixed_spec out ms;
34                           output_string out "; ";
35                        )
36                        msl;
37                      output_string out "])";
38     | Regexp re   -> output_string out "(Pxp_types.Regexp ";
39                      write_expr_regexp_spec out re;
40                      output_string out ")";
41
42 and write_expr_mixed_spec out ms =
43   match ms with
44       MPCDATA  -> output_string out "Pxp_types.MPCDATA"
45     | MChild s -> output_string out ("(Pxp_types.MChild \"" ^
46                                      String.escaped s ^ "\")")
47
48 and write_expr_regexp_spec out re =
49   match re with
50       Optional re'  -> output_string out "(Pxp_types.Optional ";
51                        write_expr_regexp_spec out re';
52                        output_string out ")";
53     | Repeated re'  -> output_string out "(Pxp_types.Repeated ";
54                        write_expr_regexp_spec out re';
55                        output_string out ")";
56     | Repeated1 re' -> output_string out "(Pxp_types.Repeated1 ";
57                        write_expr_regexp_spec out re';
58                        output_string out ")";
59     | Alt rel       -> output_string out "(Pxp_types.Alt [";
60                        List.iter
61                          (fun re' ->
62                             write_expr_regexp_spec out re';
63                             output_string out "; ";
64                          )
65                          rel;
66                        output_string out "])";
67     | Seq rel       -> output_string out "(Pxp_types.Seq [";
68                        List.iter
69                          (fun re' ->
70                             write_expr_regexp_spec out re';
71                             output_string out "; ";
72                          )
73                          rel;
74                        output_string out "])";
75     | Child s       -> output_string out ("(Pxp_types.Child \"" ^ 
76                                           String.escaped s ^ "\")")
77 ;;
78
79
80 let write_expr_att_type out at =
81   match at with
82       A_cdata       -> output_string out "Pxp_types.A_cdata"
83     | A_id          -> output_string out "Pxp_types.A_id"
84     | A_idref       -> output_string out "Pxp_types.A_idref"
85     | A_idrefs      -> output_string out "Pxp_types.A_idrefs"
86     | A_entity      -> output_string out "Pxp_types.A_entity"
87     | A_entities    -> output_string out "Pxp_types.A_entities"
88     | A_nmtoken     -> output_string out "Pxp_types.A_nmtoken"
89     | A_nmtokens    -> output_string out "Pxp_types.A_nmtokens"
90     | A_notation sl -> output_string out "(Pxp_types.A_notation [";
91                        List.iter
92                          (fun s ->
93                             output_string out ("\"" ^ 
94                                                String.escaped s ^ "\"; "))
95                          sl;
96                        output_string out "])";
97     | A_enum sl     -> output_string out "(Pxp_types.A_enum [";
98                        List.iter
99                          (fun s ->
100                             output_string out ("\"" ^ 
101                                                String.escaped s ^ "\"; "))
102                          sl;
103                        output_string out "])";
104 ;;
105
106
107 let write_expr_att_default out ad =
108   match ad with
109       D_required  -> output_string out "Pxp_types.D_required"
110     | D_implied   -> output_string out "Pxp_types.D_implied"
111     | D_default s -> output_string out ("(Pxp_types.D_default \"" ^
112                                         String.escaped s ^ "\")")
113     | D_fixed s   -> output_string out ("(Pxp_types.D_fixed \"" ^
114                                         String.escaped s ^ "\")")
115 ;;
116
117
118 let write_expr_att_value out av =
119   match av with
120       Value s       -> output_string out ("(Pxp_types.Value \"" ^
121                                           String.escaped s ^ "\")")
122     | Valuelist sl  -> output_string out ("(Pxp_types.Valuelist [");
123                        List.iter
124                          (fun s ->
125                             output_string out ("\"" ^ String.escaped s ^ 
126                                                "\"; ")
127                          )
128                          sl;
129                        output_string out "])";
130     | Implied_value -> output_string out "Pxp_types.Implied_value"
131 ;;
132
133
134 let ocaml_encoding enc =
135   match enc with
136       `Enc_utf8      -> "`Enc_utf8"
137     | `Enc_utf16     -> "`Enc_utf16"
138     | `Enc_utf16_le  -> "`Enc_utf16_le"
139     | `Enc_utf16_be  -> "`Enc_utf16_be"
140     | `Enc_iso88591  -> "`Enc_iso88591"
141 ;;
142
143
144 let write_expr_new_pi out pi =
145   output_string out ("(new Pxp_dtd.proc_instruction \"" ^
146                      String.escaped(pi # target) ^ "\" \"" ^
147                      String.escaped(pi # value) ^ "\" " ^ 
148                      ocaml_encoding(pi # encoding) ^ ")")
149 ;;
150
151
152 let write_expr_node_type out nt =
153   match nt with
154       T_data       -> output_string out "Pxp_document.T_data"
155     | T_element s  -> output_string out ("(Pxp_document.T_element \"" ^
156                                          String.escaped s ^ "\")")
157     | T_super_root -> output_string out "Pxp_document.T_super_root"
158     | T_pinstr s   -> output_string out ("(Pxp_document.T_pinstr \"" ^
159                                          String.escaped s ^ "\")")
160     | T_comment    -> output_string out "Pxp_document.T_comment"
161     | _            -> assert false
162 ;;
163
164
165 let write_local_dtd out (dtd : dtd) =
166   (* Outputs "let mkdtd warner = ... in" to 'out' *)
167   output_string out "let mkdtd warner =\n";
168   output_string out ("let encoding = " ^ ocaml_encoding (dtd # encoding) ^ 
169                      " in\n");
170   output_string out "let dtdobj = new Pxp_dtd.dtd warner encoding in\n";
171   
172   (* Set the ID: *)
173   output_string out "dtdobj # set_id ";
174   begin match dtd # id with
175       None -> ()
176     | Some(External x) -> 
177         output_string out "(Pxp_types.External ";
178         write_expr_ext_id out x;
179         output_string out ");\n"
180     | Some(Derived x) ->  
181         output_string out "(Pxp_types.Derived ";
182         write_expr_ext_id out x;
183         output_string out ");\n"
184     | Some Internal ->   
185         output_string out "Pxp_types.Internal;\n";
186   end;
187
188   (* Set standalone declaration: *)
189   output_string out ("dtdobj # set_standalone_declaration " ^
190                      string_of_bool (dtd # standalone_declaration) ^ ";\n");
191
192   (* Add notations: *)
193   List.iter
194     (fun noname ->
195        let no = dtd # notation noname in
196        output_string out ("let no = new Pxp_dtd.dtd_notation \"" ^
197                           String.escaped noname ^ "\" ");
198        write_expr_ext_id out (no # ext_id);
199        output_string out " encoding in\n";
200        output_string out "dtdobj # add_notation no;\n";
201     )
202     (List.sort Pervasives.compare (dtd # notation_names));
203
204   (* Add unparsed entities: *)
205   List.iter
206     (fun enname ->
207        let en, _ = dtd # gen_entity enname in
208        if en # is_ndata then begin
209          let ext_id = en # ext_id in
210          let notation = en # notation in
211          let encoding = en # encoding in
212          output_string out ("let ndata = new Pxp_entity.ndata_entity \"" ^
213                             String.escaped enname ^ "\" ");
214          write_expr_ext_id out ext_id;
215          output_string out ("\"" ^ String.escaped notation ^ "\" " ^ 
216                             ocaml_encoding encoding ^ " in \n");
217          output_string out "dtdobj # add_gen_entity (ndata :> Pxp_entity.entity) false;\n";
218        end;
219     )
220     (List.sort Pervasives.compare (dtd # gen_entity_names));
221
222
223   (* Add elements: *)
224   List.iter
225     (fun elname ->
226        (* Create the element 'el': *)
227        let el = dtd # element elname in
228        output_string out ("let el = new Pxp_dtd.dtd_element dtdobj \"" ^
229                           String.escaped elname ^ "\" in\n");
230        output_string out "let cm = ";
231        write_expr_content_model out (el # content_model);
232        output_string out " in\n";
233        output_string out "el # set_cm_and_extdecl cm false;\n";
234        (* Add attributes: *)
235        List.iter
236          (fun attname ->
237             let atttype, attdefault = el # attribute attname in
238             output_string out ("el # add_attribute \"" ^ 
239                                String.escaped attname ^ "\" ");
240             write_expr_att_type out atttype;
241             output_string out " ";
242             write_expr_att_default out attdefault;
243             output_string out " false;\n";
244          )
245          (List.sort Pervasives.compare (el # attribute_names));
246
247        (* Allow arbitrary? *)
248        if el # arbitrary_allowed then
249          output_string out "el # allow_arbitrary;\n"
250        else
251          output_string out "el # disallow_arbitrary;\n";
252
253        (* Validate: *)
254        output_string out "el # validate;\n";
255  
256        (* Add the element 'el' to 'dtdobj': *)
257        output_string out "dtdobj # add_element el;\n";
258     )
259     (List.sort Pervasives.compare (dtd # element_names));
260
261   (* Add processing instructions: *)
262   List.iter
263     (fun target ->
264        let pilist = dtd # pinstr target in
265        List.iter
266          (fun pi ->
267             output_string out "let pi = ";
268             write_expr_new_pi out pi;
269             output_string out " in\n";
270             output_string out "dtdobj # add_pinstr pi;\n";
271          )
272          pilist;
273     )
274     (List.sort Pervasives.compare (dtd # pinstr_names));
275
276   (* Set the name of the root element: *)
277   begin match dtd # root with
278       None -> ()
279     | Some rootname ->
280         output_string out ("dtdobj # set_root \"" ^
281                            String.escaped rootname ^ "\";\n")
282   end;
283
284   (* Special options: *)
285   if dtd # arbitrary_allowed then
286     output_string out "dtdobj # allow_arbitrary;\n"
287   else
288     output_string out "dtdobj # disallow_arbitrary;\n";
289
290   (* Return dtdobj: *)
291   output_string out "dtdobj in\n"
292 ;;
293
294
295 let rec write_local_subtree out n =
296   (* Outputs the term generating the subtree *)
297   
298   output_string out "let nt = ";
299   write_expr_node_type out (n # node_type);
300   output_string out " in\n";
301
302   begin match n # node_type with
303       T_data ->
304         output_string out ("let t = Pxp_document.create_data_node spec dtd \"" ^
305                            String.escaped (n # data) ^ "\" in\n")
306     | T_element elname ->
307         let loc, line, col = n # position in
308         output_string out
309           ("let pos = \"" ^ String.escaped loc ^ "\", " ^ 
310            string_of_int line ^ ", " ^ 
311            string_of_int col ^ " in\n");
312         output_string out 
313           ("let t = Pxp_document.create_element_node ~position:pos spec dtd \"" ^
314            String.escaped elname ^ "\" [ ");
315         List.iter
316           (fun (name,value) ->
317              begin match value with
318                  Value s -> 
319                    output_string out ("\"" ^ String.escaped name ^ "\", ");
320                    output_string out ("\"" ^ String.escaped s ^ "\"; ")
321                | Valuelist sl ->
322                    output_string out ("\"" ^ String.escaped name ^ "\", ");
323                    output_string out ("\"" ^ 
324                                       String.escaped (String.concat " " sl) ^ 
325                                       "\"; ")
326                | Implied_value ->
327                    ()
328              end
329           )
330           (n # attributes);
331         output_string out " ] in\n";
332     | T_super_root ->
333         let loc, line, col = n # position in
334         output_string out
335           ("let pos = \"" ^ String.escaped loc ^ "\", " ^ 
336            string_of_int line ^ ", " ^ 
337            string_of_int col ^ " in\n");
338         output_string out 
339           ("let t = Pxp_document.create_super_root_node ~position:pos spec dtd in\n")
340     | T_pinstr piname ->
341         let loc, line, col = n # position in
342         output_string out
343           ("let pos = \"" ^ String.escaped loc ^ "\", " ^ 
344            string_of_int line ^ ", " ^ 
345            string_of_int col ^ " in\n");
346         output_string out "let pi = ";
347         write_expr_new_pi out (List.hd (n # pinstr piname));
348         output_string out " in\n";
349         output_string out 
350           ("let t = Pxp_document.create_pinstr_node ~position:pos spec dtd pi in\n")
351     | T_comment ->
352         let loc, line, col = n # position in
353         output_string out
354           ("let pos = \"" ^ String.escaped loc ^ "\", " ^ 
355            string_of_int line ^ ", " ^ 
356            string_of_int col ^ " in\n");
357         output_string out "let comment = ";
358         ( match n # comment with
359               None   -> assert false
360             | Some c -> output_string out ("\"" ^ String.escaped c ^ "\"")
361         );
362         output_string out " in\n";
363         output_string out 
364           ("let t = Pxp_document.create_comment_node ~position:pos spec dtd comment in\n")
365     | _ ->
366         assert false
367   end;
368
369   (* Add processing instructions: *)
370   begin match n # node_type with
371       T_pinstr _ ->
372         ()
373     | _ ->
374         List.iter
375           (fun target ->
376              let pilist = n # pinstr target in
377              List.iter
378                (fun pi ->
379                   output_string out "let pi = ";
380                   write_expr_new_pi out pi;
381                   output_string out " in\n";
382                   output_string out "add_pinstr t pi;\n";
383                )
384                pilist;
385           )
386           (List.sort Pervasives.compare (n # pinstr_names));
387   end;
388        
389   (* Add the sub nodes: *)
390   n # iter_nodes
391     (fun n' ->
392        output_string out "add_node t (\n";
393        write_local_subtree out n';
394        output_string out ");\n";
395     );
396
397   (* Validate: *)
398   output_string out "local_validate t;\n";
399
400   (* Return: *)
401   output_string out "t\n"
402 ;;
403
404
405 let write_local_document out (d : 'ext document) =
406   (* Outputs "let mkdoc warner spec = ... in" *)
407   
408   output_string out "let mkdoc warner spec =\n";
409   output_string out "let doc = new Pxp_document.document warner in\n";
410   output_string out ("doc # init_xml_version \"" ^
411                      String.escaped (d # xml_version) ^ "\";\n");
412   write_local_dtd out (d # dtd);
413   output_string out "let dtd = mkdtd warner in\n";
414   output_string out "let root = ";
415   write_local_subtree out (d # root);
416   output_string out " in\n";
417   output_string out "doc # init_root root;\n";
418
419   (* Add processing instructions: *)
420   List.iter
421     (fun target ->
422        let pilist = d # pinstr target in
423        List.iter
424          (fun pi ->
425             output_string out "let pi = ";
426             write_expr_new_pi out pi;
427             output_string out " in\n";
428             output_string out "doc # add_pinstr pi;\n";
429          )
430          pilist;
431     )
432     (List.sort Pervasives.compare (d # pinstr_names));
433   
434   (* Return the result: *)
435   output_string out "doc in\n"
436 ;;
437
438
439 let write_helpers out =
440   output_string out "let add_node t n = (t : 'ext Pxp_document.node) # add_node (n : 'ext Pxp_document.node) in\n";
441   output_string out "let add_pinstr t pi = (t : 'ext Pxp_document.node) # add_pinstr (pi : Pxp_dtd.proc_instruction) in\n";
442   output_string out "let local_validate t = (t : 'ext Pxp_document.node) # local_validate ()in\n"
443 ;;
444
445
446 let write_document out d =
447   output_string out "let create_document warner spec =\n";
448   write_helpers out;
449   write_local_document out d;
450   output_string out "mkdoc warner spec;;\n"
451 ;;
452
453
454 let write_dtd out dtd =
455   output_string out "let create_dtd warner =\n";
456   write_local_dtd out dtd;
457   output_string out "mkdtd warner;;\n"
458 ;;
459
460
461 let write_subtree out t =
462   output_string out "let create_subtree dtd spec =\n";
463   write_helpers out;
464   write_local_subtree out t;
465   output_string out "mktree dtd spec;;\n"
466 ;;
467
468 (* ======================================================================
469  * History:
470  * 
471  * $Log$
472  * Revision 1.1  2000/11/17 09:57:29  lpadovan
473  * Initial revision
474  *
475  * Revision 1.7  2000/08/30 15:48:07  gerd
476  *      Minor update.
477  *
478  * Revision 1.6  2000/08/18 20:16:59  gerd
479  *      Updates because of new node types T_comment, T_pinstr, T_super_root.
480  *
481  * Revision 1.5  2000/07/23 02:16:51  gerd
482  *      Changed signature of local_validate.
483  *
484  * Revision 1.4  2000/07/09 17:59:35  gerd
485  *      Updated: The position of element nodes is also written.
486  *
487  * Revision 1.3  2000/07/09 00:30:00  gerd
488  *      Notations are written before they are used.
489  *      Unparsed entities are included.
490  *      Further changes.
491  *
492  * Revision 1.2  2000/07/08 22:59:14  gerd
493  *      [Merging 0.2.10:] Improved: The resulting code can be compiled
494  * faster, and the compiler is less hungry on memory.
495  *      Updated because of PXP interface changes.
496  *
497  * Revision 1.1  2000/05/29 23:48:38  gerd
498  *      Changed module names:
499  *              Markup_aux          into Pxp_aux
500  *              Markup_codewriter   into Pxp_codewriter
501  *              Markup_document     into Pxp_document
502  *              Markup_dtd          into Pxp_dtd
503  *              Markup_entity       into Pxp_entity
504  *              Markup_lexer_types  into Pxp_lexer_types
505  *              Markup_reader       into Pxp_reader
506  *              Markup_types        into Pxp_types
507  *              Markup_yacc         into Pxp_yacc
508  * See directory "compatibility" for (almost) compatible wrappers emulating
509  * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
510  *
511  * ======================================================================
512  * Old logs from markup_codewriter.ml:
513  *
514  * Revision 1.1  2000/03/11 22:57:28  gerd
515  *      Initial revision.
516  *
517  * 
518  *)