l4/pkg/ocaml/contrib/otherlibs/labltk/browser/typecheck.ml

   1 (*************************************************************************)
   2 (*                                                                       *)
   3 (*                Objective Caml LablTk library                          *)
   4 (*                                                                       *)
   5 (*            Jacques Garrigue, Kyoto University RIMS                    *)
   6 (*                                                                       *)
   7 (*   Copyright 1999 Institut National de Recherche en Informatique et    *)
   8 (*   en Automatique and Kyoto University.  All rights reserved.          *)
   9 (*   This file is distributed under the terms of the GNU Library         *)
  10 (*   General Public License, with the special exception on linking       *)
  11 (*   described in file ../../../LICENSE.                                 *)
  12 (*                                                                       *)
  13 (*************************************************************************)
  14
  15 (* $Id: typecheck.ml 9293 2009-06-08 04:43:32Z garrigue $ *)
  16
  17 open StdLabels
  18 open Tk
  19 open Parsetree
  20 open Location
  21 open Jg_tk
  22 open Mytypes
  23
  24 (* Optionally preprocess a source file *)
  25
  26 let preprocess ~pp ~ext text =
  27   let sourcefile = Filename.temp_file "caml" ext in
  28   begin try
  29     let oc = open_out_bin sourcefile in
  30     output_string oc text;
  31     flush oc;
  32     close_out oc
  33   with _ ->
  34     failwith "Preprocessing error"
  35   end;
  36   let tmpfile = Filename.temp_file "camlpp" ext in
  37   let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
  38   if Ccomp.command comm <> 0 then begin
  39     Sys.remove sourcefile;
  40     Sys.remove tmpfile;
  41     failwith "Preprocessing error"
  42   end;
  43   Sys.remove sourcefile;
  44   tmpfile
  45
  46 exception Outdated_version
  47
  48 let parse_pp ~parse ~wrap ~ext text =
  49   Location.input_name := "";
  50   match !Clflags.preprocessor with
  51     None ->
  52       let buffer = Lexing.from_string text in
  53       Location.init buffer "";
  54       parse buffer
  55   | Some pp ->
  56       let tmpfile = preprocess ~pp ~ext text in
  57       let ast_magic =
  58         if ext = ".ml" then Config.ast_impl_magic_number
  59         else Config.ast_intf_magic_number in
  60       let ic = open_in_bin tmpfile in
  61       let ast =
  62         try
  63           let buffer = String.create (String.length ast_magic) in
  64           really_input ic buffer 0 (String.length ast_magic);
  65           if buffer = ast_magic then begin
  66             ignore (input_value ic);
  67             wrap (input_value ic)
  68           end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
  69             raise Outdated_version
  70           else
  71             raise Exit
  72         with
  73           Outdated_version ->
  74             close_in ic;
  75             Sys.remove tmpfile;
  76             failwith "Ocaml and preprocessor have incompatible versions"
  77         | _ ->
  78             seek_in ic 0;
  79             let buffer = Lexing.from_channel ic in
  80             Location.init buffer "";
  81             parse buffer
  82       in
  83       close_in ic;
  84       Sys.remove tmpfile;
  85       ast
  86
  87 let nowarnings = ref false
  88
  89 let f txt =
  90   let error_messages = ref [] in
  91   let text = Jg_text.get_all txt.tw
  92   and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in
  93   let tl, ew, end_message =
  94     Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in
  95   Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend;
  96   txt.structure <- [];
  97   txt.type_info <- [];
  98   txt.signature <- [];
  99   txt.psignature <- [];
 100   ignore (Stypes.get_info ());
 101   Clflags.annotations := true;
 102
 103   begin try
 104
 105     if Filename.check_suffix txt.name ".mli" then
 106     let psign = parse_pp text ~ext:".mli"
 107         ~parse:Parse.interface ~wrap:(fun x -> x) in
 108     txt.psignature <- psign;
 109     txt.signature <- Typemod.transl_signature !env psign
 110
 111     else (* others are interpreted as .ml *)
 112
 113     let psl = parse_pp text ~ext:".ml"
 114         ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in
 115     List.iter psl ~f:
 116     begin function
 117       Ptop_def pstr ->
 118         let str, sign, env' = Typemod.type_structure !env pstr Location.none in
 119         txt.structure <- txt.structure @ str;
 120         txt.signature <- txt.signature @ sign;
 121         env := env'
 122     | Ptop_dir _ -> ()
 123     end;
 124     txt.type_info <- Stypes.get_info ();
 125
 126   with
 127     Lexer.Error _ | Syntaxerr.Error _
 128   | Typecore.Error _ | Typemod.Error _
 129   | Typeclass.Error _ | Typedecl.Error _
 130   | Typetexp.Error _ | Includemod.Error _
 131   | Env.Error _ | Ctype.Tags _ | Failure _ as exn ->
 132       txt.type_info <- Stypes.get_info ();
 133       let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in
 134       error_messages := et :: !error_messages;
 135       let range = match exn with
 136         Lexer.Error (err, l) ->
 137           Lexer.report_error Format.std_formatter err; l
 138       | Syntaxerr.Error err ->
 139           Syntaxerr.report_error Format.std_formatter err;
 140           begin match err with
 141             Syntaxerr.Unclosed(l,_,_,_) -> l
 142           | Syntaxerr.Other l -> l
 143           end
 144       | Typecore.Error (l,err) ->
 145           Typecore.report_error Format.std_formatter err; l
 146       | Typeclass.Error (l,err) ->
 147           Typeclass.report_error Format.std_formatter err; l
 148       | Typedecl.Error (l, err) ->
 149           Typedecl.report_error Format.std_formatter err; l
 150       | Typemod.Error (l,err) ->
 151           Typemod.report_error Format.std_formatter err; l
 152       | Typetexp.Error (l,err) ->
 153           Typetexp.report_error Format.std_formatter err; l
 154       | Includemod.Error errl ->
 155           Includemod.report_error Format.std_formatter errl; Location.none
 156       | Env.Error err ->
 157           Env.report_error Format.std_formatter err; Location.none
 158       | Ctype.Tags(l, l') ->
 159           Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l';
 160           Location.none
 161       | Failure s ->
 162           Format.printf "%s.@." s; Location.none
 163       | _ -> assert false
 164       in
 165       end_message ();
 166       let s = range.loc_start.Lexing.pos_cnum in
 167       let e = range.loc_end.Lexing.pos_cnum in
 168       if s < e then
 169         Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"
 170   end;
 171   end_message ();
 172   if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0)
 173   then destroy tl
 174   else begin
 175     error_messages := tl :: !error_messages;
 176     Text.configure ew ~state:`Disabled;
 177     bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)]
 178       ~action:(fun _ ->
 179         try
 180           let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in
 181           let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in
 182           let n = int_of_string s in
 183           Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert";
 184           Text.see txt.tw ~index:(`Mark "insert", [])
 185         with _ -> ())
 186   end;
 187   !error_messages