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 begin
	 let filename =
	   let s = String.sub text (s + 4) (len - 4) in
	   try String.sub s 0 (String.rindex s '\t')
	   with Not_found -> s in
	 Q.push_list q [ HEADER n ; FILE (filename, n) ] end
       else if is_prefix "+++ " text s
       then Q.push q (HEADER n)
       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
      ~icon:(Lazy.force Icon.monotone)
      ~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#after#close s#misc#hide) ;
  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 ctrl (junk_end, tags_coords) text orig_text =
  let window = GWindow.dialog
      ~no_separator:true
      ~title:"Monotone diff output"
      ~screen:ctrl#get_toplevel#screen
      ~type_hint:`NORMAL
      () in
  window#add_button_stock `SAVE `SAVE ;
  window#add_button_stock `CLOSE `CLOSE ;
  window#set_default_response `CLOSE ;
  let s = lazy (save_dialog window orig_text) in
  ignore (window#connect#after#close window#destroy) ;
  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:675 ~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 replacement_char = '\x7f' (* DEL *)
let careful_convert_ascii o =
  let s = String.copy o in
  for i = 0 to String.length s - 1 do
    if int_of_char s.[i] >= 0x80
    then s.[i] <- replacement_char
  done ;
  s
let careful_convert_utf8 o =
  let s = String.copy o in
  let len = String.length s in
  let pos = ref 0 in
  while !pos < len do
    let prev_pos = !pos in
    try ignore (Glib.Utf8.to_unichar_validated s ~pos)
    with
    | Glib.Convert.Error (Glib.Convert.ILLEGAL_SEQUENCE, _) ->
	pos := prev_pos ;
	s.[!pos] <- replacement_char ;
	incr pos
    | Glib.Convert.Error (Glib.Convert.PARTIAL_INPUT, _) ->
	String.fill s prev_pos (len - prev_pos) replacement_char ;
	pos := len
  done ;
  s

let utf8ize =
  let (is_utf8, _) = Glib.Convert.get_charset () in
  if not is_utf8
  then fun s ->
    try Glib.Convert.locale_to_utf8 s
    with Glib.Convert.Error _ ->
      careful_convert_ascii s
  else fun s ->
    if Glib.Utf8.validate s
    then s
    else careful_convert_utf8 s


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

let show ctrl old_id new_id =
  match ctrl#get_mtn with
  | None -> ()
  | Some mtn ->
      try
	Monotone.run_monotone_diff
	  mtn
	  (ctrl#status "monotone")
	  (fun res ->
	    match res with
	    | `OUTPUT d ->
		view ctrl d
	    | `SUB_PROC_ERROR msg ->
		ctrl#error_notice msg)
	  (old_id, new_id)
      with Viz_types.Error msg ->
	ctrl#error_notice msg