X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fpxp%2Fpxp_codewriter.ml;fp=helm%2FDEVEL%2Fpxp%2Fpxp%2Fpxp_codewriter.ml;h=a6ab0db416f073a02cb66897d0e43b6233bcfb77;hb=c03d2c1fdab8d228cb88aaba5ca0f556318bebc5;hp=0000000000000000000000000000000000000000;hpb=758057e85325f94cd88583feb1fdf6b038e35055;p=helm.git diff --git a/helm/DEVEL/pxp/pxp/pxp_codewriter.ml b/helm/DEVEL/pxp/pxp/pxp_codewriter.ml new file mode 100644 index 000000000..a6ab0db41 --- /dev/null +++ b/helm/DEVEL/pxp/pxp/pxp_codewriter.ml @@ -0,0 +1,518 @@ +(* $Id$ + * ---------------------------------------------------------------------- + * PXP: The polymorphic XML parser for Objective Caml. + * Copyright by Gerd Stolpmann. See LICENSE for details. + *) + +open Pxp_document +open Pxp_yacc +open Pxp_dtd +open Pxp_types + +let write_expr_ext_id out extid = + match extid with + System s -> + output_string out ("(Pxp_types.System\"" ^ String.escaped s ^ "\")") + | Public(s,t) -> + output_string out ("(Pxp_types.Public(\"" ^ String.escaped s ^ + "\",\"" ^ + String.escaped t ^ "\"))") + | Anonymous -> + output_string out "Pxp_types.Anonymous" +;; + + +let rec write_expr_content_model out cm = + match cm with + Unspecified -> output_string out "Pxp_types.Unspecified" + | Empty -> output_string out "Pxp_types.Empty" + | Any -> output_string out "Pxp_types.Any" + | Mixed msl -> output_string out "(Pxp_types.Mixed ["; + List.iter + (fun ms -> + write_expr_mixed_spec out ms; + output_string out "; "; + ) + msl; + output_string out "])"; + | Regexp re -> output_string out "(Pxp_types.Regexp "; + write_expr_regexp_spec out re; + output_string out ")"; + +and write_expr_mixed_spec out ms = + match ms with + MPCDATA -> output_string out "Pxp_types.MPCDATA" + | MChild s -> output_string out ("(Pxp_types.MChild \"" ^ + String.escaped s ^ "\")") + +and write_expr_regexp_spec out re = + match re with + Optional re' -> output_string out "(Pxp_types.Optional "; + write_expr_regexp_spec out re'; + output_string out ")"; + | Repeated re' -> output_string out "(Pxp_types.Repeated "; + write_expr_regexp_spec out re'; + output_string out ")"; + | Repeated1 re' -> output_string out "(Pxp_types.Repeated1 "; + write_expr_regexp_spec out re'; + output_string out ")"; + | Alt rel -> output_string out "(Pxp_types.Alt ["; + List.iter + (fun re' -> + write_expr_regexp_spec out re'; + output_string out "; "; + ) + rel; + output_string out "])"; + | Seq rel -> output_string out "(Pxp_types.Seq ["; + List.iter + (fun re' -> + write_expr_regexp_spec out re'; + output_string out "; "; + ) + rel; + output_string out "])"; + | Child s -> output_string out ("(Pxp_types.Child \"" ^ + String.escaped s ^ "\")") +;; + + +let write_expr_att_type out at = + match at with + A_cdata -> output_string out "Pxp_types.A_cdata" + | A_id -> output_string out "Pxp_types.A_id" + | A_idref -> output_string out "Pxp_types.A_idref" + | A_idrefs -> output_string out "Pxp_types.A_idrefs" + | A_entity -> output_string out "Pxp_types.A_entity" + | A_entities -> output_string out "Pxp_types.A_entities" + | A_nmtoken -> output_string out "Pxp_types.A_nmtoken" + | A_nmtokens -> output_string out "Pxp_types.A_nmtokens" + | A_notation sl -> output_string out "(Pxp_types.A_notation ["; + List.iter + (fun s -> + output_string out ("\"" ^ + String.escaped s ^ "\"; ")) + sl; + output_string out "])"; + | A_enum sl -> output_string out "(Pxp_types.A_enum ["; + List.iter + (fun s -> + output_string out ("\"" ^ + String.escaped s ^ "\"; ")) + sl; + output_string out "])"; +;; + + +let write_expr_att_default out ad = + match ad with + D_required -> output_string out "Pxp_types.D_required" + | D_implied -> output_string out "Pxp_types.D_implied" + | D_default s -> output_string out ("(Pxp_types.D_default \"" ^ + String.escaped s ^ "\")") + | D_fixed s -> output_string out ("(Pxp_types.D_fixed \"" ^ + String.escaped s ^ "\")") +;; + + +let write_expr_att_value out av = + match av with + Value s -> output_string out ("(Pxp_types.Value \"" ^ + String.escaped s ^ "\")") + | Valuelist sl -> output_string out ("(Pxp_types.Valuelist ["); + List.iter + (fun s -> + output_string out ("\"" ^ String.escaped s ^ + "\"; ") + ) + sl; + output_string out "])"; + | Implied_value -> output_string out "Pxp_types.Implied_value" +;; + + +let ocaml_encoding enc = + match enc with + `Enc_utf8 -> "`Enc_utf8" + | `Enc_utf16 -> "`Enc_utf16" + | `Enc_utf16_le -> "`Enc_utf16_le" + | `Enc_utf16_be -> "`Enc_utf16_be" + | `Enc_iso88591 -> "`Enc_iso88591" +;; + + +let write_expr_new_pi out pi = + output_string out ("(new Pxp_dtd.proc_instruction \"" ^ + String.escaped(pi # target) ^ "\" \"" ^ + String.escaped(pi # value) ^ "\" " ^ + ocaml_encoding(pi # encoding) ^ ")") +;; + + +let write_expr_node_type out nt = + match nt with + T_data -> output_string out "Pxp_document.T_data" + | T_element s -> output_string out ("(Pxp_document.T_element \"" ^ + String.escaped s ^ "\")") + | T_super_root -> output_string out "Pxp_document.T_super_root" + | T_pinstr s -> output_string out ("(Pxp_document.T_pinstr \"" ^ + String.escaped s ^ "\")") + | T_comment -> output_string out "Pxp_document.T_comment" + | _ -> assert false +;; + + +let write_local_dtd out (dtd : dtd) = + (* Outputs "let mkdtd warner = ... in" to 'out' *) + output_string out "let mkdtd warner =\n"; + output_string out ("let encoding = " ^ ocaml_encoding (dtd # encoding) ^ + " in\n"); + output_string out "let dtdobj = new Pxp_dtd.dtd warner encoding in\n"; + + (* Set the ID: *) + output_string out "dtdobj # set_id "; + begin match dtd # id with + None -> () + | Some(External x) -> + output_string out "(Pxp_types.External "; + write_expr_ext_id out x; + output_string out ");\n" + | Some(Derived x) -> + output_string out "(Pxp_types.Derived "; + write_expr_ext_id out x; + output_string out ");\n" + | Some Internal -> + output_string out "Pxp_types.Internal;\n"; + end; + + (* Set standalone declaration: *) + output_string out ("dtdobj # set_standalone_declaration " ^ + string_of_bool (dtd # standalone_declaration) ^ ";\n"); + + (* Add notations: *) + List.iter + (fun noname -> + let no = dtd # notation noname in + output_string out ("let no = new Pxp_dtd.dtd_notation \"" ^ + String.escaped noname ^ "\" "); + write_expr_ext_id out (no # ext_id); + output_string out " encoding in\n"; + output_string out "dtdobj # add_notation no;\n"; + ) + (List.sort Pervasives.compare (dtd # notation_names)); + + (* Add unparsed entities: *) + List.iter + (fun enname -> + let en, _ = dtd # gen_entity enname in + if en # is_ndata then begin + let ext_id = en # ext_id in + let notation = en # notation in + let encoding = en # encoding in + output_string out ("let ndata = new Pxp_entity.ndata_entity \"" ^ + String.escaped enname ^ "\" "); + write_expr_ext_id out ext_id; + output_string out ("\"" ^ String.escaped notation ^ "\" " ^ + ocaml_encoding encoding ^ " in \n"); + output_string out "dtdobj # add_gen_entity (ndata :> Pxp_entity.entity) false;\n"; + end; + ) + (List.sort Pervasives.compare (dtd # gen_entity_names)); + + + (* Add elements: *) + List.iter + (fun elname -> + (* Create the element 'el': *) + let el = dtd # element elname in + output_string out ("let el = new Pxp_dtd.dtd_element dtdobj \"" ^ + String.escaped elname ^ "\" in\n"); + output_string out "let cm = "; + write_expr_content_model out (el # content_model); + output_string out " in\n"; + output_string out "el # set_cm_and_extdecl cm false;\n"; + (* Add attributes: *) + List.iter + (fun attname -> + let atttype, attdefault = el # attribute attname in + output_string out ("el # add_attribute \"" ^ + String.escaped attname ^ "\" "); + write_expr_att_type out atttype; + output_string out " "; + write_expr_att_default out attdefault; + output_string out " false;\n"; + ) + (List.sort Pervasives.compare (el # attribute_names)); + + (* Allow arbitrary? *) + if el # arbitrary_allowed then + output_string out "el # allow_arbitrary;\n" + else + output_string out "el # disallow_arbitrary;\n"; + + (* Validate: *) + output_string out "el # validate;\n"; + + (* Add the element 'el' to 'dtdobj': *) + output_string out "dtdobj # add_element el;\n"; + ) + (List.sort Pervasives.compare (dtd # element_names)); + + (* Add processing instructions: *) + List.iter + (fun target -> + let pilist = dtd # pinstr target in + List.iter + (fun pi -> + output_string out "let pi = "; + write_expr_new_pi out pi; + output_string out " in\n"; + output_string out "dtdobj # add_pinstr pi;\n"; + ) + pilist; + ) + (List.sort Pervasives.compare (dtd # pinstr_names)); + + (* Set the name of the root element: *) + begin match dtd # root with + None -> () + | Some rootname -> + output_string out ("dtdobj # set_root \"" ^ + String.escaped rootname ^ "\";\n") + end; + + (* Special options: *) + if dtd # arbitrary_allowed then + output_string out "dtdobj # allow_arbitrary;\n" + else + output_string out "dtdobj # disallow_arbitrary;\n"; + + (* Return dtdobj: *) + output_string out "dtdobj in\n" +;; + + +let rec write_local_subtree out n = + (* Outputs the term generating the subtree *) + + output_string out "let nt = "; + write_expr_node_type out (n # node_type); + output_string out " in\n"; + + begin match n # node_type with + T_data -> + output_string out ("let t = Pxp_document.create_data_node spec dtd \"" ^ + String.escaped (n # data) ^ "\" in\n") + | T_element elname -> + let loc, line, col = n # position in + output_string out + ("let pos = \"" ^ String.escaped loc ^ "\", " ^ + string_of_int line ^ ", " ^ + string_of_int col ^ " in\n"); + output_string out + ("let t = Pxp_document.create_element_node ~position:pos spec dtd \"" ^ + String.escaped elname ^ "\" [ "); + List.iter + (fun (name,value) -> + begin match value with + Value s -> + output_string out ("\"" ^ String.escaped name ^ "\", "); + output_string out ("\"" ^ String.escaped s ^ "\"; ") + | Valuelist sl -> + output_string out ("\"" ^ String.escaped name ^ "\", "); + output_string out ("\"" ^ + String.escaped (String.concat " " sl) ^ + "\"; ") + | Implied_value -> + () + end + ) + (n # attributes); + output_string out " ] in\n"; + | T_super_root -> + let loc, line, col = n # position in + output_string out + ("let pos = \"" ^ String.escaped loc ^ "\", " ^ + string_of_int line ^ ", " ^ + string_of_int col ^ " in\n"); + output_string out + ("let t = Pxp_document.create_super_root_node ~position:pos spec dtd in\n") + | T_pinstr piname -> + let loc, line, col = n # position in + output_string out + ("let pos = \"" ^ String.escaped loc ^ "\", " ^ + string_of_int line ^ ", " ^ + string_of_int col ^ " in\n"); + output_string out "let pi = "; + write_expr_new_pi out (List.hd (n # pinstr piname)); + output_string out " in\n"; + output_string out + ("let t = Pxp_document.create_pinstr_node ~position:pos spec dtd pi in\n") + | T_comment -> + let loc, line, col = n # position in + output_string out + ("let pos = \"" ^ String.escaped loc ^ "\", " ^ + string_of_int line ^ ", " ^ + string_of_int col ^ " in\n"); + output_string out "let comment = "; + ( match n # comment with + None -> assert false + | Some c -> output_string out ("\"" ^ String.escaped c ^ "\"") + ); + output_string out " in\n"; + output_string out + ("let t = Pxp_document.create_comment_node ~position:pos spec dtd comment in\n") + | _ -> + assert false + end; + + (* Add processing instructions: *) + begin match n # node_type with + T_pinstr _ -> + () + | _ -> + List.iter + (fun target -> + let pilist = n # pinstr target in + List.iter + (fun pi -> + output_string out "let pi = "; + write_expr_new_pi out pi; + output_string out " in\n"; + output_string out "add_pinstr t pi;\n"; + ) + pilist; + ) + (List.sort Pervasives.compare (n # pinstr_names)); + end; + + (* Add the sub nodes: *) + n # iter_nodes + (fun n' -> + output_string out "add_node t (\n"; + write_local_subtree out n'; + output_string out ");\n"; + ); + + (* Validate: *) + output_string out "local_validate t;\n"; + + (* Return: *) + output_string out "t\n" +;; + + +let write_local_document out (d : 'ext document) = + (* Outputs "let mkdoc warner spec = ... in" *) + + output_string out "let mkdoc warner spec =\n"; + output_string out "let doc = new Pxp_document.document warner in\n"; + output_string out ("doc # init_xml_version \"" ^ + String.escaped (d # xml_version) ^ "\";\n"); + write_local_dtd out (d # dtd); + output_string out "let dtd = mkdtd warner in\n"; + output_string out "let root = "; + write_local_subtree out (d # root); + output_string out " in\n"; + output_string out "doc # init_root root;\n"; + + (* Add processing instructions: *) + List.iter + (fun target -> + let pilist = d # pinstr target in + List.iter + (fun pi -> + output_string out "let pi = "; + write_expr_new_pi out pi; + output_string out " in\n"; + output_string out "doc # add_pinstr pi;\n"; + ) + pilist; + ) + (List.sort Pervasives.compare (d # pinstr_names)); + + (* Return the result: *) + output_string out "doc in\n" +;; + + +let write_helpers out = + output_string out "let add_node t n = (t : 'ext Pxp_document.node) # add_node (n : 'ext Pxp_document.node) in\n"; + output_string out "let add_pinstr t pi = (t : 'ext Pxp_document.node) # add_pinstr (pi : Pxp_dtd.proc_instruction) in\n"; + output_string out "let local_validate t = (t : 'ext Pxp_document.node) # local_validate ()in\n" +;; + + +let write_document out d = + output_string out "let create_document warner spec =\n"; + write_helpers out; + write_local_document out d; + output_string out "mkdoc warner spec;;\n" +;; + + +let write_dtd out dtd = + output_string out "let create_dtd warner =\n"; + write_local_dtd out dtd; + output_string out "mkdtd warner;;\n" +;; + + +let write_subtree out t = + output_string out "let create_subtree dtd spec =\n"; + write_helpers out; + write_local_subtree out t; + output_string out "mktree dtd spec;;\n" +;; + +(* ====================================================================== + * History: + * + * $Log$ + * Revision 1.1 2000/11/17 09:57:29 lpadovan + * Initial revision + * + * Revision 1.7 2000/08/30 15:48:07 gerd + * Minor update. + * + * Revision 1.6 2000/08/18 20:16:59 gerd + * Updates because of new node types T_comment, T_pinstr, T_super_root. + * + * Revision 1.5 2000/07/23 02:16:51 gerd + * Changed signature of local_validate. + * + * Revision 1.4 2000/07/09 17:59:35 gerd + * Updated: The position of element nodes is also written. + * + * Revision 1.3 2000/07/09 00:30:00 gerd + * Notations are written before they are used. + * Unparsed entities are included. + * Further changes. + * + * Revision 1.2 2000/07/08 22:59:14 gerd + * [Merging 0.2.10:] Improved: The resulting code can be compiled + * faster, and the compiler is less hungry on memory. + * Updated because of PXP interface changes. + * + * Revision 1.1 2000/05/29 23:48:38 gerd + * Changed module names: + * Markup_aux into Pxp_aux + * Markup_codewriter into Pxp_codewriter + * Markup_document into Pxp_document + * Markup_dtd into Pxp_dtd + * Markup_entity into Pxp_entity + * Markup_lexer_types into Pxp_lexer_types + * Markup_reader into Pxp_reader + * Markup_types into Pxp_types + * Markup_yacc into Pxp_yacc + * See directory "compatibility" for (almost) compatible wrappers emulating + * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc. + * + * ====================================================================== + * Old logs from markup_codewriter.ml: + * + * Revision 1.1 2000/03/11 22:57:28 gerd + * Initial revision. + * + * + *)