[kernel] Reworks the list of emitted messages.

Registers all messages in the queue, and not only warnings and errors. Modifies
the GTK GUI to only show warnings and errors in the "Messages" panel.
Uses a Queue instead of a List, to iterate on messages in emission order.
Also exports [fold] on messages.

src/kernel_internals/runtime/messages.ml

@@ -40,7 +40,7 @@ module DatatypeMessages =
     end)
 
 module Messages =
-  State_builder.List_ref
+  State_builder.Queue
     (DatatypeMessages)
     (struct
       let name = "Messages.message_table"
@@ -51,33 +51,33 @@ let () = Ast.add_monotonic_state Messages.self
 let hooks = ref []
 let add_message m =
   begin
-    Messages.set (m :: Messages.get ()) ;
+    Messages.add m;
     List.iter (fun fn -> fn()) !hooks ;
   end
 
 let nb_errors () =
-  Messages.fold_left
+  Messages.fold
     (fun n e ->
        match e.Log.evt_kind with
        | Log.Error -> succ n
        | _ -> n) 0
 
 let nb_warnings () =
-  Messages.fold_left
+  Messages.fold
     (fun n e ->
        match e.Log.evt_kind with
        | Log.Warning -> succ n
        | _ -> n) 0
 
-let nb_messages() = List.length (Messages.get ())
+let nb_messages = Messages.length
 
 let self = Messages.self
 
-let iter f = List.iter f (List.rev (Messages.get ()))
+let iter = Messages.iter
+let fold = Messages.fold
 let dump_messages () = iter Log.echo
 
-let () =
-  Log.add_listener ~kind:[ Log.Error; Log.Warning ] add_message
+let () = Log.add_listener add_message
 
 module OnceTable =
   State_builder.Hashtbl

src/kernel_internals/runtime/messages.mli

@@ -20,13 +20,15 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Stored messages for persistence between sessions.
-    Currently, only warning and error messages are stored. *)
+(** Stored messages for persistence between sessions. *)
 
 val iter: (Log.event -> unit) -> unit
 (** Iter over all stored messages. The messages are passed in emission order.
     @modify Nitrogen-20111001  Messages are now passed in emission order. *)
 
+val fold: ('a -> Log.event -> 'a) -> 'a -> 'a
+(** Fold over all stored messages. The messages are passed in emission order. *)
+
 val dump_messages: unit -> unit
 (** Dump stored messages to standard channels *)
 

src/libraries/project/state_builder.ml

@@ -880,7 +880,9 @@ module type Queue = sig
   val self: State.t
   val add: elt -> unit
   val iter: (elt -> unit) -> unit
+  val fold: ('a -> elt -> 'a) -> 'a -> 'a
   val is_empty: unit -> bool
+  val length: unit -> int
 end
 
 module Queue(Data: Datatype.S)(Info: Info) = struct
@@ -913,7 +915,9 @@ module Queue(Data: Datatype.S)(Info: Info) = struct
 
   let add x = Queue.add x !state
   let iter f = Queue.iter f !state
+  let fold f acc = Queue.fold f acc !state
   let is_empty () = Queue.is_empty !state
+  let length () = Queue.length !state
 
 end
 

src/libraries/project/state_builder.mli

@@ -378,7 +378,9 @@ module type Queue = sig
   val self: State.t
   val add: elt -> unit
   val iter: (elt -> unit) -> unit
+  val fold: ('a -> elt -> 'a) -> 'a -> 'a
   val is_empty: unit -> bool
+  val length: unit -> int
 end
 
 module Queue(Data: Datatype.S)(Info: Info) : Queue with type elt = Data.t

src/plugins/gui/design.ml

@@ -1689,7 +1689,8 @@ class main_window () : main_window_extension_points =
           ignore
             (lower_notebook#insert_page ~pos:1
                ~tab_label:warnings_tab_label w);
-          let text = Format.sprintf "Messages (%d)" (Messages.nb_messages ()) in
+          let nb_messages = Messages.nb_warnings () + Messages.nb_errors () in
+          let text = Format.sprintf "Messages (%d)" nb_messages in
           let label = GtkMisc.Label.cast warnings_tab_label#as_widget in
           GtkMisc.Label.set_text label text
         in
@@ -1710,8 +1711,13 @@ class main_window () : main_window_extension_points =
       let display_warnings () =
         outdated_warnings := false ;
         Warning_manager.clear warning_manager;
-        Messages.iter (fun event -> Warning_manager.append warning_manager event);
-        let text = Format.sprintf "Messages (%d)" (Messages.nb_messages ()) in
+        Messages.iter
+          (fun event ->
+             match event.evt_kind with
+             | Warning | Error -> Warning_manager.append warning_manager event
+             | _ -> ());
+        let nb_messages = Messages.nb_warnings () + Messages.nb_errors () in
+        let text = Format.sprintf "Messages (%d)" nb_messages in
         let label = GtkMisc.Label.cast warnings_tab_label#as_widget in
         GtkMisc.Label.set_text label text
       in