--- /dev/null
+(* $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.
+ *
+ *
+ *)
projects / helm.git / blobdiff