Source file `wpalette.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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2023                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

open Widget

class tool ?label ?tooltip ?content () =
  let status = new Widget.image `None in
  let toggle = new Widget.toggle ~align:`Left ?label ?tooltip ~border:false () in
  let action = new Widget.button ~icon:`MEDIA_PLAY ?tooltip () in
  object(self)

    initializer
      begin
        let color = `NAME "orange" in
        toggle#coerce#misc#modify_bg [ `PRELIGHT , color ; `ACTIVE , color ] ;
        toggle#connect self#toggle ;
        action#connect self#action ;
        self#toggle false ;
        action#set_border false ;
        Wutil.on content self#set_content ;
      end

    val mutable details = None
    val mutable tooltip = None
    val mutable callback = None
    val mutable view = None

    method private toggle a =
      match details with
      | None -> ()
      | Some w -> Wutil.set_visible w a

    method private action () =
      match callback with
      | None -> ()
      | Some f -> f ()

    method private render =
      let hbox = GPack.hbox ~show:true () in
      hbox#pack ~expand:false status#coerce ;
      hbox#pack ~expand:true ~fill:true ~padding:1 toggle#coerce ;
      hbox#pack ~expand:false action#coerce ;
      match details with
      | None -> hbox#coerce
      | Some w ->
        let vbox = GPack.vbox ~show:true () in
        vbox#pack ~expand:false hbox#coerce ;
        vbox#pack ~expand:true ~fill:false w#coerce ;
        vbox#coerce

    method tool = (self :> tool)

    method widget =
      match view with Some w -> w | None ->
        let w = new Wutil.gobj_widget self#render in
        view <- Some w ; w

    method coerce = self#widget#coerce
    method on_active = toggle#connect
    method is_active = toggle#get
    method set_active = toggle#set
    method has_action = callback != None
    method set_enabled e = self#widget#set_enabled e
    method set_visible v = self#widget#set_visible v

    method set_label = toggle#set_label
    method set_tooltip txt = toggle#set_tooltip txt
    method set_status = status#set_icon

    method clear_action =
      callback <- None ;
      action#set_visible false

    method set_action ?icon ?tooltip ?callback:cb () =
      begin
        callback <- cb ;
        action#set_visible true ;
        action#set_enabled (cb != None) ;
        Wutil.on icon action#set_icon ;
        Wutil.on tooltip action#set_tooltip ;
      end

    method set_content (w : widget) =
      assert ( details == None ) ;
      let frame = GBin.frame ~show:false () in
      let padds = GBin.alignment ~padding:(4,4,4,4) () in
      padds#add w#coerce ;
      frame#add padds#coerce ;
      details <- Some frame

  end

(* -------------------------------------------------------------------------- *)
(* --- Panel                                                              --- *)
(* -------------------------------------------------------------------------- *)

class panel () =
  let box = GPack.vbox ~show:true () in
  object(self)
    inherit Wutil.gobj_widget box

    val mutable lock = false
    val mutable tools = []

    method add_widget (w : GObj.widget) =
      box#pack ~expand:false w

    method add_tool (w : tool) =
      begin
        self#add_widget w#coerce ;
        w#on_active (self#active w) ;
        tools <- w :: tools ;
      end

    method private active w a =
      if a && not lock then
        try
          lock <- true ;
          List.iter (fun w0 -> if w0 <> w then w0#set_active false) tools ;
          lock <- false ;
        with e ->
          lock <- false ; raise e

  end