Source file `warning_manager.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
(**************************************************************************)
(*                                                                        *)
(*  SPDX-License-Identifier LGPL-2.1                                      *)
(*  Copyright (C)                                                         *)
(*  CEA (Commissariat à l'énergie atomique et aux énergies alternatives)  *)
(*                                                                        *)
(**************************************************************************)

let scope = function
  | None -> "Global"
  | Some s -> Format.asprintf "%a" Cil_datatype.Position.pretty s

type row = Log.event

type t =
  { append : row -> unit;
    clear : unit -> unit;}

module Data = Indexer.Make(
  struct
    type t = int*row
    let compare (x,_) (y,_) = Stdlib.compare x y
  end)

let make ~packing ~callback =
  let model = object(self)
    val mutable m = Data.empty
    val mutable age = 0
    method data = m
    method size =  Data.size m
    method index i = Data.index i m
    method get i = Data.get i m
    method add i = age<-age+1; m <- Data.add (age,i) m;age,i
    method reload = age<-0; m <- Data.empty
    method coerce = (self:> (int*row) Wtable.listmodel)
  end
  in
  let w = new Wtable.list
    ~packing ~headers:true ~rules:true model#coerce
  in
  let append e = w#insert_row (model#add e)
  in
  let clear () =
    (* Post a reload request before clearing.
       The current model is used to know how many rows
       must be deleted. *)
    w#reload ;
  in
  let open Log in
  let _ = w#add_column_pixbuf ~title:"Kind" [`YALIGN 0.0;`XALIGN 0.5]
      (fun (_,e) -> match e with
         | {evt_kind=Error} -> [`STOCK_ID "gtk-dialog-error"]
         | {evt_kind=Warning} -> [`STOCK_ID  "gtk-dialog-warning"]
         | _ -> [`STOCK_ID "gtk-dialog-info"])
  in
  let _ = w#add_column_text ~title:"Source" [`YALIGN 0.0]
      (fun (_,{evt_source=src}) -> [`TEXT (scope src)])
  in
  let _ = w#add_column_text ~title:"Plugin" [`YALIGN 0.0]
      (fun (_,{evt_plugin=m}) -> [`TEXT m])
  in
  let _ = w#add_column_text ~title:"Message" [`YALIGN 0.0 ; `EDITABLE true]
      (fun (_,e) -> [`TEXT (Log.Event.message e)])
  in
  w#on_click (fun (_,w) c -> callback w c);
  {append=append;clear=clear}

let append t message = t.append message

let clear t = t.clear ()