type attr = string * string
-type 'a pp = (och -> int -> 'a) -> och -> int -> 'a
+type pp = och -> int -> unit
let attribute out (name, contents) =
if contents <> "" then begin
let doctype out root system =
out "<!DOCTYPE "; out root; out " SYSTEM \""; out system; out "\">\n\n"
-let tag tag attrs ?contents f out indent =
+let tag tag attrs ?contents out indent =
let spc = String.make indent ' ' in
- out spc; out "<"; out "tag"; List.iter (attribute out) attrs;
+ out spc; out "<"; out tag; List.iter (attribute out) attrs;
match contents with
- | None -> out "/>\n"; f out indent
- | Some cont ->
- let f _ _ = out spc; out "</"; out tag; out ">\n"; f out indent in
- cont f out (indent + 3)
+ | None -> out "/>\n"
+ | Some cont ->
+ out ">\n"; cont out (indent + 3); out spc;
+ out "</"; out tag; out ">\n"
let sort = "Sort"
"arity", contents
let name a =
- let err () = "name", "" in
- let f s = function
- | true -> "name", s
- | false -> "name", ("^" ^ s)
- in
- Y.name err f a
+ let map f i n r s =
+ let n = if r then n else "^" ^ n in
+ let spc = if i then "" else " " in
+ f (s ^ n ^ spc)
+ in
+ let f s = "name", s in
+ Y.names f map a ""
let mark a =
let err () = "mark", "" in
let f i = "mark", string_of_int i in
Y.mark err f a
-let export_entity f pp_term si g (a, uri, b) =
- let path = path_of_uri uri in
+let export_entity pp_term si g (a, u, b) =
+ let path = path_of_uri u in
let _ = Sys.command (Printf.sprintf "mkdir -p %s" (N.dirname path)) in
let och = open_out (path ^ obj_ext) in
let out = output_string och in
- let f _ _ = close_out och; f () in
xml out "1.0" "UTF-8"; doctype out root system;
- let str = U.string_of_uri uri in
- let a = Y.Name (U.name_of_uri uri, true) :: a in
- let attrs = ["uri", str; name a] in
+ let a = Y.Name (U.name_of_uri u, true) :: a in
+ let attrs = [uri u; name a; mark a] in
let contents = match b with
| Y.Abst w -> tag "ABST" attrs ~contents:(pp_term w)
| Y.Abbr v -> tag "ABBR" attrs ~contents:(pp_term v)
let opts = if si then "si" else "" in
let shp = H.string_of_graph C.start g in
let attrs = ["hierarchy", shp; "options", opts] in
- tag root attrs ~contents f out 0;
+ tag root attrs ~contents out 0;
+ close_out och