Merge branch 'warnings' into trunk

Was PR#213: New warnings machinery

5 files changed, 33 insertions, 10 deletions

diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index f0e767cba3..18557ab6b4 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -14,15 +14,17 @@ open Feedback
 
 let b2c = byte_offset_to_char_offset
 
-type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string ]
-type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
+type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string | `WARNING of Loc.t * string ]
+type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR | `WARNING ]
 let mem_flag_of_flag : flag -> mem_flag = function
   | `ERROR _ -> `ERROR
+  | `WARNING _ -> `WARNING
   | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag
 let str_of_flag = function
   | `UNSAFE -> "U"
   | `PROCESSING -> "P"
   | `ERROR _ -> "E"
+  | `WARNING _ -> "W"
   | `INCOMPLETE -> "I"
 
 class type signals =
@@ -470,6 +472,13 @@ object(self)
           self#attach_tooltip sentence loc msg;
           if not (Loc.is_ghost loc) then
             self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc))
+      | Message(Warning, loc, msg), Some (id,sentence) ->
+          let loc = Option.default Loc.ghost loc in
+          let msg = Richpp.raw_print msg         in
+          log "WarningMsg" id;
+          add_flag sentence (`WARNING (loc, msg));
+          self#attach_tooltip sentence loc msg;
+          self#position_warning_tag_at_sentence sentence loc
       | InProgress n, _ ->
           if n < 0 then processed <- processed + abs n
           else to_process <- to_process + n
@@ -511,6 +520,18 @@ object(self)
     let start, _, phrase = self#get_sentence sentence in
     self#position_error_tag_at_iter start phrase loc
 
+  method private position_warning_tag_at_iter iter_start iter_stop phrase loc =
+    if Loc.is_ghost loc then
+        buffer#apply_tag Tags.Script.warning ~start:iter_start ~stop:iter_stop
+    else
+      buffer#apply_tag Tags.Script.warning
+	  ~start:(iter_start#forward_chars (b2c phrase loc.Loc.bp))
+          ~stop:(iter_stop#forward_chars (b2c phrase loc.Loc.ep))
+
+  method private position_warning_tag_at_sentence sentence loc =
+    let start, stop, phrase = self#get_sentence sentence in
+    self#position_warning_tag_at_iter start stop phrase loc
+
   method private process_interp_error queue sentence loc msg tip id =
     Coq.bind (Coq.return ()) (function () ->
     let start, stop, phrase = self#get_sentence sentence in
diff --git a/ide/sentence.ml b/ide/sentence.ml
index 6897779e80..e332682dd0 100644
--- a/ide/sentence.ml
+++ b/ide/sentence.ml
@@ -16,6 +16,7 @@
 let split_slice_lax (buffer:GText.buffer) start stop =
   buffer#remove_tag ~start ~stop Tags.Script.sentence;
   buffer#remove_tag ~start ~stop Tags.Script.error;
+  buffer#remove_tag ~start ~stop Tags.Script.warning;
   buffer#remove_tag ~start ~stop Tags.Script.error_bg;
   let slice = buffer#get_text ~start ~stop () in
   let apply_tag off tag =
diff --git a/ide/session.ml b/ide/session.ml
index cdec392ecc..e998337604 100644
--- a/ide/session.ml
+++ b/ide/session.ml
@@ -195,12 +195,8 @@ let set_buffer_handlers
          to a point indicated by coq. *)
       if !no_coq_action_required then begin
         let start, stop = get_start (), get_stop () in
-        buffer#remove_tag Tags.Script.error ~start ~stop;
-        buffer#remove_tag Tags.Script.error_bg ~start ~stop;
-        buffer#remove_tag Tags.Script.tooltip ~start ~stop;
-        buffer#remove_tag Tags.Script.processed ~start ~stop;
-        buffer#remove_tag Tags.Script.to_process ~start ~stop;
-        buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+	List.iter (fun tag -> buffer#remove_tag tag ~start ~stop)
+		  Tags.Script.ephemere;
         Sentence.tag_on_insert buffer
       end;
     end in
diff --git a/ide/tags.ml b/ide/tags.ml
index 9ccff9fb51..e4510e7af4 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -18,6 +18,7 @@ struct
   let table = GText.tag_table ()
   let comment = make_tag table ~name:"comment" []
   let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE]
+  let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"]
   let error_bg = make_tag table ~name:"error_bg" []
   let to_process = make_tag table ~name:"to_process" []
   let processed = make_tag table ~name:"processed" []
@@ -29,9 +30,11 @@ struct
   let sentence = make_tag table ~name:"sentence" []
   let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *)
 
+  let ephemere =
+    [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified]
+
   let all =
-    [comment; error; error_bg; to_process; processed; incomplete; unjustified;
-     found; sentence; tooltip]
+    comment :: found :: sentence :: ephemere
 
   let edit_zone =
     let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in
diff --git a/ide/tags.mli b/ide/tags.mli
index 5a932f3300..02e15a5ae4 100644
--- a/ide/tags.mli
+++ b/ide/tags.mli
@@ -11,6 +11,7 @@ sig
   val table : GText.tag_table
   val comment : GText.tag
   val error : GText.tag
+  val warning : GText.tag
   val error_bg : GText.tag
   val to_process : GText.tag
   val processed : GText.tag
@@ -20,6 +21,7 @@ sig
   val sentence : GText.tag
   val tooltip : GText.tag
   val edit_zone : GText.tag (* for debugging *)
+  val ephemere : GText.tag list
   val all : GText.tag list
 end