(*
 * uTop.ml
 * -------
 * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
 * Licence   : BSD3
 *
 * This file is a part of utop.
 *)

open CamomileLibraryDyn.Camomile
open Lwt_react
open LTerm_text
open LTerm_geom
open LTerm_style

module String_set = Set.Make(String)

let version = UTop_version.version

(* +-----------------------------------------------------------------+
   | History                                                         |
   +-----------------------------------------------------------------+ *)

let history = LTerm_history.create []
let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history"))
let history_file_max_size = ref None
let history_file_max_entries = ref None

(* +-----------------------------------------------------------------+
   | Hooks                                                           |
   +-----------------------------------------------------------------+ *)

let new_command_hooks = Lwt_sequence.create ()
let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks)

(* +-----------------------------------------------------------------+
   | Config                                                          |
   +-----------------------------------------------------------------+ *)

type ui = UTop_private.ui = Console | Emacs

let get_ui () = S.value UTop_private.ui

type profile = Dark | Light

let profile, set_profile = S.create Dark

let size = UTop_private.size

let key_sequence = UTop_private.key_sequence

let count = UTop_private.count

let time = ref 0.

let () = at_new_command (fun () -> time := Unix.time ())

let make_variable ?eq x =
  let signal, set = S.create ?eq x in
  (signal, (fun () -> S.value signal), set)

let camlp4, get_camlp4, set_camlp4 = make_variable true
let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;"
let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true

(* +-----------------------------------------------------------------+
   | Keywords                                                        |
   +-----------------------------------------------------------------+ *)

let default_keywords = [
  "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
  "done"; "downto"; "else"; "end"; "exception"; "external";
  "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
  "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
  "mutable"; "new"; "object";  "of";  "open"; "private";  "rec"; "sig";
  "struct";  "then";  "to";  "try";  "type";  "val"; "virtual";
  "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt";
]

let keywords = ref (List.fold_left (fun set kwd -> String_set.add kwd set) String_set.empty default_keywords)
let add_keyword kwd = keywords := String_set.add kwd !keywords

(* +-----------------------------------------------------------------+
   | Error reporting                                                 |
   +-----------------------------------------------------------------+ *)

let get_message func x =
  let buffer = Buffer.create 1024 in
  let pp = Format.formatter_of_buffer buffer in
  Format.pp_set_margin pp (S.value size).cols;
  func pp x;
  Format.pp_print_flush pp ();
  Buffer.contents buffer

let get_ocaml_error_message exn =
  let buffer = Buffer.create 1024 in
  let pp = Format.formatter_of_buffer buffer in
  Format.pp_set_margin pp (S.value size).cols;
  Errors.report_error pp exn;
  Format.pp_print_flush pp ();
  let str = Buffer.contents buffer in
  try
    Scanf.sscanf
      str
      "Characters %d-%d:\n%[\000-\255]"
      (fun start stop msg -> ((start, stop), msg))
  with _ ->
    ((0, 0), str)

(* +-----------------------------------------------------------------+
   | Parsing                                                         |
   +-----------------------------------------------------------------+ *)

type location = int * int

type 'a result =
  | Value of 'a
  | Error of location list * string

exception Need_more

#if ocaml_version <= (3, 12, 1)
let input_name = ""
#else
let input_name = "//toplevel//"
#endif

let lexbuf_of_string eof str =
  let pos = ref 0 in
  Lexing.from_function
    (fun buf len ->
       if !pos = String.length str then begin
         eof := true;
         0
       end else begin
         let len = min len (String.length str - !pos) in
         String.blit str !pos buf 0 len;
         pos := !pos + len;
         len
       end)

let mkloc loc =
  (loc.Location.loc_start.Lexing.pos_cnum,
   loc.Location.loc_end.Lexing.pos_cnum)

let parse_toplevel_phrase_default str eos_is_error =
  let eof = ref false in
  let lexbuf = lexbuf_of_string eof str in
  try
    (* Try to parse the phrase. *)
    let phrase = Parse.toplevel_phrase lexbuf in
    Value phrase
  with
    | _ when !eof && not eos_is_error ->
        (* This is not an error, we just need more input. *)
        raise Need_more
    | End_of_file ->
        (* If the string is empty, do not report an error. *)
        raise Need_more
    | Lexer.Error (error, loc) ->
        Error ([mkloc loc], get_message Lexer.report_error error)
    | Syntaxerr.Error (Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing)) ->
        Error ([mkloc opening_loc; mkloc closing_loc],
               Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening)
    | Syntaxerr.Error (Syntaxerr.Applicative_path loc) ->
        Error ([mkloc loc],
               "Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.")
    | Syntaxerr.Error (Syntaxerr.Other loc) ->
        Error ([mkloc loc],
               "Syntax error")
    | Syntaxerr.Escape_error | Parsing.Parse_error ->
        Error ([mkloc (Location.curr lexbuf)],
               "Syntax error")
    | exn ->
        Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn)

