| 1 |
(* TODO:
|
| 2 |
- clever factorizations of content model and attribute specifs
|
| 3 |
(e.g. type XHTML_inlien = [ ( Char | ... ) ])
|
| 4 |
- better pretty-printing
|
| 5 |
*)
|
| 6 |
open Printf
|
| 7 |
open Pxp_yacc
|
| 8 |
open Pxp_lexer_types
|
| 9 |
open Pxp_types
|
| 10 |
|
| 11 |
let mixed_table : ('a,unit) Hashtbl.t = Hashtbl.create 127
|
| 12 |
let regexp_table : ('a,unit) Hashtbl.t = Hashtbl.create 127
|
| 13 |
|
| 14 |
let import_dtd ppf name filename =
|
| 15 |
let rec regexp ppf = function
|
| 16 |
| Optional re -> Format.fprintf ppf "%a?" regexp re
|
| 17 |
| Repeated re -> Format.fprintf ppf "%a*" regexp re
|
| 18 |
| Repeated1 re -> Format.fprintf ppf "%a+" regexp re
|
| 19 |
| Seq (re1 :: res) ->
|
| 20 |
Format.fprintf ppf "(@[%a" regexp re1;
|
| 21 |
List.iter (fun re -> Format.fprintf ppf "@ %a" regexp re) res;
|
| 22 |
Format.fprintf ppf "@])"
|
| 23 |
| Alt (re1 :: res) ->
|
| 24 |
Format.fprintf ppf "(@[%a" regexp re1;
|
| 25 |
List.iter (fun re -> Format.fprintf ppf "@ | %a" regexp re) res;
|
| 26 |
Format.fprintf ppf "@])"
|
| 27 |
| Child s -> Format.fprintf ppf "%s" (name s)
|
| 28 |
| _ -> assert false
|
| 29 |
in
|
| 30 |
let content ppf = function
|
| 31 |
| Unspecified | Any -> Format.fprintf ppf "Any*"
|
| 32 |
| Empty -> Format.fprintf ppf ""
|
| 33 |
| Mixed l ->
|
| 34 |
(try
|
| 35 |
Hashtbl.find mixed_table l;
|
| 36 |
Format.fprintf ppf "MIXED:CACHED!"
|
| 37 |
with Not_found ->
|
| 38 |
(* Hashtbl.add mixed_table l (); *)
|
| 39 |
let l = List.map
|
| 40 |
(function
|
| 41 |
| MPCDATA -> "Char"
|
| 42 |
| MChild s -> name s) l in
|
| 43 |
Format.fprintf ppf "( %s )*" (String.concat " | " l))
|
| 44 |
| Regexp r ->
|
| 45 |
(try
|
| 46 |
Hashtbl.find regexp_table r;
|
| 47 |
Format.fprintf ppf "REGEXP:CACHED!"
|
| 48 |
with Not_found ->
|
| 49 |
(* Hashtbl.add regexp_table r ();*)
|
| 50 |
regexp ppf r
|
| 51 |
)
|
| 52 |
in
|
| 53 |
let att_type ppf = function
|
| 54 |
| A_enum l ->
|
| 55 |
Format.fprintf ppf "(";
|
| 56 |
ignore
|
| 57 |
(List.fold_left
|
| 58 |
(fun first s ->
|
| 59 |
if not first then Format.fprintf ppf " | ";
|
| 60 |
Format.fprintf ppf "\"%s\"" s; false) true l);
|
| 61 |
Format.fprintf ppf ")"
|
| 62 |
| _ -> Format.fprintf ppf "String"
|
| 63 |
in
|
| 64 |
let attrib ppf e =
|
| 65 |
ignore
|
| 66 |
(List.fold_left
|
| 67 |
(fun first a ->
|
| 68 |
let (at,ad) = e # attribute a in
|
| 69 |
match ad with
|
| 70 |
| D_fixed _ -> first
|
| 71 |
| _ ->
|
| 72 |
Format.fprintf ppf "%s%s=%s%a"
|
| 73 |
(if first then "" else "; ")
|
| 74 |
a
|
| 75 |
(if ad = D_required then "" else "?")
|
| 76 |
att_type at;
|
| 77 |
false
|
| 78 |
)
|
| 79 |
true (e # attribute_names)
|
| 80 |
)
|
| 81 |
in
|
| 82 |
let elt ppf e =
|
| 83 |
Format.fprintf ppf "type @[<2>%s =@ @[<3><%s {|%a|}>[@ @[%a@]@ ]@]@];;@\n"
|
| 84 |
(name (e # name))
|
| 85 |
(e # name)
|
| 86 |
attrib e
|
| 87 |
content (e # content_model)
|
| 88 |
in
|
| 89 |
|
| 90 |
let dtd = parse_dtd_entity { default_config with encoding = `Enc_utf8 } (from_file filename) in
|
| 91 |
Format.fprintf ppf
|
| 92 |
"(* This type has been automatically generated from %s by dtd2cduce *)@\n"
|
| 93 |
filename;
|
| 94 |
List.iter (fun x -> elt ppf (dtd # element x)) (dtd # element_names)
|
| 95 |
|
| 96 |
let () =
|
| 97 |
if Array.length Sys.argv <> 3 then
|
| 98 |
(prerr_endline "Usage: dtd2cduce <prefix> <.dtd file>";
|
| 99 |
exit 2);
|
| 100 |
let name s = Sys.argv.(1) ^ s in
|
| 101 |
import_dtd Format.std_formatter name Sys.argv.(2)
|
Parent Directory
| 
Revision Log