Source file `wbox.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
(**************************************************************************)
(*                                                                        *)
(*  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

type expand = W | H | V | HV

let hdir = function W | V -> false | H | HV -> true
let vdir = function W | H -> false | V | HV -> true

type box =
  | Void
  | ToEnd
  | Pack of expand * int * widget

let box ?(expand=W) ?(padding=0) ?widget () =
  match widget with
  | None -> Void
  | Some w -> Pack(expand,padding,(w :> widget))
let g ?(expand=W) ?(padding=0) g = Pack(expand,padding,new Wutil.gobj_widget g)
let w ?(expand=W) ?(padding=0) a = Pack(expand,padding,(a :> widget))
let h ?(padding=0) a = Pack(H,padding,(a :> widget))
let v ?(padding=0) a = Pack(V,padding,(a :> widget))
let hv ?(padding=0) a = Pack(HV,padding,(a :> widget))

let label ?(fill=false) ?style ?align ?padding text =
  w ~expand:(if fill then H else W) ?padding
    (new Widget.label ~text ?align ?style ())

let rec populate dir (box : #GPack.box) from = function
  | [] -> ()
  | Pack(e,padding,w)::ws ->
    box#pack ~from ~expand:(dir e) ~padding w#coerce ;
    populate dir box from ws
  | Void::ws ->
    populate dir box from ws
  | ToEnd::ws ->
    if from = `START then
      populate dir box `END (List.rev ws)
    else
      populate dir box from ws

let hbox ws =
  let box = GPack.hbox ~show:true () in
  populate hdir box `START ws ;
  new Wutil.gobj_widget box

let vbox ws =
  let box = GPack.vbox ~show:true () in
  populate vdir box `START ws ;
  new Wutil.gobj_widget box

let hgroup (ws : widget list) =
  let box = GPack.hbox ~show:true ~homogeneous:true () in
  List.iter (fun w -> box#pack ~expand:false w#coerce) ws ;
  new Wutil.gobj_widget box

let vgroup (ws : widget list) =
  let box = GPack.vbox ~show:true ~homogeneous:true () in
  List.iter (fun w -> box#pack ~expand:false w#coerce) ws ;
  new Wutil.gobj_widget box

let (<|>) xs ys = if ys = [] then xs else (xs @ (ToEnd::ys))

let toolbar xs ys = hbox (xs <|> ys)
let sidebar xs ys = vbox (xs <|> ys)

let panel ?top ?left ?right ?bottom center =
  let middle =
    match left , right with
    | None , None -> (center :> widget)
    | Some a , Some b -> hbox [ v a ; hv ~padding:2 center ; v b ]
    | None , Some b -> hbox [ hv ~padding:2 center ; v b ]
    | Some a , None -> hbox [ v a ; hv ~padding:2 center ]
  in match top , bottom with
  | None , None -> middle
  | Some t , None -> vbox [ h t ; hv middle ]
  | None , Some t -> vbox [ hv middle ; w t ]
  | Some a , Some b -> vbox [ h a ; hv middle ; h b ]

class type splitter =
  object
    inherit Wutil.widget
    method get : float
    method set : float -> unit
    method connect : (float -> unit) -> unit
  end

let split ~dir w1 w2 =
  let pane = GPack.paned dir () in
  pane#add1 w1#coerce ;
  pane#add2 w2#coerce ;
  let splitter =
    object
      inherit (Wutil.gobj_widget pane)
      method get = Wutil.get_pane_ratio pane
      method set = Wutil.set_pane_ratio pane
      method connect f =
        let callback _ = f (Wutil.get_pane_ratio pane) ; false in
        ignore (pane#event#connect#button_release ~callback)
    end
  in (splitter :> splitter)

let scroll ?(hpolicy=`AUTOMATIC) ?(vpolicy=`AUTOMATIC) w =
  (* Explicit conversion needed for lablgtk3, as policy_type has been extended
     with another constructor but we still export the lablgtk2 type. *)
  let vpolicy = (vpolicy :> Gtk.Tags.policy_type) in
  let hpolicy = (hpolicy :> Gtk.Tags.policy_type) in
  let scrolled = GBin.scrolled_window ~vpolicy ~hpolicy () in
  scrolled#add_with_viewport w#coerce ;
  new Wutil.gobj_widget scrolled

let hscroll w = scroll ~vpolicy:`NEVER w
let vscroll w = scroll ~hpolicy:`NEVER w