2 ||M|| This file is part of HELM, an Hypertextual, Electronic
3 ||A|| Library of Mathematics, developed at the Computer Science
4 ||T|| Department, University of Bologna, Italy.
6 ||T|| HELM is free software; you can redistribute it and/or
7 ||A|| modify it under the terms of the GNU General Public License
8 \ / version 2 or (at your option) any later version.
9 \ / This software is distributed as is, NO WARRANTY.
10 V_______________________________________________________________ *)
19 (* internal functions *******************************************************)
27 let system = "http://helm.cs.unibo.it/lambda-delta/" ^ base ^ "/ld.dtd"
30 N.concat base (Str.string_after (U.string_of_uri uri) 3)
33 F.fprintf frm "<?xml version=%S encoding=%S?>@,@," "1.0" "UTF-8"
36 F.fprintf frm "<!DOCTYPE ENTITY SYSTEM %S>@,@," system
38 let open_entity si g frm =
39 let opts = if si then "si" else "" in
41 F.fprintf frm "<ENTITY hierarchy=%S options=%S>" shp opts
45 let close_entity frm =
46 F.fprintf frm "</ENTITY>"
50 | true -> F.fprintf frm " name=%S" s
51 | false -> F.fprintf frm " name=%S" ("^" ^ s)
55 let pp_entity pp_term frm = function
57 let str = U.string_of_uri u in
58 let a = Y.Name (U.name_of_uri u, true) :: a in
59 F.fprintf frm "<ABST uri=%S%a>%a</ABST>" str name a pp_term w
61 let str = U.string_of_uri u in
62 let a = Y.Name (U.name_of_uri u, true) :: a in
63 F.fprintf frm "<ABBR uri=%S%a>%a</ABBR>" str name a pp_term v
65 let pp_boxed pp_term frm entity =
66 F.fprintf frm "@,@[<v3> %a@]@," (pp_entity pp_term) entity
68 (* interface functions ******************************************************)
70 let old_export_entity pp_term si g entity =
71 let _, uri, _ = entity in
72 let path = path_of_uri uri in
73 let _ = Sys.command (Printf.sprintf "mkdir -p %s" (N.dirname path)) in
74 let och = open_out (path ^ obj_ext) in
75 let frm = F.formatter_of_out_channel och in
76 F.pp_set_margin frm max_int;
77 F.fprintf frm "@[<v>%t%t%t%a%t@]@."
79 (open_entity si g) (pp_boxed pp_term) entity close_entity;
84 (****************************************************************************)
86 type och = string -> unit
88 type attr = string * string
90 type pp = och -> int -> unit
92 let attribute out (name, contents) =
93 if contents <> "" then begin
94 out " "; out name; out "=\""; out contents; out "\""
97 let xml out version encoding =
99 attribute out ("version", version);
100 attribute out ("encoding", encoding);
103 let doctype out root system =
104 out "<!DOCTYPE "; out root; out " SYSTEM \""; out system; out "\">\n\n"
106 let tag tag attrs ?contents out indent =
107 let spc = String.make indent ' ' in
108 out spc; out "<"; out tag; List.iter (attribute out) attrs;
112 out ">\n"; cont out (indent + 3); out spc;
113 out "</"; out tag; out ">\n"
134 "position", string_of_int i
137 let contents = if j > 0 then string_of_int j else "" in
141 "uri", U.string_of_uri u
144 let contents = if n > 1 then string_of_int n else "" in
149 let n = if r then n else "^" ^ n in
150 let spc = if i then "" else " " in
153 let f s = "name", s in
157 let err () = "mark", "" in
158 let f i = "mark", string_of_int i in
161 let export_entity pp_term si g (a, u, b) =
162 let path = path_of_uri u in
163 let _ = Sys.command (Printf.sprintf "mkdir -p %s" (N.dirname path)) in
164 let och = open_out (path ^ obj_ext) in
165 let out = output_string och in
166 xml out "1.0" "UTF-8"; doctype out root system;
167 let a = Y.Name (U.name_of_uri u, true) :: a in
168 let attrs = [uri u; name a; mark a] in
169 let contents = match b with
170 | Y.Abst w -> tag "ABST" attrs ~contents:(pp_term w)
171 | Y.Abbr v -> tag "ABBR" attrs ~contents:(pp_term v)
173 let opts = if si then "si" else "" in
174 let shp = H.string_of_graph C.start g in
175 let attrs = ["hierarchy", shp; "options", opts] in
176 tag root attrs ~contents out 0;