Source file sourceview.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Source views *)

module B = Stk.Textbuffer
open Stk.Misc

let _ = Sourceview_rc.read ();;
let _ = Sourceview_rc.write ();;
(* FIXME: when equivalent is present in Stk
Gtksv_utils.set_source_style_scheme (Gtksv_utils.read_style_scheme_selection());;*)

let factory_name = Sourceview_rc.factory_name

let get_att name l = List.assoc_opt name l

let get_att_f ?default f name l =
  match get_att name l with
    None -> default
  | Some s -> Some (f s)
;;

(** {2 Languages} *)


(*FIXME
let language_manager = Gtksv_utils.source_language_manager
*)
let lang_of_filename filename =
  try
    let (_,mime) =
      List.find
        (fun (re,_) ->
           let re = Str.regexp re in
           Str.string_match re filename 0
        )
        (Ocf.get Sourceview_rc.filename_language_patterns)
    in
    (*language_manager#guess_language ~content_type: mime ()*)
    Some mime
  with
    Not_found ->
      None

(* Register higlo lexers with mime-type based names *)
let () =
  let l = [
      ["text/x-ocaml"], "ocaml" ;
      ["text/xml"; "text/html"; "text/xhtml"], "xml" ;
      ["text/x-dot"], "dot" ;
      ["text/x-json"], "json" ;
    ]
  in
  let f (mimes, lexer_name) =
    match Higlo.Lang.get_lexer lexer_name with
    | exception e -> Log.warn (fun m -> m "%s" (Printexc.to_string e))
    | lexer ->
        List.iter (fun mime -> Higlo.Lang.register_lang mime lexer) mimes
  in
  List.iter f l

(** {2 Utilities} *)

let utf8_of_filename ?(full=false) f =
  Misc.filename_to_utf8 (if full then f else Filename.basename f)

type location =
  Linechar of int * int
    | Linechars of int * (int * int)
    | Char of int
    | Chars of int * int

let location_of_string s =
  try
    let f a b c = Linechars (a, (b, c)) in
    Some (Scanf.sscanf s "%d,%d-%d" f)
  with
    _ ->
      try let f a b = Linechar(a,b) in Some (Scanf.sscanf s "%d,%d" f)
      with _ ->
          try let f a b = Chars(a,b) in Some (Scanf.sscanf s "%d-%d" f)
          with _ ->
              try Some (Char(Misc.my_int_of_string s))
              with _ -> None
;;
let string_of_location = function
  Linechar (l, c) -> Printf.sprintf "%d,%d" l c
| Linechars (l, (c1,c2)) -> Printf.sprintf "%d,%d-%d" l c1 c2
| Char c -> string_of_int c
| Chars (c1,c2) -> Printf.sprintf "%d-%d" c1 c2
;;

let string_of_line_char (l,c) = Printf.sprintf "%d,%d" l c

let line_char_of_location b = function
  None -> (0, 0)
| Some (Linechar (l,c)) -> (l,c)
| Some (Linechars (l,(c,_))) -> (l,c)
| Some (Char c)
| Some (Chars (c,_)) -> B.line_char_of_offset b c

(** {2 Bookmarks} *)

let bookmarks = Bookmarks.create_from_ocf_wrappers
  ~doc: "Sourceviews bookmarks"
  Ocf.Wrapper.(triple string int int);;
let _ = Bookmarks.load bookmarks Sourceview_rc.bookmarks_rc_file;;
let store_bookmarks () =
  Bookmarks.store bookmarks Sourceview_rc.bookmarks_rc_file;;

(** {2 Saving and loading open buffers} *)

let open_buffers_file =
  ref (Config.local_dir_rc_file (factory_name^".buffers"))

let xml_of_file f =
  let atts = (("","file"), f#filename) ::
    (List.map (fun (a, v) -> (("",a), v)) f#attributes)
  in
  Xml.E ((("","file"), atts), [])

let xml_of_file_list l =
  Xml.E ((("","list"), []), List.map xml_of_file l)

let file_of_xml = function
  Xml.E ((("","file"), atts), _) ->
    begin
      match List.partition (fun ((_,s),_) -> s = "file") atts with
        ((_,filename) :: _), others ->
          Some (filename, List.map (fun ((_,s),v) -> (s, v)) others)
      | _ -> None
    end
| _ -> None

let file_list_of_xml = function
  Xml.E ((("","list"), _), l) ->
    List.rev
      (List.fold_left
       (fun acc xml ->
          match file_of_xml xml with
            None -> acc
          | Some f -> f :: acc
       )
         []
         l
      )
| _ -> []

let read_open_buffers_file f =
  Xml.read_xml_file ~strip: true f file_list_of_xml

let write_open_buffers_file file buffers  =
  let xml = xml_of_file_list buffers in
  let s = Xml.string_of_xml xml in
  Misc.file_of_string ~file s
;;

(** {2 Recently used buffers} *)

let buffer_name_history = ref []
let remove_buffer_from_history name =
  buffer_name_history := List.filter ((<>) name) !buffer_name_history
let make_buffer_first_in_history name =
  remove_buffer_from_history name;
  buffer_name_history := name :: !buffer_name_history
;;
let rename_buffer_in_history oldname newname =
  buffer_name_history := List.map
    (fun s ->  if s = oldname then newname else s)
    !buffer_name_history

(** {2 The history of pastable text} *)

let pastable_history = Minibuffer.history ()

  (** {2 The buffer, using GtkSourceView.source_buffer} *)

type view_cbs = {
    on_cursor_moved : Stk.Events.callback_id ;
    on_modified_changed : Stk.Events.callback_id ;
    on_source_language_changed : Stk.Events.callback_id ;
  }

module IMap = Stk.Misc.IMap

class my_buffer buffer =
  object(self)
    method buffer = buffer

    val mutable view_cbs = IMap.empty
    method disconnect_view view_id =
      match IMap.find_opt view_id view_cbs with
      | None -> ()
      | Some c ->
        List.iter (fun id -> B.disconnect buffer id)
            [ c.on_cursor_moved ;
              c.on_modified_changed ;
              c.on_source_language_changed ;
            ]
    method connect_view view_id ~on_cursor_moved ~on_modified_changed
      ~on_source_language_changed =
      self#disconnect_view view_id ;
      let on_cursor_moved = B.connect buffer B.Cursor_moved on_cursor_moved in
      let on_modified_changed = B.connect buffer B.Modified_changed on_modified_changed in
      let on_source_language_changed = B.connect buffer B.Source_language_changed
        on_source_language_changed
      in
      view_cbs  <- IMap.add view_id
        { on_cursor_moved ;
          on_modified_changed ;
          on_source_language_changed ;
        } view_cbs

    method set_syntax_mode lang = B.set_source_language buffer lang
    method syntax_mode = B.source_language buffer

    method text ?(start=0) ?size () = B.to_string ~start ?size buffer

    method private pcre_offset_tuple_to_char_indices text (start,stop) =
      let len1 = Stk.Utf8.length (String.sub text 0 start) in
      (len1, len1 + Stk.Utf8.length (String.sub text start (stop-start)))

    method private re_search_backward re text =
      let res = Pcre.exec_all ~rex: re text in
      let len = Array.length res in
      if len > 0 then
        try Pcre.get_substring_ofs res.(len-1) 0
        with Invalid_argument _ -> raise Not_found
      else
        raise Not_found

    method private re_search_forward re text =
      let res = Pcre.exec ~rex: re text in
      try Pcre.get_substring_ofs res 0
      with Invalid_argument _ -> raise Not_found

    method re_search forward ?(start=0) ?(stop=B.size buffer) re =
      try
        (* warning: if we search backward, we must start on charcrater back that the
           one indicated, because Str starts with the given start position, not before the
           start position; that is different from the [GSourceView3.iter_backward_search] function
           and the way gtk handles this in general, so we make this hack to act the same way.
           *)
        let size = stop - start in
        let text = B.to_string ~start ~size buffer in
        let f = if forward then self#re_search_forward else self#re_search_backward in
(*
        prerr_endline (Printf.sprintf "offset=%d" offset);
*)
        let (char_start, char_end) = self#pcre_offset_tuple_to_char_indices text (f re text) in
        let (char_start, char_end) = (char_start + start, char_end + start) in
        (*        prerr_endline (Printf.sprintf "found: start=%d end=%d" char_start char_end);*)
        Some (Stk.Rope.range ~start:char_start ~size:(char_end - char_start))
      with
        Not_found ->
          None

  end

(** {2 Modes} *)

class type mode =
  object
    method name : string
    method key_bindings : (Stk.Key.keystate list * string) list
    method menus : (string * Stk.Menu.menu_entry list) list

    method to_display : string -> string
    method from_display : string -> string
    method set_to_display : (string -> string) -> unit
    method set_from_display : (string -> string) -> unit
    method word_re : string
  end

class empty_mode : mode =
  object
    val mutable to_display = fun s -> s
    val mutable from_display = fun s -> s
    method name = "empty mode"
    method key_bindings = []
    method menus = []
    method to_display s = to_display s
    method from_display s = from_display s
    method set_to_display f = to_display <- f
    method set_from_display f = from_display <- f
    method word_re = "[a-zA-Z0-9]+"
  end

let available_modes = Hashtbl.create 37
let register_mode ?(replace=false) m =
  try
    ignore(Hashtbl.find available_modes m#name);
    if replace then
      Hashtbl.replace available_modes m#name m
    else
      failwith (Printf.sprintf "Mode %s already registered." m#name)
  with
    Not_found ->
      Hashtbl.add available_modes m#name m

let get_mode name =
  try Hashtbl.find available_modes name
  with Not_found -> failwith (Printf.sprintf "Mode %s unknown." name)

let available_mode_names () =
  Hashtbl.fold (fun name _ acc -> name :: acc) available_modes []
;;

(** {2 Associating [buffered_files] and [modes]} *)

let mode_name_of_filename filename =
  try
    let (_,mode_name) =
      List.find
        (fun (re,_) ->
           let re = Str.regexp re in
           Str.string_match re filename 0
        )
        (Ocf.get Sourceview_rc.filename_mode_patterns)
    in
    Some mode_name
  with
    Not_found ->
      None

let mode_of_filename file =
  match mode_name_of_filename file with
    None -> None
  | Some name ->
      try Some (get_mode name)
      with Failure s ->
          Misc.error_message s;
          None
;;

(** {2 A buffer associated to a file} *)

exception Newer_file_exists of string

class buffered_file ?(attributes=[]) ?(xmls=[]) ?loc ~name ~filename (buffer:my_buffer) =
  let enc =
    match get_att "encoding" attributes with
      None -> Some (Ocf.get Core_rc.encoding)
    | Some "" -> None
    | Some s -> Some s
  in
  let mode =
    try
      match get_att "mode" attributes with
        None -> mode_of_filename filename
      | Some m -> Some (get_mode m)
    with Failure s -> Misc.error_message s; None
  in
  let stxmode =
    match get_att "stxmode" attributes with
    | None
    | Some "" -> lang_of_filename filename
    | Some s -> Some s
  in
  object(self)
    val mutable name : string = name
    method name = name
    method set_name s = name <- s

    val mutable filename : string = filename
    method filename = filename
    method set_filename f = filename <- f

(* FIXME: update when marks available in Stk
    val mutable source_marks = []
    method source_marks = source_marks
    method set_source_marks l = source_marks <- l
    method add_source_mark sm = source_marks <- sm :: source_marks

    method update_source_marks =
      let bookmarks = List.filter
        (fun (bm_name, (f,_,_)) -> Misc.safe_same_files filename f)
        (Bookmarks.list bookmarks)
      in
      buffer#remove_source_marks
        ~start: buffer#start_iter
        ~stop: buffer#end_iter ();
      List.iter
        (fun (bm,(_,l,c)) ->
           try
             let sm = buffer#create_source_mark ~name: bm ~category: "bookmark"
               (buffer#get_iter (`LINECHAR (l,c)))
             in
             self#add_source_mark (bm, sm)
           with
             _ -> ()
        )
        bookmarks

    method private update_source_marks_in_bookmarks =
      List.iter
        (fun (name, sm) -> Bookmarks.remove bookmarks name)
        self#source_marks;
      let f (name, sm) =
        let it = buffer#get_iter_at_mark sm#coerce in
        if sm#get_line > 0 then
          (
           let bm = (filename, it#line, it#line_index) in
           Bookmarks.set bookmarks name bm
          )
      in
      let markers = buffer#get_markers_in_region
        ~start: buffer#start_iter ~stop: buffer#end_iter
      in
      List.iter f markers;
      store_bookmarks();
      List.iter buffer#delete_marker self#source_marks;
      self#set_source_marks [];
      self#update_source_marks
*)

    val buffer : my_buffer = buffer
    method buffer = buffer

    method attributes =
      let atts =
        [
          "encoding", (match self#encoding with None -> "" | Some s -> s) ;
          "mode", (match self#mode with None -> "" | Some m -> m#name) ;
          "stxmode", (match self#syntax_mode with None -> "" | Some s -> s) ;
        ]
      in
      let b = buffer#buffer in
      match B.last_used_cursor b with
      | None -> atts
      | Some c ->
          let (line,char) = B.(line_char_of_offset b (cursor_offset b c)) in
          ("location", string_of_line_char (line,char)) :: atts

    val mutable date = None
    method date = date
    method set_date d = date <- d

    val mutable encoding : string option = enc
    method encoding = encoding
    method set_encoding e = encoding <- e

    method of_utf8 s =
      match encoding with
        None -> Misc.of_utf8 s
      | Some coding -> Misc.of_utf8 ~coding s
    method to_utf8 s =
      match encoding with
        None -> Misc.to_utf8 s
      | Some coding -> Misc.to_utf8 ~coding s

    val mutable mode = (mode : mode option)
    method mode = mode
    method set_mode m =
      match mode with
        None -> mode <- m
      | Some m2 ->
          let b = buffer#buffer in
          let s = m2#from_display (B.to_string b) in
          mode <- m;
          B.set_text b (self#mode_to_display s);
          B.set_modified b false

    method mode_key_bindings =
      match mode with
        None -> []
      | Some m -> m#key_bindings
    method mode_menus =
      match mode with
        None -> []
      | Some m -> m#menus
    method mode_name =
      match mode with
        None -> None
      | Some m -> Some m#name

    method set_syntax_mode lang = buffer#set_syntax_mode lang
    method syntax_mode = buffer#syntax_mode

    method mode_from_display s =
      match mode with
        None -> s
      | Some m -> m#from_display s

    method mode_to_display s =
      match mode with
        None -> s
      | Some m -> m#to_display s

    method load_file filename =
      if Sys.file_exists filename then
        begin
          (* FIXME: handle errors occuring while opening file *)
          let text =
            try self#mode_to_display
              (self#to_utf8 (Misc.string_of_file filename))
            with _ -> ""
          in
          B.set_text buffer#buffer text;
          B.reset_history buffer#buffer;
          B.set_modified buffer#buffer false;
        end;
      self#update_date;
      (*self#update_source_marks*)

    method newer_file_exists =
      let d = Misc.mod_date_of_file filename in
      match date with
        None -> true
      | Some d2 -> d2 < d

    method write_file ?(fail_if_newer=false) () =
      if self#newer_file_exists && fail_if_newer then
        raise (Newer_file_exists filename);
      let utf8 = B.to_string buffer#buffer in
      let s = self#of_utf8 (self#mode_from_display utf8) in
      Misc.file_of_string ~file: filename s;
      B.set_modified buffer#buffer false;
      self#update_date
(*      self#update_source_marks_in_bookmarks*)

    method update_date =
      date <- Some (Misc.mod_date_of_file filename)

    method range_from_range_in_file ~left ~right =
      let from_display = self#mode_from_display (B.to_string buffer#buffer) in
      let (left, right) =
        let left =
          Stk.Utf8.length
            (self#mode_to_display
             (String.sub from_display 0 left))
        in
        let right =
          Stk.Utf8.length
            (self#mode_to_display
             (String.sub from_display 0 right))
        in
        (left, right)
      in
      (left, right)

    method line_offset_from_line_in_file line =
      let char_offset = Misc.char_of_line filename line in
      let from_display = self#mode_from_display (B.to_string buffer#buffer) in
      Stk.Utf8.length
        (self#mode_to_display (String.sub from_display 0 char_offset))

    initializer
      self#set_syntax_mode stxmode;
      self#load_file filename;
(*
      let on_marker_update iter =
        prerr_endline "marker_update";
        List.iter
          (fun (bm, m) ->
             let it = buffer#get_iter_at_mark m#coerce in
             prerr_endline
               (Printf.sprintf "marker %s on line %d"
                bm it#line
               )
          )
          self#source_marks
      in
      ignore(buffer#connect#source_mark_updated on_marker_update);
*)

  end

(** {2 The views} *)

class sourceview ?(attributes=[]) ?(xmls=[])(topwin : View.topwin)
  f_on_destroy f_set_active f_dup
  (f_file_rename : string -> string -> unit) (file : buffered_file) =
  let vbox = Stk.Pack.vbox () in
  let () = vbox#set_border_width__ 1 in
  let wscroll = Stk.Bin.scrollbox ~pack:vbox#pack () in
  let () = wscroll#set_vscrollbar_covers_child false in
  let show_line_numbers =
    get_att_f Misc.bool_of_string "line_numbers" attributes = Some true
  in
  let show_line_markers =
    get_att_f Misc.bool_of_string "line_markers" attributes = Some true
  in
  let highlight_current_line =
    get_att_f Misc.bool_of_string "highlight_current_line" attributes = Some true
  in
  let wrap_mode =
    get_att_f ~default: (Ocf.get Sourceview_rc.default_wrap_mode)
      Stk.Textview.wrap_mode_of_string "wrap_mode" attributes
  in
  let source_view =
    Stk.Textview.textview
      ~buffer:file#buffer#buffer
      ~editable:true
(*      ~auto_indent:true
      ~insert_spaces_instead_of_tabs:true ~tab_width:2*)
      ~highlight_current_line
      ~show_line_numbers
      ~show_line_markers
      ?wrap_mode
(*      ~smart_home_end: `ALWAYS*)
      ~theme:(Ocf.get Sourceview_rc.default_theme)
      ~pack: wscroll#set_child
      ()
  in
  let hbox_state = Stk.Pack.hbox
    ~pack:(vbox#pack ~vexpand:0 ~hexpand:(-1)) ()
  in
  let add_state fopt =
    let wl = Stk.Text.label ~pack:(hbox_state#pack ~hexpand:0) () in
    let p = wl#padding in
    wl#set_padding { p with left = 5; right = 5 };
    begin
      match fopt with
        None -> ()
      | Some f ->
          ignore
            (wl#connect Stk.Widget.Button_pressed
             (fun ev ->
                if ev.Stk.Widget.button = 1 then
                  (f (); true)
                else
                  false
             )
            )
    end;
    wl
  in
  let on_stx_click () =
    Commands.eval_command (factory_name^"_popup_syntax_mode_choice")
  in
  let on_mode_click () =
    Commands.eval_command (factory_name^"_popup_mode_choice")
  in
  let wl_modified = add_state None in
  let wl_file = add_state None in
  let wl_loc = add_state None in
  let wl_stx_mode = add_state (Some on_stx_click) in
  let wl_mode = add_state (Some on_mode_click) in
  let wl_encoding = add_state None in
  let ref_on_destroy = ref (fun () -> ()) in
  object(self)
    inherit View.dyn_label
    inherit View.dyn_destroyable
      (fun () -> !ref_on_destroy () ; source_view#destroy;vbox#destroy)
    inherit View.pickable true

    method minibuffer = topwin#minibuffer

    val mutable file = file

    method source_view = source_view
    method source_buffer = file#buffer
    method scrollbox = wscroll

    method box = vbox#coerce

    method private write_file =
      let rec do_write ~fail_if_newer =
        try
          file#write_file ~fail_if_newer ();
          let msg = Printf.sprintf "Wrote %s"
            (utf8_of_filename ~full: true file#filename)
          in
          Misc.display_message msg;
          Lwt.return_unit
        with
          Newer_file_exists _ ->
            let do_it () = do_write ~fail_if_newer: false in
            Misc.confirm self#minibuffer
              (Printf.sprintf "%s was edited since last visited; write anyway ?"
               (utf8_of_filename ~full: true file#filename))
              do_it
        | Failure s
        | Sys_error s ->
        (*| Glib.Convert.Error (_,s) ->*)
            Misc.error_message (Misc.to_utf8 s);
            Lwt.return_unit
      in
      do_write ~fail_if_newer: true

    method do_save =
      self#write_file

    method save =
      let f () =
        if self#buffer_modified then
          self#do_save
        else
          (
           Misc.set_active_action_message "(No changes need to be saved)";
           Lwt.return_unit
          )
      in
      Some f
    method save_as =
      let f () =
        let save newname =
          let do_it () =
            try
              f_file_rename file#filename newname;
              self#write_file
            with
              Failure s ->
                Misc.error_message (Misc.to_utf8 s);
                Lwt.return_unit
          in
          if Sys.file_exists newname then
            Misc.confirm self#minibuffer
              (Printf.sprintf "Overwrite %s ?" (utf8_of_filename ~full: true newname))
              do_it
          else
            do_it ()
        in
        Misc.select_file
          self#minibuffer
          ~title: (Printf.sprintf "Save %s as ..." (utf8_of_filename file#filename))
          ((Filename.dirname file#filename)^"/")
          save
      in
      Some f

    method paste = Some (fun () -> Commands.async_command (factory_name^"_paste"))
    method copy = Some (fun () -> Commands.async_command (factory_name^"_copy"))
    method cut = Some (fun () -> Commands.async_command (factory_name^"_cut"))

    method close = vbox#destroy

    method kind = factory_name

    method attributes =
      let lc = B.(line_char_of_offset file#buffer#buffer
         (source_view#cursor_offset source_view#insert_cursor))
      in
      [
        "location", string_of_line_char lc ;
        "line_numbers", (Misc.string_of_bool source_view#show_line_numbers) ;
        "line_markers", (Misc.string_of_bool source_view#show_line_markers) ;
        "highlight_current_line", (Misc.string_of_bool source_view#highlight_current_line) ;
        "wrap_mode", (Stk.Textview.string_of_wrap_mode source_view#wrap_mode) ;
      ] @ file#attributes

    method xml_children = ([] : Xml.t list)

    method file = file
    method filename = file#filename
    method buffer_name = file#name
    method buffer_modified = B.modified file#buffer#buffer

    method select_location loc =
      let b = file#buffer#buffer in
      let (start,size) =
        match loc with
        | Linechar (line,char) ->
            let o = B.offset_of_line_char b ~line ~char in
            (o, 1)
        | Linechars (l,(start,stop)) ->
            let start = B.offset_of_line_char b ~line:l ~char:start in
            let size = stop - start + 1 in
            (start, size)
        | Chars (start,stop) -> (start,stop - start + 1)
        | Char start -> (start,1)
      in
      source_view#select_range ~start ~size

    method select_location_opt = function
      None -> ()
    | Some loc -> self#select_location loc

    method has_focus = source_view#is_focus

    method location_in_buffer =
      let b = file#buffer#buffer in
      B.(line_char_of_offset b (cursor_offset b source_view#insert_cursor))

    method current_line =
      fst self#location_in_buffer

    method select_range_in_file ~left ~right () =
      let (start, stop) = file#range_from_range_in_file ~left ~right in
      source_view#select_range ~start ~size:(stop-start)

    val mutable on_focus_in = fun () -> ()
    method set_on_focus_in (f: unit -> unit) =
      on_focus_in <-
        (fun _ ->
           f_set_active self;
           f ();
        )

    method grab_focus =
      source_view#grab_focus ();
      source_view#scroll_to_cursor ();
      f_set_active self;
      ()

    method my_set_label =
      self#set_label (Printf.sprintf "%s%s" (utf8_of_filename file#name)
       (if self#buffer_modified then " *" else ""))

    method set_file ?(focus_in=false) (f : buffered_file) =
      file#buffer#disconnect_view (Oo.id self);
      file <- f;
      source_view#set_buffer f#buffer#buffer ;
      source_view#scroll_to_cursor () ;
      self#connect_buffer_events;
      self#my_set_label;
      self#display_state;
      self#display_location ;
      if focus_in then on_focus_in ()

    method dup : View.topwin -> View.gui_view option = fun topwin ->
      Some (f_dup file topwin)

    method display_state =
      self#display_modified;
      self#display_buffer_name ;
      self#display_encoding ;
      self#display_location ;
      self#display_stx_mode ;
      self#display_mode

    method display_buffer_name =
      wl_file#set_text (utf8_of_filename file#name)

    method display_modified =
      wl_modified#set_text (if self#buffer_modified then "*" else "")

    method display_encoding =
      let enc =
        match file#encoding with
          None -> "default encoding"
        | Some s -> s
      in
      wl_encoding#set_text (Printf.sprintf " %s " (Misc.to_utf8 enc))

    method display_location =
      let b = file#buffer#buffer in
      let (line,char) = B.line_char_of_offset b
        (source_view#cursor_offset source_view#insert_cursor)
      in
      wl_loc#set_text (Printf.sprintf "L%d-C%d" (line+1) (char+1))

    method display_stx_mode =
      let lang =
        match B.source_language file#buffer#buffer with
          None -> "[no highlight]"
        | Some lang -> Printf.sprintf "[%s]" lang(*#name*)
      in
      wl_stx_mode#set_text (Misc.to_utf8 lang)

    method display_mode =
      let mode =
        match file#mode_name with
          None -> "(no mode)"
        | Some name -> Printf.sprintf "(%s)" name
      in
      wl_mode#set_text (Misc.to_utf8 mode)

    method connect_buffer_events =
      file#buffer#connect_view (Oo.id self)
        ~on_cursor_moved:(fun (c,_) -> if c = source_view#insert_cursor then self#display_location)
        ~on_modified_changed:(fun _ -> self#display_modified; self#my_set_label)
        ~on_source_language_changed:(fun _ -> self#display_stx_mode; self#my_set_label)

    method key_bindings =
      file#mode_key_bindings @
        (Ocf.get Sourceview_rc.key_bindings)

    method bookmarks_menus =
      let l = Bookmarks.list bookmarks in
      let l = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) l in
      let entries =
        List.map
          (fun (name, (file,line,char)) ->
            let com () =
              Commands.eval_command (Printf.sprintf "open_file %s" (Filename.quote file));
              if self#filename = file then
                ignore(source_view#move_cursor ~line ~char ())
            in
            let label =
               Printf.sprintf "%s (%s, %d, %d)" name (Filename.basename file) line char
             in
            `I (Misc.escape_menu_label (Misc.to_utf8 label), com)
          )
          l
      in
      [ "Bookmarks", entries]

    method menus : (string * Stk.Menu.menu_entry list) list =
      let com com () = Commands.async_command (Printf.sprintf "%s_%s" factory_name com) in
      (* FIXME: do some kind of merging between the sourceview menus
         and the mode menus *)
      [
        "Search",
        [ `I ("Search forward", com "search") ;
          `I ("Search backward", com "search_backward") ;
          (*`S ; FIXME when GToolbox will reintroduce, not using deprecated gtkitemfactory *)
          `I ("Search regexp forward", com "search_re") ;
          `I ("Search regexp backward", com "search_re_backward") ;
          (*`S ;*)
          `I ("Query/replace", com "query_replace") ;
        ]
      ] @
        self#bookmarks_menus @
        file#mode_menus

    method update_menus = topwin#update_menus

    method beginning_of_line = ignore(source_view#move_to_line_start ())
    method end_of_line = ignore(source_view#move_to_line_end ())
 (*     let b = file#buffer in
      let it = b#get_iter `INSERT in
      let (l,_) = location_of_iter it in
      self#set_location (l,max_int)*)

(*    method set_scroll_on_change =
      file#buffer#connect_delete_range (Oo.id self)
        (fun ~start ~stop -> self#place_cursor start);
      file#buffer#connect_insert_text (Oo.id self)
        (fun it _ -> self#place_cursor it)

    method unset_scroll_on_change =
      file#buffer#remove_delete_range (Oo.id self);
      file#buffer#remove_insert_text (Oo.id self)
*)
    method undo = B.undo file#buffer#buffer
(*
      let b = file#buffer in
      if b#can_undo then
        begin
          self#set_scroll_on_change;
          b#undo ();
          self#unset_scroll_on_change;
        end
*)
    method redo = B.redo file#buffer#buffer
(*
      let b = file#buffer in
      if b#can_redo then
        begin
          self#set_scroll_on_change;
          b#redo ();
          self#unset_scroll_on_change;
        end
*)
(*    method place_cursor ?(scroll=true) where =
      file#buffer#place_cursor ~where;
      if scroll then ignore(source_view#scroll_to_iter where);
      self#update_my_location
*)
    method forward_word = ignore(source_view#forward_to_word_end ())
(*      let b = file#buffer in
      let it = b#get_iter `INSERT in
      self#place_cursor it#forward_word_end*)
    method backward_word = ignore(source_view#backward_to_word_start ())
(*      let b = file#buffer in
      let it = b#get_iter `INSERT in
      self#place_cursor it#backward_word_start*)
    method forward_line = ignore(source_view#dline_forward 1)
(*      let (l,c) = my_location in
      self#set_location (l+1,c)*)
    method backward_line = ignore(source_view#dline_backward 1)
(*      let (l,c) = my_location in
      self#set_location (l-1,c)*)
    method forward_char = ignore(source_view#char_forward 1)
(*      let b = file#buffer in
      let it = b#get_iter `INSERT in
      self#place_cursor it#forward_cursor_position
*)
    method backward_char = ignore(source_view#char_backward 1)
(*
      let b = file#buffer in
      let it = b#get_iter `INSERT in
      self#place_cursor it#backward_cursor_position
*)
    method cut_to_selection ?(concat : [`APPEND | `PREPEND] option) ~start ~stop () =
      let size = stop - start in
      Log.debug (fun m -> m "%s#cut_to_selection start=%d, stop=%d, size=%d"
        source_view#me start stop size);
      match source_view#delete ~honor_readonly:true ~start ~size () with
      | "" -> ()
      | text ->
          match concat with
          | None ->
              pastable_history#add text;
              let>() = Tsdl.Sdl.set_clipboard_text text in
              ()
          | Some p ->
              let sel =
                if Tsdl.Sdl.has_clipboard_text () then
                  let> str = Tsdl.Sdl.get_clipboard_text () in
                  str
                else
                  ""
              in
              let text =
                match p with
                  `PREPEND -> text^sel
                | `APPEND -> sel^text
              in
                pastable_history#add text;
              let>() = Tsdl.Sdl.set_clipboard_text text in
              ()

    method kill_line ~append =
      let b = file#buffer#buffer in
      match B.dup_cursor b source_view#insert_cursor with
      | None -> ()
      | Some c ->
          let start = B.cursor_offset b c in
          let o =
            match B.move_cursor_to_line_end b c with
            | None -> start
            | Some o -> o
          in
          let stop =
            if start = o then
              match B.forward_cursor b c 1 with
              | None -> start
              | Some n -> n
            else
              o
          in
          B.remove_cursor b c;
          let concat = if append then Some `APPEND else None in
          self#cut_to_selection ?concat ~start ~stop ()

    method kill_word ?concat forward =
      let b = file#buffer#buffer in
       match B.dup_cursor b source_view#insert_cursor with
      | None -> ()
      | Some c ->
          let start = B.cursor_offset b c in
          let (start, stop) =
            if forward then
              match B.forward_cursor_to_word_end b c with
              | None -> (start, start)
              | Some n -> (start, n)
            else
              match B.backward_cursor_to_word_start b c with
              | None -> (start, start)
              | Some n -> (n, start)
          in
          B.remove_cursor b c;
          self#cut_to_selection ?concat ~start ~stop ()

    method insert text =
      source_view#insert ~honor_readonly:true text

    method delete_char forward =
      ignore(
       (if forward then source_view#delete_forward else source_view#delete_backward)
         ~honor_readonly:true 1)

    method transpose_chars = source_view#transpose_chars ~honor_readonly:true ()
    method transpose_lines = source_view#transpose_lines ~honor_readonly:true ()
    method transpose_words = source_view#transpose_words ~honor_readonly:true ()
(*      let b = file#buffer in
      let insert = b#get_iter `INSERT in
      if insert#is_end || insert#is_start then
        ()
      else
        let stop = insert#backward_char in
        let c = b#get_text ~start: insert ~stop () in
        b#begin_user_action ();
      b#delete ~start: insert ~stop;
      let iter = insert#forward_char in
      b#insert ~iter c;
      self#place_cursor iter;
      b#end_user_action ()

    method transpose_lines =
      let b = file#buffer in
      let insert = b#get_iter `INSERT in
      let line = insert#line in
      if line = 0 then
        ()
      else
        (
         let (line1_start, line1_stop) =
           ((if insert#starts_line then insert else insert#backward_line#forward_line),
            (if insert#is_end then insert else insert#forward_line))
         in
         let prevline_start = line1_start#backward_line in
         (*
           prerr_endline (Printf.sprintf "prevline_start:%s" (string_of_location (location_of_iter prevline_start)));
            *)
         let prevline_stop =
           (* do not cut the line with the ending '\n' if we are at the end of the buffer,
              to prevent adding a new blank line *)
           if line1_stop#is_end || line1_start#equal line1_stop then
             prevline_start#forward_to_line_end
           else
             line1_start
         in
         (*
            prerr_endline (Printf.sprintf "prevline_stop:%s" (string_of_location (location_of_iter prevline_stop)));
            *)
         let prev_line = b#get_text ~start: prevline_start ~stop: prevline_stop () in
         let prev_line =
           if line1_stop#is_end || line1_start#equal line1_stop then
             "\n"^prev_line
           else
             prev_line
         in
         (*
            let sline = b#get_text ~start: line1_start ~stop: line1_stop () in
            prerr_endline (Printf.sprintf "prev_line=\"%s\"" (self#of_utf8 prev_line));
            prerr_endline (Printf.sprintf "line=\"%s\"" (self#of_utf8 sline));
            *)
         b#begin_user_action ();
         self#place_cursor line1_stop;
         b#delete ~start: prevline_start ~stop: line1_start;
         b#insert prev_line;
         self#goto_line (line + 1);
         b#end_user_action ()
        )

    method transpose_words =
      let b = file#buffer in
      let insert = b#get_iter `INSERT in
      (*
         prerr_endline (Printf.sprintf "insert iter starts word: %b" insert#starts_word);
         prerr_endline (Printf.sprintf "insert iter inside word: %b" insert#inside_word);
         prerr_endline (Printf.sprintf "insert#forward_word_end is_end: %b" insert#forward_word_end#is_end);
         prerr_endline (Printf.sprintf "insert#backward_word_start is_start: %b" insert#backward_word_start#is_start);
      *)
      (* let's say we swap a right and left words *)
      try
        let right_word_start =
          if insert#starts_word then
            insert
          else
            (* a forward_word_start function would have been great, thanks Gtk! *)
            let it =
              let itend =
                if insert#inside_word then insert#forward_word_end else insert
              in
              let itend2 = itend#forward_word_end in
              if itend2#equal itend || not itend2#ends_word then
                raise Not_found
              else
                itend2#backward_word_start
            in
            if it#is_end || not it#starts_word then
              raise Not_found
            else
              it
        in
        let right_word_end = right_word_start#forward_word_end in
        let left_word_start =
          let it = right_word_start#backward_word_start in
          if it#equal right_word_start || not it#starts_word then
            raise Not_found
          else
            it
        in
        let left_word_end = left_word_start#forward_word_end in

        let rw_start_offset = right_word_start#offset in
        let rw_end_offset = right_word_end#offset in
        let rw_size = rw_end_offset - rw_start_offset in
        let lw_start_offset = left_word_start#offset in
        let lw_end_offset = left_word_end#offset in
        let lw_size = lw_end_offset - lw_start_offset in

        let rw = b#get_text ~start: right_word_start ~stop: right_word_end () in
        let lw = b#get_text ~start: left_word_start ~stop: left_word_end () in

        b#begin_user_action ();

        b#delete ~start: right_word_start ~stop: right_word_end;

        let left_word_start = b#get_iter (`OFFSET lw_start_offset) in
        let left_word_end = b#get_iter (`OFFSET lw_end_offset) in
        b#delete ~start: left_word_start ~stop: left_word_end;
        let iter = b#get_iter (`OFFSET lw_start_offset) in
        b#insert ~iter rw;
        let iter = b#get_iter (`OFFSET (rw_start_offset - lw_size + rw_size)) in
        let ins_offset = iter#offset in
        b#insert ~iter lw;
        self#place_cursor (b#get_iter (`OFFSET (ins_offset + lw_size)));
        b#end_user_action ()
      with
        Not_found ->
          (* we don't have two words to transpose *)
          ()
*)
    method goto_line n =
      let line = max 0 (min n (B.line_count file#buffer#buffer - 1)) in
      ignore(source_view#move_cursor ~line ())

    method goto_char n =
      let offset = max 0 (min n (B.size file#buffer#buffer -1)) in
      ignore(source_view#move_cursor ~offset ())

    method reload =
      let g () =
        let f () = file#load_file file#filename; Lwt.return_unit in
        if self#buffer_modified then
          Misc.confirm self#minibuffer
            "Buffer was modified; revert anyway ?" f
        else
          f ()
      in
      Some g

    method set_syntax_mode lang =
      file#set_syntax_mode lang;
      self#display_stx_mode

    method set_mode mode =
      file#set_mode mode;
      self#display_mode

    method set_encoding e =
      file#set_encoding e;
      self#display_encoding

    method switch_line_numbers ?v () =
      let v = match v with
          None -> not source_view#show_line_numbers
        | Some v -> v
      in
      source_view#set_show_line_numbers v

    method switch_line_markers ?v () =
      let v = match v with
          None -> not source_view#show_line_markers
        | Some v -> v
      in
      source_view#set_show_line_markers v

    method switch_highlight_current_line ?v () =
      let v = match v with
          None -> not source_view#highlight_current_line
        | Some v -> v
      in
      source_view#set_highlight_current_line v

    method set_wrap_mode m =
      source_view#set_wrap_mode m

    method add_clipboard_to_pastable_history =
      if Tsdl.Sdl.has_clipboard_text () then
        let> text = Tsdl.Sdl.get_clipboard_text () in
        match text with
        | "" -> ()
        | _ -> pastable_history#add text
      else
        ()

    initializer
      self#my_set_label;
      self#display_state;
      self#display_location;
      source_view#scroll_to_cursor ();
      (*Gtksv_utils.register_source_view source_view;
      Gtksv_utils.apply_sourceview_props source_view (Gtksv_utils.read_sourceview_props ()) ;*)
      self#connect_buffer_events;
      ref_on_destroy := (fun () -> f_on_destroy self);
      ignore(vbox#connect (Stk.(Object.Prop_changed Props.is_focus))
         (fun ~prev ~now -> if now then on_focus_in ()));

      (* FIXME: not available in sourceview3 ?
        try
        let pix_bookmark = GdkPixbuf.from_file
          (Filename.concat Installation.pixmap_dir "bookmark.png")
        in
        source_view#set_mark_category_pixbuf "bookmark" (Some pix_bookmark)
      with
        e -> prerr_endline (Printexc.to_string e)
      *)
  end


(** {2 Handling open views and buffers} *)

let views = ref ([] : sourceview list)
let buffers = ref ([] : buffered_file list)
let active_sourceview = ref (None : sourceview option)

let set_active_sourceview o =
  if List.exists (fun v -> Oo.id v = Oo.id o) !views then
    active_sourceview := Some o;
  make_buffer_first_in_history o#buffer_name

let get_fresh_buffer_name name =
  let name_of_n n =
    if n <= 1
    then name
    else Printf.sprintf "%s<%d>" name n
  in
  let rec iter n =
    let name = name_of_n n in
    if List.exists (fun b -> b#name = name) !buffers then
      iter (n+1)
    else
      name
  in
  iter 1

let create_buffer ?(attributes=[]) ?xmls filename =
  let mes = Printf.sprintf "creating buffer for %s" filename in
  Misc.display_message mes;
  let b = B.create () in
  let buffer = new my_buffer b in
  B.set_max_undo_levels b (Ocf.get Sourceview_rc.max_undo_levels);
  (*b#set_highlight_matching_brackets true;*)
  (*Gtksv_utils.register_source_buffer (b :> GSourceView3.source_buffer);*)
  let name = get_fresh_buffer_name (Filename.basename filename) in
  let file = new buffered_file ~attributes ?xmls ~name ~filename buffer in
  buffers := file :: !buffers;
  make_buffer_first_in_history file#name;
  file

let get_buffer ?(attributes=[]) ?xmls filename =
  try
(*    if not (Sys.file_exists filename) then raise Not_found;*)
    let b = List.find
      (fun f -> Misc.safe_same_files f#filename filename)
        !buffers
    in
    let loc =
      match get_att "location" attributes with
        None -> None
      | Some s -> location_of_string s
    in
    (
     match loc with
     | None -> ()
     | Some loc ->
       (* create and move a cursor so that the first view to
          use this buffer will have the insert cursor at this position *)
          let b = b#buffer#buffer in
          let (line,char) = line_char_of_location b (Some loc) in
          let c = B.create_cursor ~line ~char b in
          B.set_last_used_cursor b c
    );
    b
  with Not_found -> create_buffer ~attributes ?xmls filename

let get_buffer_by_name name =
  List.find (fun b -> b#name = name) !buffers

let remove_buffer (b : buffered_file) =
  buffers := List.filter (fun b2 -> b#filename <> b2#filename) !buffers;
  remove_buffer_from_history b#name;
  (*Gtksv_utils.unregister_source_buffer (b#buffer :> GSourceView3.source_buffer)*)
;;

let on_view_destroy v =
  views := List.filter (fun v2 -> Oo.id v <> Oo.id v2) !views;
  match !active_sourceview with
    Some v2 when Oo.id v = Oo.id v2 ->
      active_sourceview := None
  | Some _
  | None -> ()

let rec create_view ?(attributes=[]) ?xmls topwin file =
  let v = new sourceview ~attributes ?xmls topwin on_view_destroy
    set_active_sourceview dup file_rename file
  in
  ignore(v#source_view#connect Stk.Widget.Destroy (fun () -> on_view_destroy v; false));
  views := v :: !views;
  v

and dup file topwin =
  (create_view topwin file :> View.gui_view)

and file_rename oldname newname =
  try
    ignore(List.find (fun b -> Misc.safe_same_files b#filename newname) !buffers);
    let mes = Printf.sprintf "%s is already open. Close it before." newname in
    failwith mes
  with Not_found ->
      (* search on names here, not dev/inode *)
      let views = List.filter (fun v -> v#filename = oldname) !views in
      let b = get_buffer oldname in
      let old_buffer_name = b#name in
      b#set_filename newname;
      b#set_name (get_fresh_buffer_name (Filename.basename newname));
      rename_buffer_in_history old_buffer_name b#name;
      List.iter (fun v -> v#my_set_label; v#display_state) views

let open_file topwin active_view ?(attributes=[]) ?xmls filename =
  let file = get_buffer ~attributes filename in
  match !active_sourceview with
    None -> `New_view (create_view ~attributes ?xmls topwin file :> View.gui_view)
  | Some v ->
      if topwin#contains_view (v :> View.gui_view) then
        begin
          if v#file#name = file#name then
            match get_att "location" attributes with
              None -> ()
            | Some s -> v#select_location_opt (location_of_string s)
          else
            v#set_file ~focus_in: true file;
          `Use_view (v :> View.gui_view)
        end
      else
        `New_view (create_view ~attributes topwin file :> View.gui_view)
;;

(** {2 Factory} *)

class factory : View.view_factory =
  object
    method name = factory_name
    method open_file = open_file
    method open_hidden =
      Some (fun ?attributes ?xmls filename ->
             ignore (get_buffer ?attributes filename))
    method on_start =
      let f () =
        let buffers = read_open_buffers_file !open_buffers_file in
        List.iter
          (fun (f, attributes) ->
            if Sys.file_exists f then
              ignore(get_buffer ~attributes f)
          )
          buffers
      in
      Misc.catch_print_exceptions f ()
    method on_exit =
      Misc.catch_print_exceptions
        (write_open_buffers_file !open_buffers_file) !buffers;
      Misc.catch_print_exceptions
        (Bookmarks.store bookmarks) Sourceview_rc.bookmarks_rc_file
  end


let _ = View.register_view_factory factory_name (new factory)
;;

(** {2 "Forward-stack" of locations.} *)

let location_stack = Fstack.create ();;


(** {2 Commands} *)

let keep_key_bindings_from_view v l =
  let rec iter acc = function
    [] -> acc
  | (k,com) :: q ->
      if List.mem com l then
        iter ((k, fun () -> Commands.async_command com) :: acc) q
      else
        iter acc q
  in
  iter [] v#key_bindings

let register_com_lwt ~prefix name args ?more f =
  let name = Printf.sprintf "%s_%s" prefix name in
  let f args =
    match !active_sourceview with
      None -> Lwt.return_unit
    | Some v -> f v args
  in
  let c = { Commands.com_name = name ;
      com_args = args ;
      com_more_args = more ;
      com_f = f ;
    }
  in
  Commands.register c

let register_com ~prefix name args ?more f =
  let f sv args = f sv args; Lwt.return_unit in
  register_com_lwt ~prefix name args ?more f

let switch_to_buffer (v : sourceview) name =
  try
    let b = get_buffer_by_name name in
    v#set_file ~focus_in: true b
  with Not_found ->
      Misc.error_message
        (Printf.sprintf "No %s buffer %s"
         factory_name (utf8_of_filename name))

let candidate_buffers () =
  let displayed_buffers = List.map (fun o -> o#buffer_name) !views in
  let (last,first) = List.partition
    (fun name -> List.mem name displayed_buffers)
      !buffer_name_history
  in
  first @ last

let switch_buffer_history = Minibuffer.history ()
let switch_buffer v args =
  if Array.length args > 0 then
    (
    let name = args.(0) in
    switch_to_buffer v name;
    Lwt.return_unit
    )
  else
    (* propose list of available buffers *)
    let candidate_buffers = candidate_buffers () in
    let com = Printf.sprintf "%s_switch_buffer" factory_name in
    let f = function
      "" ->
        (
         match candidate_buffers with
         | [] -> Lwt.return_unit
         | s :: _ ->
             Commands.launch_command
               ~history:false com [| s |]
        )
    | s ->
        Commands.launch_command
          ~history:false com [| s |]
    in
    let title =
      Printf.sprintf "Switch to %s"
        (match candidate_buffers with
           [] -> "" | s :: _ -> "["^((*FIXME Glib.Convert.filename_to_utf8*) s)^"]")
    in
    Misc.select_string
      ~history: switch_buffer_history
      v#minibuffer
      ~title
      ~choices: ((*FIXME List.map Glib.Convert.filename_to_utf8*) candidate_buffers)
      ""
      f

let destroy_buffer (v : sourceview) args =
  let f () =
    let bname = v#buffer_name in
    remove_buffer v#file;
    let () =
      match List.filter (fun name -> name <> bname) (candidate_buffers()) with
      | [] ->
        (* no more buffer to replace the destroyed one, destroy all views *)
        List.iter (fun v -> v#destroy) !views
      | first :: _ ->
        let buf =
          try get_buffer_by_name first
          with Not_found -> failwith "Internal error; Please restart to be safe."
        in
        List.iter
          (fun (v:sourceview) ->
             if v#buffer_name = bname then v#set_file ~focus_in: true buf
          )
          !views
     in
     Lwt.return_unit
  in
  if not v#buffer_modified then
    f ()
  else
    Misc.confirm v#minibuffer
      (Printf.sprintf "Buffer %s modified; destroy anyway ?"
       (utf8_of_filename v#buffer_name))
      f

(* Replace search and replace with GtkSourceSearchContext stuff when bound *)
type search_buffer_function =
  ?wrapped:bool ->
    bool ->
      my_buffer ->
        start:int-> string -> bool * Stk.Rope.range option

let prev_search = ref None

let rec re_search_buffer ?(quote=false) ?(wrapped=false) forward (buffer: my_buffer) ~start s_utf8 =
  let b = buffer#buffer in
  let (start, stop) =
    if forward then
      (start, B.size b)
    else
      (0, start)
  in
  let gsearch = buffer#re_search forward in
  let re = Pcre.regexp (if quote then Pcre.quote s_utf8 else s_utf8) in
  Log.warn (fun m -> m "gsearch start=%d stop=%d" start stop);
  match gsearch ~start ~stop re with
    None ->
      if wrapped then
        (wrapped, None)
      else
        let start = if forward then 0 else B.size b in
        re_search_buffer ~wrapped: true forward buffer ~start s_utf8
  | Some range ->
      Log.warn (fun m -> m "found range %a" Stk.Rope.pp_range range);
      (wrapped, Some range)

let search_buffer = re_search_buffer ~quote:true
let re_search_buffer = re_search_buffer ~quote:false

(*let rec search_buffer ?(wrapped=false) forward (buffer : my_buffer)
  ?(start=buffer#get_iter `INSERT) s_utf8 =
  let gsearch =
    if forward then
      GSourceView3.iter_forward_search
    else
      GSourceView3.iter_backward_search
  in
  let stop = buffer#end_iter in
  match gsearch start [] ~start ~stop s_utf8 with
    None ->
      if wrapped then
        (wrapped, None)
      else
        let start = if forward then buffer#start_iter else buffer#end_iter in
        search_buffer ~wrapped: true forward buffer ~start s_utf8
  | Some (start,stop) ->
      (wrapped, Some (start, stop))
*)

let rec search =
  let forward = ref true in
  fun (fsearch_buffer : search_buffer_function)
    mes ?(changed=false) _forward (v: sourceview) args ->
      forward := _forward;
    let fixed wrapped = Printf.sprintf "%s%s%s: "
      (if wrapped then "[wrapped] " else "")
        mes
        (if !forward then "" else " backward")
    in
    let mb = v#minibuffer in
    if mb#active then
      (
       let s_utf8 = mb#get_user_text in
       match s_utf8 with
         "" ->
           begin
             match !prev_search with
               None -> ()
             | Some s -> mb#set_user_text s
           end
       | _ ->
           (*           prerr_endline ("search "^(Misc.of_utf8 s_utf8));*)
           let start =
             match v#source_view#selection_range with
             | Some { Stk.Rope.start ; size } ->
                 if !forward then
                   if changed then start else start + 1
                 else
                   if changed then start + size else start + size - 1
             | None ->
                 v#source_view#cursor_offset v#source_view#insert_cursor
           in
           match fsearch_buffer !forward v#file#buffer ~start s_utf8 with
             (wrapped, None) ->
               mb#set_text ~fixed: (fixed wrapped) s_utf8
           | (wrapped, Some {start ; size}) ->
               (*
                  prerr_endline (Printf.sprintf "found start=%d,%d" start#line start#line_offset);
                  prerr_endline (Printf.sprintf "and stop=%d,%d" stop#line stop#line_offset);
               *)
               v#source_view#select_range ~start ~size;
               mb#set_text ~fixed: (fixed wrapped) s_utf8
      )
    else
      (
       let on_changed () =
         (* do not do anything if there is nothing to search
           or the searched string has not changed, to prevent
            from moving to next search when changing the fixed text
            of the minibuffer *)
         match mb#get_user_text with
           "" -> ()
         | s ->
             if !prev_search = Some s then
               ()
             else
               (
                prev_search := Some s;
                search fsearch_buffer mes ~changed: true !forward  v args
               )
       in
       mb#clear;
       mb#set_text ~fixed: (fixed false) "";
       mb#set_on_text_changed on_changed;

       mb#set_more_key_bindings
         (keep_key_bindings_from_view v
          [ factory_name^"_search" ;
            factory_name^"_search_backward" ;
            factory_name^"_search_re" ;
            factory_name^"_search_re_backward" ;
          ]
         );
       mb#set_active true
      )

let replace_history = Minibuffer.history ()

let query_replace_gen
  ?(mes="")
  command_name
  (fsearch_buffer : search_buffer_function)
  (freplace : searched: string -> found:string -> repl:string -> string)
  (v : sourceview) args =
  let mb = v#minibuffer in
  let len = Array.length args in
  if len <= 0 then
    let f s = Commands.launch_command command_name [| s |] in
    let title = Printf.sprintf "Query-replace%s" mes in
    Misc.input_string ~history: replace_history
      mb ~title "" f
  else
    if len = 1 then
      begin
        let title = Misc.to_utf8
          (Printf.sprintf "Query-replace%s %s with" mes args.(0))
        in
        let f s = Commands.launch_command command_name [| args.(0); s |] in
        Misc.input_string ~history: replace_history
          mb ~title "" f
      end
    else
      begin
        let title = Misc.to_utf8
          (Printf.sprintf "Query-replace%s %s with %s (y/n/!)"
           mes args.(0) args.(1))
        in
        let s1_utf8 = Misc.to_utf8 args.(0) in
        let s2_utf8 = Misc.to_utf8 args.(1) in
        let rec iter interactive =
          let b = v#file#buffer in
          let start = v#source_view#cursor_offset v#source_view#insert_cursor in
          match fsearch_buffer true (*=forward*) b ~start s1_utf8 with
            true, _
          | _, None -> mb#set_active false; Lwt.return_unit
          | false, Some { start ; size } ->
              if interactive then v#source_view#select_range ~start ~size;
              let replace () =
                (*v#place_cursor ~scroll: interactive start;*)
                let found = v#source_view#delete ~honor_readonly:true ~start ~size () in
                (*              prerr_endline
                   (Printf.sprintf "searched=%s, found=%s, repl=%s"
                   s1_utf8 found s2_utf8);
                *)
                let new_text = freplace
                  ~searched: s1_utf8 ~found ~repl: s2_utf8
                in
                v#source_view#insert_at ~honor_readonly:true start new_text;
                v#source_view#move_cursor ~offset:(start+Stk.Utf8.length new_text) ();
              in
              if interactive then
                (
                 let f_yes () = replace (); Lwt.async (fun () -> iter true) in
                 let f_no () =
                   v#source_view#move_cursor ~offset:(start+1) ();
                   Lwt.async (fun () -> iter true)
                 in
                 let f_bang () = replace (); Lwt.async (fun () -> iter false) in
                 mb#clear;
                 mb#set_more_key_bindings
                   [ [Stk.Key.keystate Tsdl.Sdl.K.y], f_yes ;
                     [Stk.Key.keystate Tsdl.Sdl.K.n], f_no ;
                     [Stk.Key.keystate Tsdl.Sdl.K.exclaim], f_bang ;
                   ];
                 mb#set_text ~fixed: title "";
                 if not mb#active then
                   (mb#set_active true; mb#wait)
                 else
                   Lwt.return_unit
                )
              else
                (replace (); iter interactive)
        in
        let%lwt () = iter true in
        Lwt.return_unit
      end

let query_replace = query_replace_gen
  (Printf.sprintf "%s_query_replace" factory_name)
  search_buffer
  (fun ~searched ~found ~repl -> repl)

let re_replace ~searched ~found ~repl =
  let rex = Pcre.regexp searched in
  Pcre.replace_first ~rex ~templ: repl found

let re_query_replace = query_replace_gen
  ~mes: " regexp"
  (Printf.sprintf "%s_query_replace_re" factory_name)
  re_search_buffer
  re_replace


let copy (v:sourceview) args =
  v#source_view#copy ;
  v#add_clipboard_to_pastable_history
let cut (v:sourceview) args =
  match v#source_view#cut ~honor_readonly:true () with
  | Some _ -> v#add_clipboard_to_pastable_history
  | None -> ()
let paste (v:sourceview) args =
  v#source_view#paste ~honor_readonly:true ();
  v#add_clipboard_to_pastable_history


let beginning_of_line (v : sourceview) args = v#beginning_of_line
let end_of_line (v : sourceview) args = v#end_of_line
let undo (v : sourceview) args = v#undo
let redo (v : sourceview) args = v#redo
let forward_word v args = v#forward_word
let backward_word v args = v#backward_word
let forward_line v args = v#forward_line
let backward_line v args = v#backward_line
let forward_char v args = v#forward_char
let backward_char v args = v#backward_char
let kill_line v args =
  v#kill_line ~append: (Commands.same_previous_command ())

let kill_word v args =
  let concat =
    if Commands.same_previous_command () then
      Some `APPEND
    else
      None
  in
  v#kill_word ?concat true

let backward_kill_word v args =
  let concat =
    if Commands.same_previous_command () then
      Some `PREPEND
    else
      None
  in
  v#kill_word ?concat false

let delete_char v args = v#delete_char true
let backward_delete_char v args = v#delete_char false

let transpose_chars v args = v#transpose_chars
let transpose_lines v args = v#transpose_lines
let transpose_words v args = v#transpose_words

let yank_choose v args =
  let mb = v#minibuffer in
  let title = "Choose text to paste (Up/Down to choose):" in
  let on_eval () =
    let s_utf8 = mb#get_user_text in
    paste v [| s_utf8 |];
    mb#set_active false;
    Lwt.return_unit
  in
  mb#clear ;
  mb#set_on_eval on_eval;
  mb#set_text ~fixed: title "";
  mb#set_history pastable_history;
  mb#set_active true

let insert (v:sourceview) args =
  Array.iter v#insert args

let goto_history = Minibuffer.history ()
let goto_line v args =
  let f s =
    let n =
      try Misc.my_int_of_string args.(0)
      with _ -> invalid_arg "Bad line number"
    in
    v#goto_line (n-1);
    Lwt.return_unit
  in
  Misc.input_command_arg
    v#minibuffer ~history: goto_history
    ~title: "Go to line"
    f (Printf.sprintf "%s_goto_line" factory_name) args

let goto_char v args =
  let f s =
    let n =
      try Misc.my_int_of_string args.(0)
      with _ -> invalid_arg "Bad character number"
    in
    v#goto_char (n-1);
    Lwt.return_unit
  in
  Misc.input_command_arg
    v#minibuffer ~history: goto_history
    ~title: "Go to char"
    f (Printf.sprintf "%s_goto_char" factory_name) args

let force_save v args = v#do_save

let syntax_mode_history = Minibuffer.history ()
let set_syntax_mode v args =
  let len = Array.length args in
  if len > 0 then
    let name = args.(0) in
    try
      (*let langs = Gtksv_utils.available_source_languages ~manager: language_manager () in
      let lang = List.find (fun l -> l#name = name)  langs in*)
      v#set_syntax_mode (Some name(*lang*));
      Lwt.return_unit
    with
      Not_found ->
        Misc.error_message
          (Printf.sprintf "Unknown syntax mode \"%s\"" name);
        Lwt.return_unit
  else
    let f mode =
      let com = Printf.sprintf "%s_set_syntax_mode %s"
        factory_name (Filename.quote mode)
      in
      Commands.eval_command com
    in
    let languages = List.map fst (Higlo.Lang.registered_langs ()) in
    Misc.select_string ~history: syntax_mode_history
      v#minibuffer
      ~title: "Syntax mode"
      ~choices: languages
      ""
      f

let popup_syntax_mode_choice v args =
  let com s =
    Commands.async_command
      (Printf.sprintf "%s_set_syntax_mode %s"
       factory_name (Filename.quote s))
  in
  let entries = List.map
    (fun (name,_) ->
       `I (name, (fun () -> com name))
    )
    (Higlo.Lang.registered_langs())
  in
  Stk.Menu.popup_menu_entries entries

let mode_history = Minibuffer.history ()
let set_mode v args =
  let len = Array.length args in
  if len > 0 then
    let name = args.(0) in
    try
      match Misc.no_blanks name with
        "" -> v#set_mode None; Lwt.return_unit
      | _ -> v#set_mode (Some (get_mode name)); Lwt.return_unit
    with
      Failure s->
        Misc.error_message s;
        Lwt.return_unit
  else
    let f mode =
      let com = Printf.sprintf "%s_set_mode %s"
        factory_name (Filename.quote mode)
      in
      Commands.eval_command com
    in
    Misc.select_string ~history: mode_history
      v#minibuffer
      ~title: "Mode"
      ~choices: (available_mode_names ())
      ""
      f

let popup_mode_choice v args =
  let com s =
    Commands.async_command
      (Printf.sprintf "%s_set_mode %s"
       factory_name (Filename.quote s))
  in
  let entries =
    (`I ("None", fun () -> com "''")) ::
      (List.map
       (fun s -> `I (s, (fun () -> com s)))
         (available_mode_names ()))
  in
  Stk.Menu.popup_menu_entries entries

let switch_line_numbers (view : sourceview) args =
  let v =
    if Array.length args > 0 then
      Some (Misc.bool_of_string args.(0))
    else
      None
  in
  view#switch_line_numbers ?v ()

let switch_line_markers (view : sourceview) args =
  let v =
    if Array.length args > 0 then
      Some (Misc.bool_of_string args.(0))
    else
      None
  in
  view#switch_line_markers ?v ()

let switch_highlight_current_line (view : sourceview) args =
  let v =
    if Array.length args > 0 then
      Some (Misc.bool_of_string args.(0))
    else
      None
  in
  view#switch_highlight_current_line ?v ()

let set_wrap_mode (view : sourceview) args =
  let com = Printf.sprintf "%s_set_wrap_mode" factory_name in
  if Array.length args < 1 then
    let f s = Commands.launch_command com [| s |] in
    Misc.select_string view#minibuffer ~title: com
      ~choices: (Stk.Textview.(List.map string_of_wrap_mode [Wrap_none ; Wrap_char]))
      "" f
  else
    (
     let mode = Stk.Textview.wrap_mode_of_string args.(0) in
     view#set_wrap_mode mode;
     Lwt.return_unit
    )


let insert_utf8 (view : sourceview) args =
  if Array.length args < 1 then
    ()
  else
    try
      let code = int_of_string args.(0) in
      let s = Stk.Utf8.string_of_uchar (Uchar.of_int code) in
      view#source_view#insert ~honor_readonly:true s
    with
      Invalid_argument _ ->
        let mes = Printf.sprintf "insert_utf8: invalid argument (%s)" args.(0) in
        Misc.error_message mes
;;

let set_encoding (view : sourceview) args =
  if Array.length args < 1 then
    let com = Printf.sprintf "%s_set_encoding" factory_name in
    let f s = Commands.launch_command com [| s |] in
    Misc.select_string view#minibuffer ~title: com
      ~choices: Iconv.encoding_names
      "" f
  else
    (
     view#set_encoding (Some args.(0));
     Lwt.return_unit
    )
;;

let set_bookmark (view : sourceview) args =
  let com = Printf.sprintf "%s_set_bookmark" factory_name in
  if Array.length args < 1 then
    (
     let f s = Commands.launch_command com [| s |] in
     Misc.input_string view#minibuffer ~title: com
       "" f
    )
  else
    (
     let data =
       let (l,c) = view#location_in_buffer in
       (view#filename, l, c)
     in
     Bookmarks.set bookmarks args.(0) data;
     (*FIXME view#file#update_source_marks;*)
     view#update_menus;
     Lwt.return_unit
    )
;;

let remove_bookmark (view : sourceview) args =
  let com = Printf.sprintf "%s_remove_bookmark" factory_name in
  if Array.length args < 1 then
    (
     let choices = List.map fst (Bookmarks.list bookmarks) in
     let f s = Commands.launch_command com [| s |] in
     Misc.select_string view#minibuffer ~title: com
       ~choices
       "" f
    )
  else
    (
     Bookmarks.remove bookmarks args.(0);
     view#update_menus;
     Lwt.return_unit
    )
;;

let push_location (view : sourceview) args =
  let loc = (view#filename, view#location_in_buffer) in
  Fstack.push loc location_stack;
  Misc.set_active_action_message "Location pushed"
;;

let pop_location (view : sourceview) args =
  try
    let (file, (line,char)) = Fstack.pop location_stack in
    Commands.eval_command (Printf.sprintf "pop_location %s" (Filename.quote file));
    if view#filename = file then
      ignore(view#source_view#move_cursor ~line ~char ())
  with
    Fstack.Empty ->
      let m = "Location stack is empty" in
      Log.err (fun p -> p "%s" m);
      Misc.set_active_action_message m

;;

let forward_location (view : sourceview) args =
  try
    let (file, (line,char)) = Fstack.forward location_stack in
    Commands.eval_command (Printf.sprintf "open_file %s" (Filename.quote file));
    if view#filename = file then
      ignore(view#source_view#move_cursor ~line ~char ())
  with
    Fstack.Empty ->
      let m = "Location stack is forward-empty" in
      Log.err (fun p -> p "%s" m);
      Misc.set_active_action_message m
;;

[@@@ocaml.warning "-5"]

let coms =
  [
    "search", [| |], None, search search_buffer "search" true ;
    "search_backward", [| |], None, search search_buffer "search" false ;
    "search_re", [| |], None, search re_search_buffer "regexp search" true ;
    "search_re_backward", [| |], None, search re_search_buffer "regexp search" false ;
    "beginning_of_line", [| |], None, beginning_of_line ;
    "end_of_line", [| |], None, end_of_line ;
    "undo", [| |], None, undo ;
    "redo", [| |], None, redo ;
    "forward_word", [| |], None, forward_word ;
    "backward_word", [| |], None, backward_word ;
    "forward_line", [| |], None, forward_line ;
    "backward_line", [| |], None, backward_line ;
    "forward_char", [| |], None, forward_char ;
    "backward_char", [| |], None, backward_char ;
    "paste", [| |], None, paste ;
    "copy", [| |], None, copy ;
    "cut", [| |], None, cut ;
    "kill_line", [| |], None, kill_line ;
    "kill_word", [| |], None, kill_word ;
    "backward_kill_word", [| |], None, backward_kill_word ;
    "yank_choose", [| |], None, yank_choose ;
    "insert", [| |], Some "utf8 strings to insert", insert ;
    "delete_char", [| |], None, delete_char ;
    "backward_delete_char", [| |], None, backward_delete_char ;
    "transpose_chars", [| |], None, transpose_chars ;
    "transpose_lines", [| |], None, transpose_lines ;
    "transpose_words", [| |], None, transpose_words ;
    "popup_syntax_mode_choice", [| |], None, popup_syntax_mode_choice ;
    "popup_mode_choice", [| |], None, popup_mode_choice ;
    "switch_line_numbers", [| "optional value" |], None, switch_line_numbers ;
    "switch_line_markers", [| "optional value" |], None, switch_line_markers ;
    "insert_utf8", [| "utf8 code" |], None, insert_utf8 ;
    "push_location", [| |], None, push_location ;
    "pop_location", [| |], None, pop_location ;
    "forward_location", [| |], None, forward_location ;
  ]

let coms_lwt =
  [
    "switch_buffer", [| |], None, switch_buffer ;
    "destroy_buffer", [| |], None, destroy_buffer ;
    "query_replace", [| |], None, query_replace ;
    "query_replace_re", [| |], None, re_query_replace ;
    "goto_line", [|"line"|], None, goto_line ;
    "goto_char", [|"character"|], None, goto_char ;
    "force_save", [| |], None, force_save ;
    "set_syntax_mode", [| "Syntax mode" |], None, set_syntax_mode ;
    "set_mode", [| "Mode" |], None, set_mode ;
    "set_wrap_mode", [| "mode" |], None, set_wrap_mode ;
    "set_encoding", [| "encoding" |], None, set_encoding ;
    "set_bookmark", [| "name" |], None, set_bookmark ;
    "remove_bookmark", [| "name" |], None, remove_bookmark ;
  ]

let _ = List.iter
  (fun (name, args, more, f) ->
     let f sv args = f sv args; Lwt.return_unit in
     register_com ~prefix: factory_name name args ?more f)
    coms

let _ = List.iter
  (fun (name, args, more, f) ->
     register_com_lwt ~prefix: factory_name name args ?more f)
    coms_lwt