(*************************************************************************)
(*                                                                       *)
(*                         OCaml LablTk library                          *)
(*                                                                       *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
(*   en Automatique and Kyoto University.  All rights reserved.          *)
(*   This file is distributed under the terms of the GNU Library         *)
(*   General Public License, with the special exception on linking       *)
(*   described in file ../../../LICENSE.                                 *)
(*                                                                       *)
(*************************************************************************)

(* $Id$ *)

open StdLabels
open Tk
open Parsetree
open Typedtree
open Location
open Jg_tk
open Mytypes

(* Optionally preprocess a source file *)

let preprocess ~pp ~ext text =
  let sourcefile = Filename.temp_file "caml" ext in
  begin try
    let oc = open_out_bin sourcefile in
    output_string oc text;
    flush oc;
    close_out oc
  with _ ->
    failwith "Preprocessing error"
  end;
  let tmpfile = Filename.temp_file "camlpp" ext in
  let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
  if Ccomp.command comm <> 0 then begin
    Sys.remove sourcefile;
    Sys.remove tmpfile;
    failwith "Preprocessing error"
  end;
  Sys.remove sourcefile;
  tmpfile

exception Outdated_version

let parse_pp ~parse ~wrap ~ext text =
  Location.input_name := "";
  match !Clflags.preprocessor with
    None ->
      let buffer = Lexing.from_string text in
      Location.init buffer "";
      parse buffer
  | Some pp ->
      let tmpfile = preprocess ~pp ~ext text in
      let ast_magic =
        if ext = ".ml" then Config.ast_impl_magic_number
        else Config.ast_intf_magic_number in
      let ic = open_in_bin tmpfile in
      let ast =
        try
          let buffer = really_input_string ic (String.length ast_magic) in
          if buffer = ast_magic then begin
            ignore (input_value ic);
            wrap (input_value ic)
          end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
            raise Outdated_version
          else
            raise Exit
        with
          Outdated_version ->
            close_in ic;
            Sys.remove tmpfile;
            failwith "OCaml and preprocessor have incompatible versions"
        | _ ->
            seek_in ic 0;
            let buffer = Lexing.from_channel ic in
            Location.init buffer "";
            parse buffer
      in
      close_in ic;
      Sys.remove tmpfile;
      ast

let nowarnings = ref false

let f txt =
  let error_messages = ref [] in
  let text = Jg_text.get_all txt.tw
  and env = ref (Compmisc.initial_env ()) in
  let tl, ew, end_message =
    Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in
  Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend;
  txt.structure <- [];
  txt.type_info <- [];
  txt.signature <- [];
  txt.psignature <- [];
  ignore (Stypes.get_info ());
  Clflags.annotations := true;

  begin try

    if Filename.check_suffix txt.name ".mli" then
    let psign = parse_pp text ~ext:".mli"
        ~parse:Parse.interface ~wrap:(fun x -> x) in
    txt.psignature <- psign;
    txt.signature <- (Typemod.transl_signature !env psign).sig_type;

    else (* others are interpreted as .ml *)

    let psl = parse_pp text ~ext:".ml"
        ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in
    List.iter psl ~f:
    begin function
      Ptop_def pstr ->
        let str, sign, env' = Typemod.type_structure !env pstr Location.none in
        txt.structure <- txt.structure @ str.str_items;
        txt.signature <- txt.signature @ sign;
        env := env'
    | Ptop_dir _ -> ()
    end;
    txt.type_info <- Stypes.get_info ();

  with
    Lexer.Error _ | Syntaxerr.Error _
  | Typecore.Error _ | Typemod.Error _
  | Typeclass.Error _ | Typedecl.Error _
  | Typetexp.Error _ | Includemod.Error _
  | Env.Error _ | Ctype.Tags _ | Failure _ as exn ->
      txt.type_info <- Stypes.get_info ();
      let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in
      error_messages := et :: !error_messages;
      let range = match exn with
        Lexer.Error (err, l) ->
          Lexer.report_error Format.std_formatter err; l
      | Syntaxerr.Error err ->
          Syntaxerr.report_error Format.std_formatter err;
          Syntaxerr.location_of_error err
      | Typecore.Error (l, env, err) ->
          Typecore.report_error env Format.std_formatter err; l
      | Typeclass.Error (l, env, err) ->
          Typeclass.report_error env Format.std_formatter err; l
      | Typedecl.Error (l, err) ->
          Typedecl.report_error Format.std_formatter err; l
      | Typemod.Error (l, env, err) ->
          Typemod.report_error env Format.std_formatter err; l
      | Typetexp.Error (l, env, err) ->
          Typetexp.report_error env Format.std_formatter err; l
      | Includemod.Error errl ->
          Includemod.report_error Format.std_formatter errl; Location.none
      | Env.Error err ->
          Env.report_error Format.std_formatter err; Location.none
      | Cmi_format.Error err ->
          Cmi_format.report_error Format.std_formatter err; Location.none
      | Ctype.Tags(l, l') ->
          Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l';
          Location.none
      | Failure s ->
          Format.printf "%s.@." s; Location.none
      | _ -> assert false
      in
      end_message ();
      let s = range.loc_start.Lexing.pos_cnum in
      let e = range.loc_end.Lexing.pos_cnum in
      if s < e then
        Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"
  end;
  end_message ();
  if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0)
  then destroy tl
  else begin
    error_messages := tl :: !error_messages;
    Text.configure ew ~state:`Disabled;
    bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)]
      ~action:(fun _ ->
        try
          let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in
          let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in
          let n = int_of_string s in
          Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert";
          Text.see txt.tw ~index:(`Mark "insert", [])
        with _ -> ())
  end;
  !error_messages