(*************************************************************************)

(*                                                                       *)

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