helm/interface/styleConfiguration.ml

   1 (******************************************************************************)
   2 (*                                                                            *)
   3 (*                               PROJECT HELM                                 *)
   4 (*                                                                            *)
   5 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
   6 (*                                 28/12/2000                                 *)
   7 (*                                                                            *)
   8 (* This is the parser that reads the configuration file of helm               *)
   9 (*                                                                            *)
  10 (******************************************************************************)
  11
  12 let filename =
  13  try
  14   Sys.getenv "HELM_STYLECONFIGURATION_PATH"
  15  with
  16   Not_found ->
  17    let xml = "style-configuration.xml" in
  18    let tmp_xml = Configuration.tmp_dir ^ "/" ^ xml in
  19    let request_xml = Configuration.getter_url ^ "getstyleconf?uri=" ^ xml in
  20    ClientHTTP.get_and_save request_xml tmp_xml ;
  21    tmp_xml
  22
  23 exception Warnings;;
  24
  25 class warner =
  26   object
  27     method warn w =
  28       print_endline ("WARNING: " ^ w) ;
  29       (raise Warnings : unit)
  30   end
  31 ;;
  32
  33 let xml_document () =
  34  let module Y = Pxp_yacc in
  35   try
  36    let config = {Y.default_config with Y.warner = new warner} in
  37     Y.parse_document_entity config (PxpUriResolver.from_file filename) Y.default_spec
  38   with
  39    e ->
  40      print_endline (Pxp_types.string_of_exn e) ;
  41      raise e
  42 ;;
  43
  44 exception Impossible;;
  45
  46 let styles = Hashtbl.create 13;;
  47 let applies = Hashtbl.create 13;;
  48
  49 (* we trust the xml file to be valid because of the validating xml parser *)
  50 let _ =
  51  List.iter
  52   (function
  53       n ->
  54        match n#node_type with
  55           Pxp_document.T_element "style" ->
  56            let key =
  57             try
  58              match n#attribute "key" with
  59                 Pxp_types.Value s -> s
  60               | _ -> raise Impossible
  61             with
  62              Not_found -> n#data
  63            in
  64             Hashtbl.add styles key n#data
  65         | Pxp_document.T_element "apply" ->
  66            let keys = List.map
  67             (function n ->
  68               match n#node_type with
  69                  Pxp_document.T_element "style-ref" ->
  70                   begin
  71                    match n#attribute "key" with
  72                       Pxp_types.Value s -> s
  73                     | _ -> raise Impossible
  74                   end
  75                | _ -> raise Impossible
  76             )
  77             n#sub_nodes
  78            in
  79             let apply_name =
  80              match n#attribute "name" with
  81                 Pxp_types.Value s -> s
  82               | _ -> raise Impossible
  83             in Hashtbl.add applies apply_name keys
  84         | _ -> raise Impossible
  85   )
  86   ((xml_document ())#root#sub_nodes)
  87 ;;
  88
  89 let style_of_key key =
  90  Hashtbl.find styles key
  91
  92 let key_list_of_mode_name name =
  93  Hashtbl.find applies name
  94 ;;
  95