Below is the file 'viz_style.ml' from this revision. You can also download the file.

open Viz_misc
open Viz_types

(* "Generic" preferences *)

type item = [
    `BOOL of bool
  | `FLOAT of float
  | `INT of int
  | `STRING of string ]

type generic_prefs = (string * item) list

let print_item () = function
  | `BOOL b   -> string_of_bool b
  | `FLOAT f  -> string_of_float f
  | `INT i    -> string_of_int i
  | `STRING s -> Printf.sprintf "%S" s

let bool_of_item = function
  | `BOOL b -> b
  | `INT i -> i <> 0
  | `STRING "yes" | `STRING "true" -> true
  | `STRING "no" | `STRING "false" -> false
  | _ -> failwith "bool_of_item"

let int_of_item = function
  | `INT i -> i
  | `FLOAT f -> int_of_float f
  | _ -> failwith "int_of_item"

let string_of_item = function
  | `STRING s -> s
  | _ -> failwith "string_of_item"
let string_list_of_item = function
  | `STRING s -> Str.split (Str.regexp ", *") s
  | _ -> failwith "string_list_of_item"

let autocolor_of_item = function
  | `STRING "none" | `BOOL false -> NONE
  | `STRING "key" | `STRING "keyid" -> BY_KEYID
  | `STRING "author" -> BY_AUTHOR_HASH
  | `STRING "branch" -> BY_BRANCH_HASH
  | _ -> failwith "autocolor_of_item"
let string_of_autocolor = function
  | NONE -> "none"
  | BY_KEYID -> "key"
  | BY_AUTHOR_HASH -> "author"
  | BY_BRANCH_HASH -> "branch"
let item_of_autocolor ac =
  `STRING (string_of_autocolor ac)

type 'a key = string * (item -> 'a)
let bool_key s = (s, bool_of_item)
let string_key s = (s, string_of_item)
let string_list_key s = (s, string_list_of_item)
let autocolor_key s = (s, autocolor_of_item)

let add_pref l (k, v) =
  (k, v) :: (if List.mem_assoc k l
             then List.remove_assoc k l
             else l)

let lookup p (k, conv) =
  try Some (conv (List.assoc k p))
  with Failure _ | Not_found -> None




(* Styles *)

type cert_style = string * Str.regexp * string * generic_prefs
type style = cert_style list

type prefs = {
    font          : string ;
    autocolor     : autocolor ;
    lr_layout     : bool ;
    monotone_path : string ;
    dot_path      : string ;
    ignored_certs : string list ;
    style         : style ;
  }




type shape_props = [
    `FILL_COLOR of string
  | `OUTLINE_COLOR of string
  | `WIDTH_PIXELS of int]
