| 1 | ;;;; gtk-dialog.jl |
|---|
| 2 | |
|---|
| 3 | (require 'gui.gtk-2.gtk) |
|---|
| 4 | |
|---|
| 5 | ;; Each BUTTON is (TEXT . RETURNED-VALUE) |
|---|
| 6 | (defun gtk-dialog (message &rest buttons) |
|---|
| 7 | (let |
|---|
| 8 | ((window (gtk-window-new 'toplevel)) |
|---|
| 9 | (vbox (gtk-vbox-new nil 0)) |
|---|
| 10 | (label (gtk-label-new message)) |
|---|
| 11 | (bbox (gtk-hbutton-box-new))) |
|---|
| 12 | (catch 'exit |
|---|
| 13 | (unwind-protect |
|---|
| 14 | (progn |
|---|
| 15 | (gtk-container-border-width window 6) |
|---|
| 16 | (gtk-signal-connect window "delete_event" |
|---|
| 17 | (lambda () |
|---|
| 18 | (throw 'exit nil))) |
|---|
| 19 | (gtk-container-add window vbox) |
|---|
| 20 | (gtk-box-pack-start vbox label) |
|---|
| 21 | (gtk-box-pack-end vbox bbox) |
|---|
| 22 | (mapc (lambda (cell) |
|---|
| 23 | (let |
|---|
| 24 | ((button (gtk-button-new-with-label (car cell)))) |
|---|
| 25 | (GTK-WIDGET-SET-FLAGS button '(can-default)) |
|---|
| 26 | (gtk-box-pack-start bbox button nil nil) |
|---|
| 27 | (gtk-signal-connect button "clicked" |
|---|
| 28 | (lambda () |
|---|
| 29 | (throw 'exit (cdr cell)))))) |
|---|
| 30 | buttons) |
|---|
| 31 | (gtk-widget-show-all window) |
|---|
| 32 | (gtk-main)) |
|---|
| 33 | (gtk-widget-destroy window) |
|---|
| 34 | ;; If I don't do this, the window isn't unmapped.. |
|---|
| 35 | (while (> (gtk-events-pending) 0) |
|---|
| 36 | (gtk-main-iteration)))))) |
|---|
| 37 | |
|---|
| 38 | (defun yes-or-no-p (question) |
|---|
| 39 | (gtk-dialog question '("Yes" . t) '("No" . nil))) |
|---|
| 40 | |
|---|
| 41 | (defun y-or-n-p (q) |
|---|
| 42 | (yes-or-no-p q)) |
|---|
| 43 | |
|---|
| 44 | (defun map-y-or-n-p (question inputs callback) |
|---|
| 45 | (let |
|---|
| 46 | ((all-t t)) |
|---|
| 47 | (when (eq 'all-t (catch 'map |
|---|
| 48 | (while inputs |
|---|
| 49 | (let* |
|---|
| 50 | ((q (if (stringp question) |
|---|
| 51 | (format nil question (car inputs)) |
|---|
| 52 | (question (car inputs)))) |
|---|
| 53 | (a (gtk-dialog q |
|---|
| 54 | '("Yes" . t) '("No" . nil) |
|---|
| 55 | '("Yes to all" . all-t) |
|---|
| 56 | '("Quit" . quit)))) |
|---|
| 57 | (cond ((or (eq a 'all-t) (eq a 'quit)) |
|---|
| 58 | (throw 'map a)) |
|---|
| 59 | (a |
|---|
| 60 | (callback (car inputs))) |
|---|
| 61 | (t |
|---|
| 62 | (setq all-t nil))) |
|---|
| 63 | (setq inputs (cdr inputs)))))) |
|---|
| 64 | ;; User answered with "!", so loop over all remaining inputs |
|---|
| 65 | (while inputs |
|---|
| 66 | (callback (car inputs)) |
|---|
| 67 | (setq inputs (cdr inputs)))) |
|---|
| 68 | all-t)) |
|---|
