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=0000000000000000000000000000000000000000;hb=c7514aaa249a96c5fdd39b1123fbdb38d92f20b6;hp=a6ab0db416f073a02cb66897d0e43b6233bcfb77;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;p=helm.git diff --git a/helm/DEVEL/pxp/pxp/pxp_codewriter.ml b/helm/DEVEL/pxp/pxp/pxp_codewriter.ml deleted file mode 100644 index a6ab0db41..000000000 --- a/helm/DEVEL/pxp/pxp/pxp_codewriter.ml +++ /dev/null @@ -1,518 +0,0 @@ -(* $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. - * - * - *)