(*********************************************************************************)
(*                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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** OCaml sourceview mode. *)

let _ = Mode_ocaml_rc.read ()
let _ = Mode_ocaml_rc.write ()
let _ = Mode_ocaml_rc.local_read ()
let _ = Mode_ocaml_rc.local_write ()

let mode_name = Mode_ocaml_rc.mode_name

let remove_first_blanks s =
  let len = String.length s in
  try
    let rec first_no_blank p =
      if p < len then
        match s.[p] with
          ' ' | '\t' -> first_no_blank (p+1)
        | _ -> p
      else
        raise Not_found
    in
    let p = first_no_blank 0 in
    String.sub s p (len - p)
  with
    Not_found -> ""

module B = Stk.Textbuffer

let indent_line (v : Sourceview.sourceview) args =
  let b = v#file#buffer#buffer in
  match B.dup_cursor b v#source_view#insert_cursor with
  | None -> ()
  | Some c ->
      let (line, bol, pos_on_line) =
        let lo = B.cursor_line_offset b c in
        (lo.B.line, lo.B.bol, lo.B.offset)
      in
      match B.move_cursor_to_line_end b c with
      | None -> B.remove_cursor b c
      | Some eol ->
          let code =
              v#file#of_utf8
              (v#file#mode_from_display
               (B.to_string ~size:eol b))
          in
          let indentations =
            match Ocaml_lexer.get_lines_indentation code with
            | `Failure (e,(start,stop),l) ->
                let err = Printf.sprintf "chars %d-%d: %s"
                  start stop (Ocaml_lexer.report_error e) in
                Misc.set_active_action_message (Misc.to_utf8 err);
                l
            | `Success l ->
                l
          in
          if List.length indentations <= line then
            ()
          else
            match List.rev indentations with
              [] -> ()
            | None :: _ -> ()
            | (Some n) :: _ ->
                let codeline = v#file#of_utf8
                  (v#file#mode_from_display
                   (B.to_string ~start:bol ~size:(eol-bol) b))
                in
                let len = String.length codeline in
                  let new_codeline = remove_first_blanks codeline in
                let new_codeline = Printf.sprintf "%s%s"
                  (String.make n ' ')
                    new_codeline
                in
                B.remove_cursor b c;
                if new_codeline <> codeline then
                  begin
                    let len2 = String.length new_codeline in
                    let user_pos =
                      let diff = len - len2 in
                      let p = max 0 (pos_on_line - diff) in
                      if p < n then n else p
                    in
                    B.begin_action b ;
                    B.delete ~start:bol ~size:(eol-bol) b;
                    B.insert b bol
                      (v#file#mode_to_display (v#file#to_utf8 new_codeline));
                    B.end_action b ;
                    ignore(v#source_view#move_cursor ~offset:(bol+user_pos)
                     ~c:v#source_view#insert_cursor ())
                  end
                else
                  ()

let indent_buffer (v : Sourceview.sourceview) args =
  let current_line = v#current_line in
  let b = v#file#buffer#buffer in
  let sv = v#source_view in
  let code = v#file#of_utf8
    (v#file#mode_from_display (B.to_string b))
  in
  match Ocaml_lexer.get_lines_indentation code with
  | `Failure (e,(start,stop),_) ->
      let err = Printf.sprintf "chars %d-%d: %s"
        start stop (Ocaml_lexer.report_error e) in
      Misc.set_active_action_message (Misc.to_utf8 err)
  | `Success indentations ->
      let lines = Misc.split_string ~keep_empty: true code ['\n'] in
      let nb_lines = List.length lines in
      let nb_indentations = List.length indentations in
      let indentations =
        if nb_indentations < nb_lines then
          indentations @
            (Misc.make_list (nb_lines - nb_indentations) None)
        else
          indentations
      in
      B.begin_action b ;
      B.delete b ;
      let c = sv#insert_cursor in
      sv#move_cursor ~offset:0 ~c ();
      List.iter2
        (fun line nopt ->
           let line =
             match nopt with
               None -> line^"\n"
             | Some n ->
                 let s = remove_first_blanks line in
                 Printf.sprintf "%s%s\n" (String.make n ' ') s
           in
           sv#insert ~c (v#file#mode_to_display (v#file#to_utf8 line))
        )
        lines
        indentations;
      sv#move_cursor ~line:current_line ~c ();
      B.end_action b;
      let message =
        Printf.sprintf "%d lines indented / %d lines in buffer"
          nb_indentations nb_lines
      in
      Misc.set_active_action_message (Misc.to_utf8 message)
  
let switch_file (v:Sourceview.sourceview) args =
  let f = v#file#filename in
  try
    let filename2 =
      let ext =
        if Filename.check_suffix f ".ml" then
          "mli"
        else if Filename.check_suffix f ".mli" then
            "ml"
          else
            raise Not_found
      in
      Printf.sprintf "%s.%s" (Filename.chop_extension f) ext
    in
    let com = Printf.sprintf "open_file %s" (Filename.quote filename2) in
    Commands.eval_command com
  with
    Not_found -> Lwt.return_unit

let remove_pp file =
  let ext = Filename.extension file in
  let s = Filename.remove_extension file in
  let s = match Filename.chop_suffix_opt ~suffix:".pp" s with
    | None -> s
    | Some s -> s
  in
  s^ext

let find_cmt_from_all_cmt_files root file =
  let rec eq s1 s2 =
    let b1 = Filename.basename s1 in
    let b2 = Filename.basename s2 in
    b1 = b2 &&
    (let d1 = Filename.dirname s1 in
     let d2 = Filename.dirname s2 in
     d1 = "." || d2 = "." || eq d1 d2)
  in
  let pred cmtfile =
    Log.debug (fun m -> m "%s ?" cmtfile);
    match Binannot.load_cmt cmtfile with
    | Error _ -> false
    | Ok cmt ->
        match cmt.Cmt_format.cmt_sourcefile with
        | None -> false
        | Some source ->
          let source = remove_pp source in
          Log.debug (fun m -> m "eq %s %s ?" source file);
          eq source file
  in
  let regexp = Str.regexp ".*\\.cmt$" in
  match Find.(find_list Ignore [root]
     [Follow;  Predicate pred; Regexp regexp])
  with
  | [] -> None
  | cmtfiles ->
      let cmtfiles = List.map
        (fun f ->
           match Unix.stat f with
           | exception _ -> (f, 0.)
           | s -> (f, s.Unix.st_mtime)) cmtfiles
      in
      let comp (_,d1) (_,d2) = int_of_float (d2 -. d1) in
      match List.map fst (List.sort comp cmtfiles) with
      | [] -> assert false
      | h :: q -> Some h

let cmt_file_build_dir_max_parent_level = ref 3;;

let find_cmt_file file =
  let cmt_file =
    try
      if Filename.check_suffix file ".ml" then
        (Filename.chop_extension file)^".cmt"
      else
        raise Not_found
    with _ -> failwith "File has no .ml extension"
  in
  Log.info (fun m -> m "file_exists %s ?" cmt_file) ;
  if Sys.file_exists cmt_file then
    cmt_file
  else
    begin
      let cmt_file = Filename.basename cmt_file in
      let rec iter n up_path down_path =
        if n < !cmt_file_build_dir_max_parent_level then
          let build_dir = Filename.concat up_path "_build" in
          if Sys.file_exists build_dir then
            let dir = Filename.concat build_dir down_path in
            let f = Filename.concat dir cmt_file in
            let () = Log.info (fun m -> m "file_exists %s ?" f) in
            if Sys.file_exists f then
              f
            else
              let f =
                let def = Filename.concat build_dir "default" in
                Filename.(concat (concat def down_path) cmt_file)
              in
              let () = Log.info (fun m -> m "file_exists %s ?" f) in
              if Sys.file_exists f then
                f
              else
                match find_cmt_from_all_cmt_files build_dir file with
                | Some f -> f
                | None ->
                    iter (n+1) (Filename.dirname up_path)
                      (Filename.concat (Filename.basename up_path) down_path)
          else
            iter (n+1) (Filename.dirname up_path)
              (Filename.concat (Filename.basename up_path) down_path)
        else
          failwith (Printf.sprintf "No %s file found." cmt_file)
      in
      iter 0 (Filename.dirname file) ""
    end
;;

let was_preprocessed cmt =
  match cmt.Cmt_format.cmt_sourcefile with
  | None -> false
  | Some f -> (remove_pp f) <> f

let load_cmt ml_file =
  let cmt_file = find_cmt_file ml_file in
  match Binannot.load_cmt cmt_file with
  | Result.Error msg -> failwith msg
  | Result.Ok t ->
      if was_preprocessed t then
        (* if the source file was preprocessed, the digests will not match,
           because the cmt file will contain the digest of source after
           processing. In this case we do not check digests. *)
        (
         Log.warn
           (fun m -> m "File %s was preprocessed, not checking digests from .cmt file"
             ml_file);
         t
        )
      else
        match t.cmt_source_digest with
        | None -> t
        | Some cmt_digest ->
            match Digest.file ml_file with
            | exception  _ ->
                Log.warn (fun m -> m "Could not digest %s" ml_file);
                t
            | ml_digest ->
                Log.debug
                  (fun m -> m "source digest in cmt: %s\nml digest: %s"
                   (Digest.to_hex cmt_digest) (Digest.to_hex ml_digest));
                if Digest.equal cmt_digest ml_digest then
                  t
                else
                  failwith
                    (Printf.sprintf "Source was modified since %s was created" cmt_file)
;;

type action =
| Display_type of bool (* copy to clipboard or not *)
| Jump_to_local_def
| Display_ident

let string_of_type_expr t =
  let b = Buffer.create 256 in
  let fmt = Format.formatter_of_buffer b in
  Printtyp.type_expr fmt t ;
  Format.pp_print_flush fmt () ;
  Buffer.contents b

let string_of_longident li =
  let b = Buffer.create 256 in
  let fmt = Format.formatter_of_buffer b in
  Pprintast.longident fmt li ;
  Format.pp_print_flush fmt ();
  Buffer.contents b

let display_annot action (v:Sourceview.sourceview) args =
  let f = v#file#filename in
  try
    let file = v#file in
    let sv = v#source_view in
    let c = sv#insert_cursor in
    let pos = sv#cursor_offset c in
    (* beware of the possible offset between file contents and display *)
    let pos =
      Stk.Utf8.length
        (file#mode_from_display
         (sv#text ~start:0 ~stop:pos ()))
    in
    (* TODO: lookup for cmt file in other directories *)
    let cmt = load_cmt f in
    match Binannot.lookup_by_pos (f, pos) cmt  with
    | None -> failwith "No annotation found"
    | Some res ->
        let (left, right, message, copy) =
          match action with
          | Display_type copy ->
              let typ_str = string_of_type_expr res.typ in
              (res.loc.loc_start.pos_cnum,
               res.loc.loc_end.pos_cnum,
               typ_str, copy)
          | Jump_to_local_def ->
              begin
                match res.def with
                | None ->
                    (res.loc.loc_start.pos_cnum,
                     res.loc.loc_end.pos_cnum,
                     "No def", false)
                | Some loc ->
                    if Misc.safe_same_files loc.loc_start.pos_fname f then
                      (loc.loc_start.pos_cnum,
                       loc.loc_end.pos_cnum,
                       "", false)
                    else
                      let message = Printf.sprintf
                        "Definition is not local (%s)"
                          loc.loc_start.pos_fname
                      in
                      (res.loc.loc_start.pos_cnum,
                       res.loc.loc_end.pos_cnum,
                       message, false)
              end
          | Display_ident ->
              let message =
                match res.path with
                | None -> "No path"
                | Some p -> Path.name p
              in
              (res.loc.loc_start.pos_cnum,
               res.loc.loc_end.pos_cnum,
               message, false)
        in
        let message = Misc.to_utf8 message in
        if copy then
          let open Stk.Misc in
          let> () = Tsdl.Sdl.set_clipboard_text message in
          ()
        else
          v#select_range_in_file ~left ~right ();
        Misc.set_active_action_message  message;
  with
    Not_found -> ()
  | Failure s
  | Sys_error s ->
      Misc.set_active_action_message s;
;;

let call_display_tag_name = mode_name^"_call";;
let create_call_display_tag (v:Sourceview.sourceview) =
  let tag = Stk.Texttag.T.get_or_create call_display_tag_name in
  let theme = v#source_view#theme in
  Stk.Texttag.Theme.(
   set_tag_prop theme tag Stk.Props.fg_color (Ocf.get Mode_ocaml_rc.stack_call_fgcolor);
   set_tag_prop theme tag Stk.Props.bg_color (Ocf.get Mode_ocaml_rc.stack_call_bgcolor);
  );
  tag

let show_hide_call_annots (v:Sourceview.sourceview) args = ()
(*
  let f = v#file#filename in
  try
    let buf = v#file#buffer in
    let tt = new GText.tag_table buf#tag_table in
    match tt#lookup call_display_tag_name with
    | Some t ->
        buf#remove_tag_by_name call_display_tag_name
          ~start: buf#start_iter ~stop: buf#end_iter;
        tt#remove t;
        Misc.set_active_action_message
          (Misc.to_utf8 "Calls on stack hidden")
    | None ->
        ignore(create_call_display_tag buf);
        let t = load_annot_tree f in
        let f acc = function
          (left, right, Some (Annot.Call k)) -> (left, right, k) :: acc
        | _ -> acc
        in
        let calls = Annot.fold f [] t in
        let display_call n (left, right, kind) =
          match kind with
            `Tail -> n
          | `Stack ->
              let (left, right) = v#file#range_from_range_in_file ~left ~right in
              let start = buf#get_iter (`OFFSET left) in
              let stop = buf#get_iter (`OFFSET right) in
              buf#apply_tag_by_name call_display_tag_name ~start ~stop;
              n+1
        in
        let n = List.fold_left display_call 0 calls in
        Misc.set_active_action_message
          (Misc.to_utf8 (Printf.sprintf "%d calls on stack showed" n))
  with
  | Failure s
  | Sys_error s ->
      Misc.set_active_action_message s
;;
*)

let display_type_annot = display_annot (Display_type false);;
let copy_type_annot = display_annot (Display_type true);;
(*let display_call_annot = display_annot `Call;;*)
let display_ident_annot = display_annot Display_ident;;
let jump_to_local_def = display_annot Jump_to_local_def;;

let expand_external_idents (v:Sourceview.sourceview) args =
  let open Location in
  let module B = Stk.Textbuffer in
  let f = v#file#filename in
  let sv = v#source_view in
  let ext_refs =
    try
      let t = load_cmt f in
      let from_stdlib s = Misc.is_prefix s "Stdlib." in
      let f acc (path, loc, defloc) =
        match defloc with
        | None -> acc
        | Some loc when Misc.safe_same_files loc.loc_start.pos_fname f ->
            acc
        | Some _ ->
            let path_s = Path.name path in
            if from_stdlib path_s then
              acc
          else
              (loc, path_s) :: acc
      in
      List.sort
        (fun (l1, _) (l2, _) -> Stdlib.compare l1.loc_start.pos_cnum l2.loc_start.pos_cnum)
          ((Binannot.fold_exp_idents f [] t))
    with
    | Failure s
    | Sys_error s ->
        Misc.set_active_action_message s;
        []
  in
  let b = v#file#buffer#buffer in
  let mb = v#minibuffer in
  let title s1 s2 = Printf.sprintf
    "Replace %s by %s ? (y/n/!)" s1 s2
  in
  let nb_replaced = ref 0 in
  let (t,u) = Lwt.wait () in
  let ok () = Lwt.wakeup u () in
  let rec iter interactive offset = function
  | [] -> mb#set_active false; ok ()
  | (loc, ext_id) :: q ->
      let left = offset + loc.loc_start.pos_cnum in
        let right = offset + loc.loc_end.pos_cnum  in
      let (b_left, b_right) = v#file#range_from_range_in_file ~left ~right in
      let current = B.to_string ~start:b_left ~size:(b_right-b_left) b in
      if current = ext_id then
        iter interactive offset q
        else
          begin
            sv#select_range ~start:b_left ~size:(b_right-b_left) ;
            let replace () =
              sv#move_cursor ~offset:b_left ~c:sv#insert_cursor ();
              ignore(sv#delete ~start:b_left ~size:(b_right-b_left) ());
              sv#insert ext_id;
              incr nb_replaced;
            in
            let new_offset = offset - (right - left) + (String.length ext_id) in
            if interactive then
              (
               let f_yes () = replace (); iter interactive new_offset q in
               let f_no () = iter interactive offset q in
               let f_bang () = replace (); iter false new_offset q 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 ;
                 ];
               let title = title current ext_id in
               mb#set_text ~fixed: title "";
               if not mb#active then (mb#set_active true)
              )
            else
              (replace (); iter interactive new_offset q)
          end
  in
  (try iter true 0 ext_refs
   with e -> Lwt.wakeup_exn u e);
  Misc.set_active_action_message
    (Misc.to_utf8 (Printf.sprintf "%d ident(s) replaced." !nb_replaced));
  t

;;

let coms = [
    "indent_line", [| |], None, indent_line ;
    "indent_buffer", [| |], None, indent_buffer ;
    "display_type_annot", [| |], None, display_type_annot ;
    "copy_type_annot", [| |], None, copy_type_annot ;
(*    "display_call_annot", [| |], None, display_call_annot ;*)
    "display_ident_annot", [| |], None, display_ident_annot ;
    "jump_to_local_def", [| |], None, jump_to_local_def ;
    "show_stack_calls", [| |], None, show_hide_call_annots;
 ]

let coms_lwt =
  [
    "switch_file", [| |], None, switch_file ;
    "expand_ext_idents", [| |], None, expand_external_idents;
  ]

let _ = List.iter
    (fun (name, args, more, f) ->
      Sourceview.register_com
        ~prefix: mode_name name args ?more f)
    coms

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


class mode =
  object
    inherit Sourceview.empty_mode
    method name = mode_name
    method key_bindings : (Stk.Key.keystate list * string) list =
      Ocf.get Mode_ocaml_rc.key_bindings
    method menus : (string * Stk.Menu.menu_entry list) list =
      [
        "OCaml",
          [ `I ("Switch file", fun () -> Commands.async_command "ocaml_switch_file") ;
            (*`S ;*)
            `I ("Indent line", fun () -> Commands.async_command "ocaml_indent_line") ;
            `I ("Indent buffer", fun () -> Commands.async_command "ocaml_indent_buffer") ;
            (*`S ;*)
            `I ("Run ocamlbuild", fun () -> Commands.async_command "ocaml_build") ;
            (*`S ;*)
            `I ("Display type (from .cmt file)", fun () -> Commands.async_command "ocaml_display_type_annot") ;
            `I ("Copy type (from .cmt file)", fun () -> Commands.async_command "ocaml_copy_type_annot") ;
            `I ("Display call kind (from .annot file)", fun () -> Commands.async_command "ocaml_display_call_annot") ;
            `I ("Display ident path (from .cmt file)", fun () -> Commands.async_command "ocaml_display_ident_annot") ;
            `I ("Jump to local def (from .cmt file)", fun () -> Commands.async_command "ocaml_jump_to_local_def") ;
            `I ("Show stack calls (from .annot file)", fun () -> Commands.async_command "ocaml_show_stack_calls") ;
          ]
      ]

    method word_re = "[a-zA-Z0-9_']+"
  end

let mode = new mode;;
let _ = Sourceview.register_mode mode;;
let _ = Commands.register_after
  { Commands.com_name = Constant.com_on_exit ;
    com_args = [| |] ;
    com_more_args = None ;
    com_f = (fun _ -> Mode_ocaml_rc.local_write (); Lwt.return_unit) ;
  };;
