"Schema dump" ] <body>[ <h1>['Namespace: ' !ns] <p>['Processing time: ' !{:time:} 'ms'] <h2>"Simple types" (ul simple_type {{s.simple_types}}) <h2>"Complex types" (ul complex_type {{s.complex_types}}) <h2>"Elements" (ul element {{s.elements}}) <h2>"Attributes" (ul attrib {{s.attributes}}) ] ] }} let () = if Array.length Sys.argv <> 2 then ( prerr_endline "Please provide a single XML Schema file."; exit 2 ); let t1 = Sys.time () in let s = try load Sys.argv.(1) with | Xml.Error err -> Printf.eprintf "Parsing error: %s\n" (Xml.error err); exit 2 | exn -> Printf.eprintf "Error: %s\n" (Printexc.to_string exn); exit 2 in let time = Sys.time () -. t1 in let h = dump time s in Ocamlduce.Print.print_xml print_string h; print

(* This is the main program. *) (* Load the XML Schema *) module L = Ocamlduce.Load let load_xml fn = let xml = Xml.parse_file fn in let l = L.make ~ns:true () in let rec aux = function | Xml.Element (tag, attrs, child) -> L.start_elem l tag attrs; List.iter aux child; L.end_elem l () | Xml.PCData s -> L.text l s in aux xml; L.get l let include_uri base local = let l = if Filename.is_relative local then Filename.concat (Filename.dirname base) local else local in Printf.eprintf "Include %s\n" l; flush stderr; l let import_uri imported base local ns = if local = "" then None else let l = if Filename.is_relative local then Filename.concat (Filename.dirname base) local else local in if List.mem l !imported then None else (imported := l :: !imported; Printf.eprintf "Import %s\n" l; flush stderr; Some l) let load url = try {{ (load_xml url :? Schema_dtd.schema) }} with Failure s -> Printf.eprintf "Invalid document:%s@." s; exit 2 let load s = Schema_loader.parse_schema ~include_uri ~import_uri:(import_uri (ref [])) ~load s (* Dump the XML Schema *) open Schema module H = Xhtml1_strict let get_opt = function Some x -> x | None -> assert false let get_name o = snd (Ocamlduce.Atom.get o) let simple_type st = let n = get_name (get_opt st.st_name) in {{ [ n ] }} let complex_type ct = get_name (get_opt ct.ct_name) let element e = get_name e.el_name let attrib e = get_name e.at_name let ul f l = (* Inferred type: val ul : ('a -> {{[ String | Char* ]}}) -> 'a list -> {{
[ '' ] |
[
[ String | Char* ]+ ]}} *) {{ match {:List.map f l:} with | [] ->
"" | x ->
(map x with l -> [
l ]) }} let dump time s : H.html = let time = string_of_int (int_of_float (time *. 1000.)) in let ns = match Ocamlduce.Namespace.get s.ns with | {{ "" }} -> {{ "" }} | {{ x }} -> x in {{ [ [ "Schema dump" ] <body>[ <h1>['Namespace: ' !ns] <p>['Processing time: ' !{:time:} 'ms'] <h2>"Simple types" (ul simple_type {{s.simple_types}}) <h2>"Complex types" (ul complex_type {{s.complex_types}}) <h2>"Elements" (ul element {{s.elements}}) <h2>"Attributes" (ul attrib {{s.attributes}}) ] ] }} let () = if Array.length Sys.argv <> 2 then ( prerr_endline "Please provide a single XML Schema file."; exit 2 ); let t1 = Sys.time () in let s = try load Sys.argv.(1) with | Xml.Error err -> Printf.eprintf "Parsing error: %s\n" (Xml.error err); exit 2 | exn -> Printf.eprintf "Error: %s\n" (Printexc.to_string exn); exit 2 in let time = Sys.time () -. t1 in let h = dump time s in Ocamlduce.Print.print_xml print_string h; print_newline ()