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  *)