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 tmp_filename = C.tmpdir ^ "/style-configuration.xml" in
  18    if Sys.file_exists tmp_filename then tmp_filename
  19    else begin
  20     let styleconf = Getter.raw_get "getstyleconf" in
  21     let out_channel = open_out tmp_filename in
  22     output_string out_channel styleconf;
  23     close_out out_channel;
  24     tmp_filename
  25    end
  26
  27 exception Warnings;;
  28
  29 class warner =
  30   object
  31     method warn w =
  32       print_endline ("WARNING: " ^ w) ;
  33       (raise Warnings : unit)
  34   end
  35 ;;
  36
  37 let xml_document () =
  38  let module Y = Pxp_yacc in
  39   try
  40    let config = {Y.default_config with Y.warner = new warner} in
  41     Y.parse_document_entity config (Y.from_file filename) Y.default_spec
  42   with
  43    e ->
  44      print_endline (Pxp_types.string_of_exn e) ;
  45      raise e
  46 ;;
  47
  48 exception Impossible;;
  49
  50 let styles = Hashtbl.create 13;;
  51 let applies = Hashtbl.create 13;;
  52
  53 (* we trust the xml file to be valid because of the validating xml parser *)
  54 let _ =
  55  List.iter
  56   (function
  57       n ->
  58        match n#node_type with
  59           Pxp_document.T_element "style" ->
  60            let key =
  61             try
  62              n#attribute "key"
  63             with
  64              Not_found -> n#data
  65            Hashtbl.add styles key n#data
  66         | Pxp_document.T_element "apply" ->
  67            let keys = List.map
  68             (function n ->
  69               match n#node_type with
  70                  Pxp_document.T_element "style-ref" -> n#attribute "key"
  71                | _ -> raise Impossible
  72             )
  73             n#sub_nodes
  74            in
  75             Hashtbl.add applies (n#attribute "name") keys
  76         | _ -> raise Impossible
  77   )
  78   ((xml_document ())#root#sub_nodes)
  79 ;;
  80
  81 let style_of_key key =
  82  Hashtbl.lookup styles key
  83
  84 let key_list_of_mode_name name =
  85  Hashtbl.lookup applies name