guile-zenity/zenity.scm

;;; guile-zenity --- Scheme wrapper for Zenity
;;; Copyright © 2016 Raymond Nicholson <rain1@openmailbox.org>
;;; Copyright © 2016 Fabian Harfert <fhmgufs@opmbx.org>
;;;
;;; guile-zenity is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; guile-zenity 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guile-zenity.  If not, see <http://www.gnu.org/licenses/>.

(define-module (zenity)
  #:export (zenity-calendar
            zenity-color-selection
            zenity-file-selection
            zenity-forms
            zenity-list zenity-checklist
            zenity-error zenity-info zenity-question zenity-warning
            zenity-password
            zenity-pulsate zenity-progress
            zenity-scale
            zenity-entry)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-14))

;; https://help.gnome.org/users/zenity/stable/

;; Utility functions

(define (drain-input port)
  (let ((ch (read-char port)))
    (if (eof-object? ch)
        '()
        (cons ch (drain-input port)))))

(define (chomp text)
  (string-trim-right text (char-set #\newline)))

(define (boolean->zenity-boolean b)
  (if b
      "TRUE"
      "FALSE"))

(define (->string thing)
  (cond ((string? thing) thing)
        ((symbol? thing) (symbol->string thing))
        ((number? thing) (number->string thing))
        ((boolean? thing) (boolean->zenity-boolean thing))
        (else (error "unsupported type in ->string"))))

(define (parse-date text)
  (let ((dmy (string-split (chomp text) #\/)))
    (list (cons 'day (string->number (car dmy)))
          (cons 'month (string->number (cadr dmy)))
          (cons 'year (string->number (caddr dmy))))))

;;

(define* (zenity args #:key (title #f)
                      (icon #f)
                      (width #f)
                      (height #f)
                      (timeout #f))
  (let ((args (if (null? args)
                  '()
                  (append (list (car args))
                          (if title (list (string-append "--title=" title)) (list))
                          (if icon (list (string-append "--window-icon=" icon)) (list))
                          (if width (list (string-append "--width=" (number->string width))) (list))
                          (if height (list (string-append "--height=" (number->string height))) (list))
                          (if timeout (list (string-append "--timeout=" (number->string timeout))) (list))
                          (cdr args)))))
    (let* ((pipe (apply open-pipe* OPEN_READ "zenity" args))
           (text (list->string (drain-input pipe)))
           (ret (close-pipe pipe)))
      (values ret text))))

(define* (zenity/check args thunk #:key (title #f)
                                  (icon #f)
                                  (width #f)
                                  (height #f)
                                  (timeout #f))
  (let-values (((ret text) (zenity args #:title title #:icon icon #:width width
                                   #:height height #:timeout timeout)))
    (cond ((= ret 0) (thunk text))
          ((= ret 256) #f)
          (else (error "unexpected return code in zenity")))))

(define* (zenity-input-pipe args #:key (title #f)
                                 (icon #f)
                                 (width #f)
                                 (height #f)
                                 (timeout #f))
  (apply open-pipe* OPEN_WRITE "zenity"
         (if (null? args)
             '()
             (append (list (car args))
                     (if title (list (string-append "--title=" title)) (list))
                     (if icon (list (string-append "--window-icon=" icon)) (list))
                     (if width (list (string-append "--width=" (number->string width))) (list))
                     (if height (list (string-append "--height=" (number->string height))) (list))
                     (if timeout (list (string-append "--timeout=" (number->string timeout))) (list))
                     (cdr args)))))

;; Calendar Dialog — Use the --calendar option.

(define* (zenity-calendar message #:key (title #f)
                                  (icon #f)
                                  (width #f)
                                  (height #f)
                                  (timeout #f))
  (zenity/check (list "--calendar" "--date-format=%d/%m/%Y" (string-append "--text=" message))
                parse-date
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

;; Color Selection Dialog — Use the --color-selection option.

(define* (zenity-color-selection #:key (color #f) (show-palette #f))
  (zenity/check (append
                 (list "--color-selection")
                 (if color (list (string-append "--color=" color)) (list))
                 (if show-palette (list "--show-palette") (list)))
                chomp))

;; File Selection Dialog — Use the --file-selection option.

(define* (zenity-file-selection #:key (multiple #f)
                                (directory #f)
                                (save #f)
                                (filename #f)
                                (title #f)
                                (icon #f)
                                (width #f)
                                (height #f)
                                (timeout #f))
  (let ((args (append
               (if multiple (list "--multiple") (list))
               (if directory (list "--directory") (list))
               (if save (list "--save") (list))
               (if filename (list (string-append "--filename=" filename)) (list)))))
    (let-values (((ret text) (zenity (cons* "--file-selection" args)
                                     #:title title
                                     #:icon icon
                                     #:width width
                                     #:height height
                                     #:timeout timeout)))
      (if (= ret 256)
          #f
          (if multiple
              ;; I hope you don't have files with | in the name.
              (string-split (chomp text) #\|)
              (chomp text))))))

;; Forms Dialog — Use the --forms option.

(define* (zenity-forms text layout #:key (icon #f)
                                   (title #f)
                                   (width #f)
                                   (height #f)
                                   (timeout #f))
  (zenity/check (cons* "--forms"
                        ;; must not use , in anything you enter
                       "--separator=,"
                       "--forms-date-format=%d/%m/%Y"
                       (string-append "--text=" text)
                       (map (lambda (layout-entry)
                              (string-append
                               (case (car layout-entry)
                                 ((entry) "--add-entry=")
                                 ((password) "--add-password=")
                                 ((calendar) "--add-calendar="))
                               (cdr layout-entry)))
                            layout))
                (lambda (text)
                  (let loop ((layout layout)
                             (data (string-split (chomp text) #\,)))
                    (cond ((and (null? layout) (null? data)) '())
                          ((or (null? layout) (null? data))
                           (error "wrong number of form data fields in zenity"))
                          (else (cons (case (caar layout)
                                        ((entry password) (car data))
                                        ((calendar) (parse-date (car data))))
                                      (loop (cdr layout)
                                            (cdr data)))))))
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

;; List Dialog — Use the --list option.

(define* (zenity-list message columns rows #:key (title #f)
                                           (icon #f)
                                           (width #f)
                                           (height #f)
                                           (timeout #f))
  ;; TODO: Emit a warning if two columns are keyed by the same name
  (let ((columns^ (map (lambda (col) (string-append "--column=" col)) columns))
        (rows^ (apply append (map (lambda (row) (map ->string row)) rows))))
    (zenity/check (cons "--list" (append columns^ rows^))
                  (lambda (text)
                    (assoc (chomp text) rows (lambda (k c) (string=? k (->string c)))))
                  #:title title
                  #:icon icon
                  #:width width
                  #:height height
                  #:timeout timeout)))

(define* (zenity-checklist message columns rows #:key (title #f)
                                                (icon #f)
                                                (width #f)
                                                (height #f)
                                                (timeout #f))
  (let ((columns^ (map (lambda (col) (string-append "--column=" col)) columns))
        (rows^ (apply append (map (lambda (row) (map ->string row)) rows))))
    (zenity/check (append (list "--list" "--checklist") (append columns^ rows^))
                  (lambda (text)
                    (string-split (chomp text) #\|))
                  #:title title
                  #:icon icon
                  #:width width
                  #:height height
                  #:timeout timeout)))

;; Message Dialog — Error, Info, Question, Warning

(define* (zenity-error message #:key (title #f)
                               (icon #f)
                               (width #f)
                               (height #f)
                               (timeout #f))
  (zenity (list "--error" (string-append "--text=" message))
          #:title title
          #:icon icon
          #:width width
          #:height height
          #:timeout timeout)
  #t)

(define* (zenity-info message #:key (title #f)
                              (icon #f)
                              (width #f)
                              (height #f)
                              (timeout #f))
  (zenity (list "--info" (string-append "--text=" message))
          #:title title
          #:icon icon
          #:width width
          #:height height
          #:timeout timeout)
  #t)

(define* (zenity-question message #:key (title #f)
                                  (icon #f)
                                  (width #f)
                                  (height #f)
                                  (timeout #f))
  (zenity/check (list "--question" (string-append "--text=" message))
                (lambda (_) #t)
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

(define* (zenity-warning message #:key (title #f)
                                 (icon #f)
                                 (width #f)
                                 (height #f)
                                 (timeout #f))
  (zenity (list "--warning" (string-append "--text=" message))
          #:title title
          #:icon icon
          #:width width
          #:height height
          #:timeout timeout)
  #t)

;; Notification Icon — Use the --notification option.

;; Password Dialog — Use the --password option.

(define* (zenity-password message #:key (title #f)
                                  (icon #f)
                                  (width #f)
                                  (height #f)
                                  (timeout #f))
  (zenity/check (list "--password" message (string-append "--text=" message))
                chomp
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

;; Progress Dialog — Use the --progress option.

(define* (zenity-pulsate message #:key (auto-close #f)
                         (no-cancel #f)
                         (title #f)
                         (icon #f)
                         (width #f)
                         (height #f)
                         (timeout #f))
  (let ((pipe (zenity-input-pipe (append
                                  (list "--progress" "--pulsate" (string-append "--text=" message))
                                  (if auto-close (list "--auto-close") (list))
                                  (if no-cancel (list "--no-cancel") (list)))
                                 #:title title
                                 #:icon icon
                                 #:width width
                                 #:height height
                                 #:timeout timeout)))
    (lambda () (close-pipe pipe))))

(define* (zenity-progress message #:key (value #f)
                          (auto-close #f)
                          (no-cancel #f)
                          (title #f)
                          (icon #f)
                          (width #f)
                          (height #f)
                          (timeout #f))
  (let ((pipe (zenity-input-pipe (append
                                  (list "--progress" (string-append "--text=" message))
                                  (if value
                                      (list (string-append "--percentage=" (number->string value)))
                                      (list))
                                  (if auto-close (list "--auto-close") (list))
                                  (if no-cancel (list "--no-cancel") (list)))
                                 #:title title
                                 #:icon icon
                                 #:width width
                                 #:height height
                                 #:timeout timeout)))
    (let ((done #f))
      (lambda (message)
        (unless done
          (if message
              (begin
                (display message pipe)
                (newline pipe)
                (when (>= message 100)
                  (set! done #t)))
              (begin
                (close-pipe pipe)
                (set! done #t))))))))

;; Scale Dialog — Use the --scale option.

(define* (zenity-scale message
                       #:key (value #f)
                       (minimum #f)
                       (maximum #f)
                       (step #f)
                       (hide-value #f)
                       (title #f)
                       (icon #f)
                       (width #f)
                       (height #f)
                       (timeout #f))
  (zenity/check (append
                 (list "--scale" (string-append "--text=" message))
                 (if value (list (string-append "--value=" (->string value)))
                     (if minimum
                      (list (string-append "--value=" (->string minimum)))
                      (list)))
                 (if minimum (list (string-append "--min-value="
                                     (->string minimum)))
                     (list))
                 (if maximum (list (string-append "--max-value="
                                     (->string maximum)))
                     (list))
                 (if step (list (string-append "--step=" (->string step)))
                     (list))
                 (if hide-value (list "--hide-value") (list)))
                (lambda (text) (string->number (chomp text)))
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

;; Text Entry Dialog — Use the --entry option.

(define* (zenity-entry message #:key (title #f)
                               (icon #f)
                               (width #f)
                               (height #f)
                               (timeout #f))
  (zenity/check (list "--entry" message (string-append "--text=" message))
                chomp
                #:title title
                #:icon icon
                #:width width
                #:height height
                #:timeout timeout))

;; Text Information Dialog — Use the --text-info option.