(* $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.
 *
 * 
 *)