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 (width #f) (height #f))
  (let ((args (if (null? args)
                  '()
                  (append (list (car args))
                          (if width (list (string-append "--width=" (number->string width))) (list))
                          (if height (list (string-append "--height=" (number->string height))) (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 (width #f) (height #f))
  (let-values (((ret text) (zenity args #:width width #:height height)))
    (cond ((= ret 0) (thunk text))
          ((= ret 256) #f)
          (else (error "unexpected return code in zenity")))))

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

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

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

;; 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 title
                                #:key (multiple #f)
                                (directory #f)
                                (save #f)
                                (filename #f)
                                (width #f) (height #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"
                                            (string-append "--title=" title)
                                            args)
                                     #:width width #:height height)))
      (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 title text layout #:key (width #f) (height #f))
  (zenity/check (cons* "--forms"
                        ;; must not use , in anything you enter
                       "--separator=,"
                       "--forms-date-format=%d/%m/%Y"
                       (string-append "--title=" title)
                       (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)))))))
                #:width width #:height height))

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

(define* (zenity-list message columns rows #:key (width #f) (height #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)))))
                  #:width width #:height height)))

(define* (zenity-checklist message columns rows #:key (width #f) (height #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) #\|))
                  #:width width #:height height)))

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

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

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

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

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

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

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

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

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

(define* (zenity-pulsate message #:key (auto-close #f)
                         (no-cancel #f)
                         (width #f) (height #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)))
                                 #:width width #:height height)))
    (lambda () (close-pipe pipe))))

(define* (zenity-progress message #:key (value #f)
                          (auto-close #f)
                          (no-cancel #f)
                          (width #f) (height #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)))
                                 #:width width #:height height)))
    (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)
                       (width #f) (height #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)))))

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

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

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