let parse_toplevel_phrase = ref parse_toplevel_phrase_default

(* +-----------------------------------------------------------------+
   | Safety checking                                                 |
   +-----------------------------------------------------------------+ *)

let null = Format.make_formatter (fun str ofs len -> ()) ignore

let rec last head tail =
  match tail with
    | [] ->
        head
    | head :: tail ->
        last head tail

(* Check that the given phrase can be evaluated without typing/compile
   errors. *)
let check_phrase phrase =
  match phrase with
    | Parsetree.Ptop_dir _ ->
        None
    | Parsetree.Ptop_def [] ->
        None
    | Parsetree.Ptop_def (item :: items) ->
        let loc = {
          Location.loc_start = item.Parsetree.pstr_loc.Location.loc_start;
          Location.loc_end = (last item items).Parsetree.pstr_loc.Location.loc_end;
          Location.loc_ghost = false;
        } in
        (* Backup. *)
        let snap = Btype.snapshot () in
        let env = !Toploop.toplevel_env in
        (* Construct "module _(_ : sig end) = struct <items> end" in
           order to test the typing and compilation of [items] without
           evaluating them. *)
        let wrapped_items = {
          Parsetree.pmod_loc = loc;
          Parsetree.pmod_desc = Parsetree.Pmod_structure (item :: items);
        } in
        let empty_sig = {
          Parsetree.pmty_loc = loc;
          Parsetree.pmty_desc = Parsetree.Pmty_signature [];
        } in
        let funct = {
          Parsetree.pmod_loc = loc;
          Parsetree.pmod_desc = Parsetree.Pmod_functor ("_", empty_sig, wrapped_items);
        } in
        let top_def = {
          Parsetree.pstr_loc = loc;
          Parsetree.pstr_desc = Parsetree.Pstr_module ("_", funct);
        } in
        let check_phrase = Parsetree.Ptop_def [top_def] in
        try
          let _ = Toploop.execute_phrase false null check_phrase in
          (* The phrase is safe. *)
          Toploop.toplevel_env := env;
          Btype.backtrack snap;
          None
        with exn ->
          (* The phrase contains errors. *)
          Toploop.toplevel_env := env;
          Btype.backtrack snap;
          let loc, msg = get_ocaml_error_message exn in
          Some ([loc], msg)

(* +-----------------------------------------------------------------+
   | Prompt                                                          |
   +-----------------------------------------------------------------+ *)

let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) =
  let tm = Unix.localtime !time in
  let color dark light =
    match profile with
      | Dark -> dark
      | Light -> light
  in
  match ui with
    | Emacs ->
        [||]
    | Console ->
        let bold = profile = Dark in
        let txta =
          if key_sequence = [] then
            eval [
              B_bold bold;
              B_fg (color lcyan blue);
              S "─( ";
              B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
              S " )─< ";
              B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
              S " >─";
            ]
          else
            eval [
              B_bold bold;
              B_fg (color lcyan blue);
              S "─( ";
              B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
              S " )─< ";
              B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
              S " >─[ ";
              B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg;
              S " ]─";
            ]
        in
        let txtb =
          if recording then
            eval [
              B_bold bold;
              B_fg (color lcyan blue);
              S "{ ";
              B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
              S " }─[ ";
              B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg;
              S " ]─";
            ]
          else
            eval [
              B_bold bold;
              B_fg (color lcyan blue);
              S "{ ";
              B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
              S " }─";
            ]
        in
        let second_line =
          eval [
            S "\n";
            B_bold bold;
            B_fg (rgb 0xe3 0xaa 0x73);
            S "utop";
            B_fg (color lgreen green);
            S " $ ";
          ]
        in
        Array.append (
          if Array.length txta + Array.length txtb > size.cols then
            Array.sub (Array.append txta txtb) 0 size.cols
          else
            Array.concat [
              txta;
              Array.make
                (size.cols - Array.length txta - Array.length txtb)
                (UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold });
              txtb;
            ]
        ) second_line

let prompt = ref (
  S.l6 make_prompt
    UTop_private.ui
    profile
    count
    size
    key_sequence
    (S.l3 (fun x y z -> (x, y, z))
       (Zed_macro.recording LTerm_read_line.macro)
       (Zed_macro.count LTerm_read_line.macro)
       (Zed_macro.counter LTerm_read_line.macro))
)

(* +-----------------------------------------------------------------+
   | Help                                                            |
   +-----------------------------------------------------------------+ *)

module Bindings = Zed_input.Make (LTerm_key)
module Keys_map = Map.Make (struct type t = LTerm_key.t list let compare = compare end)

