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

(* -------------------------------------------------------------------------- *)
(* ---  File Chooser                                                      --- *)
(* -------------------------------------------------------------------------- *)

type filekind = [ `FILE | `DIR ]

class dialog
    ?(kind=`FILE)
    ?(title="Select File")
    ?(select="Select")
    ?parent () =
  let dialog = GWindow.dialog ~title ?parent ~modal:true () in
  let packing = dialog#vbox#pack ~expand:true in
  let action = match kind with `FILE -> `SAVE | `DIR -> `CREATE_FOLDER in
  let chooser = GFile.chooser_widget ~action ~packing () in
  object

    inherit [string] Wutil.signal as signal

    initializer
      begin
        ignore (dialog#event#connect#delete ~callback:(fun _ -> true)) ;
        dialog#add_button "Cancel" `DELETE_EVENT ;
        dialog#add_button select `SELECT ;
        ignore (GMisc.label ~packing:(dialog#action_area#pack ~expand:true) ()) ;
      end

    method add_filter ~descr ~patterns =
      if kind = `FILE then
        chooser#add_filter (GFile.filter ~name:descr ~patterns ())

    method select ?dir ?file () =
      begin
        match dir , file with
        | None , None -> ignore (chooser#set_filename "")
        | None , Some path -> ignore (chooser#set_filename path)
        | Some dir , None ->
          ignore (chooser#set_current_folder dir) ;
          ignore (chooser#set_current_name "")
        | Some dir , Some file ->
          ignore (chooser#set_current_folder dir) ;
          ignore (chooser#set_current_name file)
      end ;
      let result = dialog#run () in
      dialog#misc#hide () ;
      match result with
      | `DELETE_EVENT -> ()
      | `SELECT ->
        match chooser#get_filenames with | f::_ -> signal#fire f | _ -> ()

  end

class button ?kind ?title ?select ?tooltip ?parent () =
  let box = GPack.hbox ~homogeneous:false ~spacing:0 ~border_width:0 () in
  let fld = GMisc.label ~text:"(none)" ~xalign:0.0
      ~packing:(box#pack ~expand:true) () in
  let _ = GMisc.separator `VERTICAL
      ~packing:(box#pack ~expand:false ~padding:2) ~show:true ()
  in
  let _ = GMisc.image  ~packing:(box#pack ~expand:false) ~stock:`OPEN () in
  let button = GButton.button () in
  let dialog = new dialog ?kind ?title ?select ?parent () in
  object(self)

    inherit Wutil.gobj_widget button
    inherit! [string] Wutil.selector "" as current

    val mutable disptip = fun f ->
      match tooltip , f with
      | None , "" -> "(none)"
      | None , _ -> f
      | Some d , "" -> d
      | Some d , f -> Printf.sprintf "%s: %s" d f

    val mutable display = function
      | "" -> "(none)"
      | path -> Filename.basename path

    initializer
      begin
        button#add box#coerce ;
        button#set_focus_on_click false ;
        ignore (button#connect#clicked ~callback:self#select) ;
        dialog#connect current#set ;
        Wutil.set_tooltip button tooltip ;
        current#connect
          (fun f ->
             button#misc#set_tooltip_text (disptip f) ;
             fld#set_text (display f)) ;
      end

    method set_tooltip p = disptip <- p ; fld#misc#set_tooltip_text (p current#get)
    method set_display p = display <- p ; fld#set_text (p current#get)
    method add_filter = dialog#add_filter

    method select ?dir ?file () =
      let file = match file with None -> current#get | Some f -> f in
      dialog#select ?dir ~file ()

  end