type text_props = [
    `FILL_COLOR of string
  | `FONT of string
  | `WEIGHT of int]

let match_style { autocolor = autocolor_pref ; style = style } g db =
  let autocolor = Autocolor.autocolor autocolor_pref db in

  fun id (default_rect_props, default_txt_props) ->
    let get_cert n = Database.fetch_cert_value db id n in

    let matching_attrs =
      List.fold_left
	(fun acc (cert_name, value_re, _, attr) ->
	  List.fold_left
	    (fun acc c_value ->
	      if Str.string_match value_re c_value 0
	      then List.fold_left add_pref acc attr
	      else acc)
	    acc (get_cert cert_name))
	[] style in
    let build_props dflt keys =
      List.fold_left
	(fun acc key ->
	  Viz_misc.may_cons (lookup matching_attrs key) acc)
	dflt keys in
    let rect_props : shape_props list =
      build_props default_rect_props
	[ ("color",         fun i -> `FILL_COLOR (string_of_item i)) ;
	  ("outline_color", fun i -> `OUTLINE_COLOR (string_of_item i)) ;
	  ("width_pixels",  fun i -> `WIDTH_PIXELS (int_of_item i)) ; ] in
    let text_props : text_props list =
      build_props default_txt_props
	[ ("text_color", fun i -> `FILL_COLOR (string_of_item i)) ;
	  ("font",       fun i -> `FONT (string_of_item i)) ;
	  ("weight",     fun i -> `WEIGHT (int_of_item i)) ; ] in
    let cleanup_rect_props =
      fst
	(List.fold_left
	   (fun ((props, seen_props) as acc) -> function
	     | `FILL_COLOR _ when List.mem `FILL_COLOR seen_props -> acc
	     | `FILL_COLOR _ as i -> (i :: props, `FILL_COLOR :: seen_props)
	     | `OUTLINE_COLOR _ when List.mem `OUTLINE_COLOR seen_props -> acc
	     | `OUTLINE_COLOR _ as i -> (i :: props, `OUTLINE_COLOR :: seen_props)
	     | `WIDTH_PIXELS _ when List.mem `WIDTH_PIXELS seen_props -> acc
	     | `WIDTH_PIXELS _ as i -> (i :: props, `WIDTH_PIXELS :: seen_props))
	   ([], []) rect_props) in
    let cleanup_text_props =
      fst
	(List.fold_left
	   (fun ((props, seen_props) as acc) -> function
	     | `FILL_COLOR _ when List.mem `FILL_COLOR seen_props -> acc
	     | `FILL_COLOR _ as i -> (i :: props, `FILL_COLOR :: seen_props)
	     | `FONT _ when List.mem `FONT seen_props -> acc
	     | `FONT _ as i -> (i :: props, `FONT :: seen_props)
	     | `WEIGHT _ when List.mem `WEIGHT seen_props -> acc
	     | `WEIGHT _ as i -> (i :: props, `WEIGHT :: seen_props))
	   ([], []) text_props) in
    let rect_props =
      if List.exists (function `FILL_COLOR _ -> true | _ -> false) cleanup_rect_props
      then cleanup_rect_props
      else begin
	let autocolor_key =
	  match autocolor_pref with
	  | BY_KEYID -> Database.fetch_cert_signer db id "branch"
	  | BY_AUTHOR_HASH -> Database.fetch_cert_value db id "author"
	  | BY_BRANCH_HASH -> Database.fetch_cert_value db id "branch"
	  | NONE -> [] in
	`FILL_COLOR_RGBA (autocolor autocolor_key) :: cleanup_rect_props
      end in

    (rect_props, cleanup_text_props)




(* Parsing *)

type token = Genlex.token =
  | Kwd of string
  | Ident of string
  | Int of int
  | Float of float
  | String of string
  | Char of char

let lex = Genlex.make_lexer [ "[" ; "="; ";"; "]" ]

let rec parse_list ?(q=Q.empty) p = parser
  | [< e = p ; nxt >] -> parse_list ~q:(Q.push q e) p nxt
  | [<>] -> Q.to_list q
let rec parse_list_sep sep ?(q=Q.empty) p = parser
  | [< e = p ; nxt >] -> opt_sep sep (Q.push q e) p nxt
  | [<>] -> Q.to_list q
and opt_sep sep q p = parser
  | [< ' Kwd s when s = sep ; nxt >] -> parse_list_sep sep ~q p nxt
  | [<>] -> Q.to_list q

type entry =
  | Cert_style of cert_style
  | Pref of (string * item)

let rec parse strm = parse_list style_or_pref strm
and style_or_pref = parser
  | [< ' Ident "cert" ; ' Ident cert_name ; ' String cert_value_re ; attr = attr_list >] ->
      Cert_style (cert_name, Str.regexp cert_value_re, cert_value_re, attr)
  | [< ' Ident key ; v = value >] ->
      Pref (key, v)
and attr_list = parser
  | [< ' Kwd "["; l = parse_list_sep ";" attr ; ' Kwd "]" >] -> l
and attr = parser
  | [< ' Ident key; ' Kwd "="; v = value >] -> (key, v)
and value = parser
  | [< ' Ident "true" >] -> `BOOL true
  | [< ' Ident "yes" >] -> `BOOL true
  | [< ' Ident "false" >] -> `BOOL false
  | [< ' Ident "no" >] -> `BOOL false
  | [< ' Ident i >] -> `STRING i
  | [< ' Int i >] -> `INT i
  | [< ' Float f >] -> `FLOAT f
  | [< ' String s >] -> `STRING s

let parse_file filename =
  if not (Sys.file_exists filename ) then [] else
  Viz_misc.with_file_in
    (fun ic -> parse (lex (Stream.of_channel ic)))
    filename

let parse_merge_items (prefs, style) filename =
  let parsed_data =
    try parse_file filename
    with
    | Sys_error msg ->
	Viz_types.errorf
	  "Error while accessing the style file '%s':\n%s" filename msg
    | Stream.Failure | Stream.Error _ ->
	Viz_types.errorf
	  "Syntax error in the style file '%s'" filename in
  let (prefs, style_entries) =
    List.fold_left
      (fun (prefs, style) -> function
	| Cert_style c -> (prefs, Q.push style c)
	| Pref k -> (add_pref prefs k, style))
      (prefs, Q.empty)
      parsed_data in
  (prefs, style @ (Q.to_list style_entries))




(* Conversion *)

let defaults =
  {
   font          = "Monospace 8" ;
   autocolor     = BY_KEYID ;
   lr_layout     = false ;
   monotone_path = "mtn" ;
   dot_path      = "dot" ;
   ignored_certs = [] ;
   style         = [] ;
 }

let prefs_of_items (i, style) =
  let get mk n = some (lookup i (mk n)) in
  { font          = get string_key    "font" ;
    autocolor     = get autocolor_key "autocolor" ;
    lr_layout     = get bool_key      "lr_layout" ;
    monotone_path = get string_key    "monotone" ;
    dot_path      = get string_key    "dot" ;
    ignored_certs = get string_list_key "ignored_certs" ;
    style         = style ;
  }

let items_of_prefs p =
  [ "font",          `STRING p.font ;
    "autocolor",     item_of_autocolor p.autocolor ;
    "lr_layout",     `BOOL p.lr_layout ;
    "monotone",      `STRING p.monotone_path ;
    "dot",           `STRING p.dot_path ;
    "ignored_certs",  `STRING (String.concat "," p.ignored_certs) ;
  ], p.style

let style_file_name =
  Filename.concat
    (get_home_dir ())
    ".monotone-viz.style"

let parse_merge p filename =
  prefs_of_items (parse_merge_items (items_of_prefs p) filename)

let load () = parse_merge defaults style_file_name

let separator = "-*- monotone-viz -*-"

let save_prefs b prefs =
  Printf.bprintf b "autocolor %s\n" (string_of_autocolor prefs.autocolor) ;
  Printf.bprintf b "lr_layout %B\n" prefs.lr_layout ;
  Printf.bprintf b "monotone  %S\n" prefs.monotone_path ;
  Printf.bprintf b "dot  %S\n" prefs.dot_path

let save prefs =
  let lines =
    if Sys.file_exists style_file_name
    then with_file_in input_lines style_file_name
    else [] in
  let keep_lines =
    let re = Str.regexp (" *(\\* *" ^ (Str.quote separator) ^ " *\\*)") in
    let rec keep = function
      | l :: tl when Str.string_match re l 0 -> []
      | l :: tl -> l :: keep tl
      | [] -> [] in
    keep lines in
  let keep_styles =
    List.fold_right
      (fun i acc -> match i with
      | Cert_style s -> s :: acc
      | Pref _ -> acc)
      (parse (lex (Stream.of_string (String.concat "\n" keep_lines))))
      [] in
  let b = Buffer.create 4096 in
  save_prefs b prefs ;
  List.iter
    (function
      | s when List.mem s keep_styles -> ()
      | (cert_name, _, re, attrs) ->
      Printf.bprintf b "cert %s %S [%s]\n"
	cert_name re
	(String.concat "; "
	   (List.map
	      (fun (k, v) -> Printf.sprintf "%s = %a" k print_item v)
	      attrs)))
    prefs.style ;
  with_file_out
    (fun oc ->
      let ol l = output_string oc l ; output_char oc '\n' in
      List.iter ol keep_lines ;
      Printf.fprintf oc "(* %s *)\n\n" separator ;
      Buffer.output_buffer oc b)
    style_file_name