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

open Viz_misc

(** returns a list of [(num, start, stop)] triplets
    with the line number, start and end position of each line. *)
let lines_coords text =
  let len = String.length text in
  let last = ref 0 in
  let num = ref 0 in
  let l = ref Q.empty in
  for i = 0 to len - 1 do
    if text.[i] = '\n'
    then begin
      l := Q.push !l (!num, !last, i - !last) ;
      last := i + 1 ;
      incr num
    end
  done ;
  Q.to_list
    (Q.push !l (!num, !last, len - !last))

type tag_data =
    HEADER of int
  | HUNK of int
  | ADDITION of int
  | REMOVAL of int
  | FILE of string * int

let is_prefix p t offset = Viz_misc.string_is_prefix p ~offset t

(** parse diff data and detect hunk headers, modified text, etc.
    @return [(start, tag_data list)] with start is the line number of the first hunk. *)
let analyze_diff_output text =
  let coords = lines_coords text in
  let rec skip_junk = function
    | (n, s1, _) :: ((_, s2, _) :: _ as tl) as l ->
	if is_prefix "---" text s1 && is_prefix "+++" text s2
	then (n, l)
	else skip_junk tl
    | _ ->
	raise Not_found in
  let (start, rest) = skip_junk coords in
  (start,
   Q.list_fold
     (fun q (n, s, len) ->
       if is_prefix "--- " text s
       then Q.push q (HEADER n)
       else if is_prefix "+++ " text s
       then begin
	 let filename =
	   let re = Str.regexp "[0-9a-f]+/\\(.*\\)  (" in
	   if Str.string_match re text (s + 4)
	   then Str.matched_group 1 text
	   else String.sub text (s + 4) (len - 4) in
	 Q.push_list q [ HEADER n ; FILE (filename, n - 1) ] end
       else if is_prefix "@@ " text s
       then Q.push q (HUNK n)
       else if is_prefix "-" text s
       then Q.push q (REMOVAL n)
       else if is_prefix "+" text s
       then Q.push q (ADDITION n)
       else q)
     rest)


let make_combo_box coords ~packing =
  let files =
    List.fold_right
      (fun arg acc ->
	match arg with
	| FILE (f, _) -> f :: acc
	| _ -> acc)
      coords [] in
  let box = GPack.hbox ~packing () in
  let (cb, _) as text_combo = GEdit.combo_box_text
    ~strings:("All files" :: files)
    ~packing:box#pack () in
  cb#set_active 0 ;
  text_combo

let rec find_line_num i = function
  | FILE (_, n) :: _ when i = 0 -> n
  | FILE _ :: tl ->
      find_line_num (i - 1) tl
  | _ :: tl ->
      find_line_num i tl
  | [] -> raise Not_found

let save_dialog parent text =
  let s = GWindow.file_chooser_dialog
      ~action:`SAVE ~parent
      ~destroy_with_parent:true
      ~title:"Save monotone diff output" () in
  s#add_button_stock `CANCEL `CANCEL ;
  s#add_select_button_stock `SAVE `SAVE ;
  s#set_default_response `SAVE ;
  ignore (s#connect#response (function
    | `CANCEL | `DELETE_EVENT -> s#misc#hide ()
    | `SAVE ->
	let f = some s#filename in
	s#misc#hide () ;
	try
	  with_file_out
	    (fun oc -> output_string oc text) f
	with Sys_error _ ->
	  Viz_types.errorf "Could not write monotone diff output to '%s'" f)) ;
  s

let view_diff ?parent (junk_end, tags_coords) text =
  let window = GWindow.dialog
      ~no_separator:true ?parent
      ~title:"Monotone diff output"
      ~type_hint:`NORMAL
      ~icon:(Lazy.force Icon.monotone) () in
  window#add_button_stock `SAVE `SAVE ;
  window#add_button_stock `CLOSE `CLOSE ;
  window#set_default_response `CLOSE ;
  let s = lazy (save_dialog window text) in
  ignore (window#connect#response (function
    | `CLOSE | `DELETE_EVENT -> window#destroy ()
    | `SAVE -> (Lazy.force s)#present () )) ;

  let buffer = GText.buffer ~text () in

  begin
    let junk_tag    = buffer#create_tag ~name:"junk"   [ `FOREGROUND "dark blue" ] in
    let header_tag  = buffer#create_tag ~name:"header" [ `FOREGROUND "white" ;
							 `BACKGROUND "dark gray" ] in
    let hunk_tag    = buffer#create_tag ~name:"hunk"   [ `BACKGROUND "#F0F090" ] in
    let modif_tag   = buffer#create_tag ~name:"modif"  [ `FOREGROUND "red" ; `WEIGHT `BOLD ] in

    buffer#apply_tag junk_tag
      ~start:buffer#start_iter ~stop:(buffer#get_iter (`LINE junk_end)) ;

    let apply_tag_on_line n tag =
      let start = buffer#get_iter (`LINE n) in
      buffer#apply_tag tag ~start ~stop:start#forward_to_line_end in
    List.iter
      (function
	| HEADER   n -> apply_tag_on_line n header_tag
	| HUNK     n -> apply_tag_on_line n hunk_tag
	| ADDITION n
	| REMOVAL  n -> apply_tag_on_line n modif_tag
	| FILE _ -> ())
      tags_coords
  end ;

  let vbox = window#vbox in
  let ((cb, _) : _ GEdit.text_combo) = make_combo_box tags_coords vbox#pack in
  let sw = GBin.scrolled_window ~packing:(vbox#pack ~expand:true) () in
  let v =
    GText.view ~buffer ~cursor_visible:false ~editable:false
      ~width:500 ~height:300 ~packing:sw#add () in
  v#misc#modify_font_by_name "Monospace" ;
  v#misc#grab_focus () ;
  ignore
    (cb#connect#changed
       (fun () ->
	 let act = cb#active in
	 if act = 0
	 then
	   ignore (v#scroll_to_iter ~use_align:true ~xalign:0. ~yalign:0. buffer#start_iter)
	 else if act > 0
	 then
	   let n = find_line_num (act - 1) tags_coords in
	   ignore (v#scroll_to_iter ~use_align:true ~xalign:0. ~yalign:0. (buffer#get_iter (`LINE n)))
       )) ;

  window#misc#show ()

let view ~parent text =
  let parent = GWindow.toplevel parent in
  try
    view_diff ?parent (analyze_diff_output text) text
  with Not_found ->
    let d =
      GWindow.message_dialog
	~message:"No changes"
	~message_type:`INFO
	~buttons:GWindow.Buttons.close
	?parent
	~destroy_with_parent:true
	~title:"Monotone diff output" () in
    ignore (d#connect#response (fun _ -> d#destroy ())) ;
    d#show ()