Support for automatic stylesheet configuration retrieval started

[helm.git] / helm / interface / styleConfiguration.ml

diff --git a/helm/interface/styleConfiguration.ml b/helm/interface/styleConfiguration.ml
new file mode 100644 (file)
index 0000000..753a808
--- /dev/null
+++ b/helm/interface/styleConfiguration.ml
@@ -0,0 +1,85 @@
+(******************************************************************************)
+(*                                                                            *)
+(*                               PROJECT HELM                                 *)
+(*                                                                            *)
+(*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
+(*                                 28/12/2000                                 *)
+(*                                                                            *)
+(* This is the parser that reads the configuration file of helm               *)
+(*                                                                            *)
+(******************************************************************************)
+
+let filename =
+ try
+  Sys.getenv "HELM_STYLECONFIGURATION_PATH"
+ with
+  Not_found ->
+   let tmp_filename = C.tmpdir ^ "/style-configuration.xml" in
+   if Sys.file_exists tmp_filename then tmp_filename
+   else begin
+    let styleconf = Getter.raw_get "getstyleconf" in
+    let out_channel = open_out tmp_filename in
+    output_string out_channel styleconf;
+    close_out out_channel;
+    tmp_filename 
+   end
+
+exception Warnings;;
+
+class warner =
+  object 
+    method warn w =
+      print_endline ("WARNING: " ^ w) ;
+      (raise Warnings : unit)
+  end
+;;
+
+let xml_document () =
+ let module Y = Pxp_yacc in
+  try 
+   let config = {Y.default_config with Y.warner = new warner} in
+    Y.parse_document_entity config (Y.from_file filename) Y.default_spec
+  with
+   e ->
+     print_endline (Pxp_types.string_of_exn e) ;
+     raise e
+;;
+
+exception Impossible;;
+
+let styles = Hashtbl.create 13;;
+let applies = Hashtbl.create 13;;
+
+(* we trust the xml file to be valid because of the validating xml parser *)
+let _ =
+ List.iter
+  (function
+      n ->
+       match n#node_type with
+          Pxp_document.T_element "style" ->
+           let key =
+           try
+            n#attribute "key"
+           with
+            Not_found -> n#data
+           Hashtbl.add styles key n#data
+        | Pxp_document.T_element "apply" ->
+           let keys = List.map
+            (function n ->
+              match n#node_type with
+                 Pxp_document.T_element "style-ref" -> n#attribute "key"
+               | _ -> raise Impossible
+            )
+            n#sub_nodes
+           in
+            Hashtbl.add applies (n#attribute "name") keys
+        | _ -> raise Impossible
+  )
+  ((xml_document ())#root#sub_nodes)
+;;
+
+let style_of_key key =
+ Hashtbl.lookup styles key
+
+let key_list_of_mode_name name =
+ Hashtbl.lookup applies name