let () =
  Hashtbl.add Toploop.directive_table "utop_help"
    (Toploop.Directive_none
       (fun () ->
          print_endline "If colors look too bright, try: UTop.set_profile UTop.Light

You can use the following commands to get more help:

#utop_bindings : list all the current key bindings
#utop_macro : display the currently recorded macro

For a complete description of utop, look at the utop(1) manual page."));

  Hashtbl.add Toploop.directive_table "utop_bindings"
    (Toploop.Directive_none
       (fun () ->
          let make_lines keys actions acc =
            match actions with
              | [] ->
                  (String.concat " " (List.map LTerm_key.to_string_compact keys),
                   "",
                   "does nothing")
                  :: acc
              | action :: actions ->
                  let rec loop actions acc =
                    match actions with
                      | [] ->
                          acc
                      | action :: actions ->
                          loop
                            actions
                            (("",
                              LTerm_read_line.name_of_action action,
                              LTerm_read_line.doc_of_action action)
                             :: acc)
                  in
                  loop
                    actions
                    ((String.concat " " (List.map LTerm_key.to_string_compact keys),
                      LTerm_read_line.name_of_action action,
                      LTerm_read_line.doc_of_action action)
                     :: acc)
          in
          let bindings = Bindings.fold (fun key actions map -> Keys_map.add key (List.map (fun action -> (LTerm_read_line.Edit action)) actions) map) !LTerm_edit.bindings Keys_map.empty in
          let bindings = Bindings.fold Keys_map.add !LTerm_read_line.bindings bindings in
          let table = List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc) bindings []) in
          let size_key, size_name, size_doc =
            List.fold_left
              (fun (size_key, size_name, size_doc) (key, name, doc) ->
                 (max (String.length key) size_key,
                  max (String.length name) size_name,
                  max (String.length doc) size_doc))
              (0, 0, 0)
              table
          in
          let buf = Buffer.create 128 in
          let format_line (key, name, doc) =
            Buffer.clear buf;
            Buffer.add_string buf key;
            while Buffer.length buf < size_key do
              Buffer.add_char buf ' '
            done;
            Buffer.add_string buf " : ";
            Buffer.add_string buf name;
            while Buffer.length buf < size_key + size_name + 3 do
              Buffer.add_char buf ' '
            done;
            Buffer.add_string buf " -> ";
            Buffer.add_string buf doc;
            Buffer.add_char buf '\n';
            output_string stdout (Buffer.contents buf)
          in
          List.iter format_line table;
          flush stdout));

  Hashtbl.add Toploop.directive_table "utop_macro"
    (Toploop.Directive_none
       (fun () ->
          let macro = Zed_macro.contents LTerm_read_line.macro in
          List.iter
            (fun action ->
               output_string stdout (LTerm_read_line.name_of_action action);
               output_char stdout '\n')
            macro;
          flush stdout))

(* +-----------------------------------------------------------------+
   | Camlp4                                                          |
   +-----------------------------------------------------------------+ *)

let print_error msg =
  lwt term = Lazy.force LTerm.stdout in
  lwt () = LTerm.set_style term !UTop_private.error_style in
  lwt () = Lwt_io.print msg in
  lwt () = LTerm.set_style term LTerm_style.none in
  LTerm.flush term

let handle_findlib_error = function
  | Failure msg ->
      Lwt_main.run (print_error msg)
  | Fl_package_base.No_such_package(pkg, reason) ->
      Lwt_main.run (print_error (Printf.sprintf "No such package: %s%S\n" pkg (if reason <> "" then " - " ^ reason else "")))
  | Fl_package_base.Package_loop pkg ->
      Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
  | exn ->
      raise exn

let () =
  Hashtbl.add
    Toploop.directive_table
    "camlp4o"
    (Toploop.Directive_none
       (fun () ->
          set_phrase_terminator ";;";
          try
            Topfind.syntax "camlp4o";
            Topfind.load_deeply ["utop.camlp4"]
          with exn ->
            handle_findlib_error exn));

  Hashtbl.add
    Toploop.directive_table
    "camlp4r"
    (Toploop.Directive_none
       (fun () ->
          set_phrase_terminator ";";
          try
            Topfind.syntax "camlp4r";
            Topfind.load_deeply ["utop.camlp4"]
          with exn ->
            handle_findlib_error exn))

(* +-----------------------------------------------------------------+
   | Initialization                                                  |
   +-----------------------------------------------------------------+ *)

let () =
  (* "utop" is an internal library so it is not passed as "-package"
     to "ocamlfind ocamlmktop". *)
  Topfind.don't_load ["utop"];
  (* Add findlib path so Topfind is available and it won't be
     initialized twice if the user does [#use "topfind"]. *)
  Topdirs.dir_directory (Findlib.package_directory "findlib");
  (* Make UTop accessible. *)
  Topdirs.dir_directory (Findlib.package_directory "utop")

(* +-----------------------------------------------------------------+
   | Deprecated                                                      |
   +-----------------------------------------------------------------+ *)

let smart_accept = ref true
let new_prompt_hooks = Lwt_sequence.create ()
let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks)
let prompt_continue = ref (S.const [| |])
let prompt_comment = ref (S.const [| |])