mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
124 lines
4.2 KiB
Scheme
124 lines
4.2 KiB
Scheme
|
|
;; Abstract user interface for the snow command. This could be
|
|
;; substituted with a different implementation to provide a GUI.
|
|
|
|
(define (message . args)
|
|
(for-each display args)
|
|
(newline))
|
|
|
|
(define (info . args)
|
|
(apply message args))
|
|
|
|
(define (warn msg . args)
|
|
(let ((err (current-error-port)))
|
|
(display "WARNING: " err)
|
|
(display msg err)
|
|
(if (pair? args) (display ": " err))
|
|
(if (and (pair? args) (null? (cdr args)))
|
|
(write (car args) err)
|
|
(for-each (lambda (x) (display "\n " err) (write x err)) args))
|
|
(newline err)))
|
|
|
|
(define (die x . args)
|
|
(let ((n (if (number? x) x 2))
|
|
(args (if (number? x) args (cons x args)))
|
|
(err (current-error-port)))
|
|
(for-each (lambda (x) (display x err)) args)
|
|
(newline err)
|
|
(flush-output-port err)
|
|
(exit n)))
|
|
|
|
(define input-history #f)
|
|
|
|
(define (conf-input-history-file cfg)
|
|
(or (conf-get cfg 'input-history)
|
|
(string-append (or (conf-get cfg 'snow-dir)
|
|
(string-append (get-environment-variable "HOME")
|
|
"/.snow"))
|
|
"/input-history.scm")))
|
|
|
|
(define (restore-history cfg)
|
|
(let ((history-file (conf-input-history-file cfg)))
|
|
(set! input-history
|
|
(or (guard (exn (else #f))
|
|
(list->history (call-with-input-file history-file read)))
|
|
(make-history)))))
|
|
|
|
(define (save-history cfg)
|
|
(let ((history-file (conf-input-history-file cfg)))
|
|
(guard (exn (else (warn "couldn't save history to " history-file)))
|
|
(create-directory* (path-directory history-file))
|
|
(call-with-output-file history-file
|
|
(lambda (out)
|
|
(write (remove (lambda (x) (equal? x ""))
|
|
(history->list input-history))
|
|
out))))))
|
|
|
|
(define (input cfg name prompt . o)
|
|
(let ((proc (or (and (pair? o) (car o)) (lambda (x) x)))
|
|
(check (or (and (pair? o) (pair? (cdr o)) (cadr o))
|
|
(lambda (str res lp) res))))
|
|
(let lp ((reason #f))
|
|
(cond
|
|
((and (not reason) (conf-get cfg name))
|
|
=> (lambda (res) (check "" res lp)))
|
|
(else
|
|
(if reason
|
|
(show #t reason fl))
|
|
(let ((str (edit-line 'prompt: (lambda () (show #f prompt))
|
|
'history: input-history)))
|
|
(history-insert! input-history str)
|
|
(check str (proc str) lp)))))))
|
|
|
|
(define (input-password cfg name prompt1 . o)
|
|
(let ((prompt2 (or (and (pair? o) (car o))
|
|
(string-append prompt1 " (confirmation): "))))
|
|
(let lp ()
|
|
(let ((password (edit-line 'hidden?: #t 'prompt: prompt1)))
|
|
(newline)
|
|
(cond
|
|
((equal? password "")
|
|
(show #t "password must be non-empty\n")
|
|
(lp))
|
|
(else
|
|
(let ((conf (edit-line 'hidden?: #t 'prompt: prompt2)))
|
|
(newline)
|
|
(cond
|
|
((not (equal? password conf))
|
|
(show #t "password didn't match\n")
|
|
(lp))
|
|
(else
|
|
password)))))))))
|
|
|
|
(define (input-number cfg name prompt . o)
|
|
(let* ((default (and (pair? o) (car o)))
|
|
(lo (and (pair? o) (pair? (cdr o)) (cadr o)))
|
|
(hi (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o))))
|
|
(prompt
|
|
(if default (each prompt " [default=" default "]: ") prompt))
|
|
(proc (lambda (str)
|
|
(if (and default (equal? str ""))
|
|
default
|
|
(string->number str))))
|
|
(check
|
|
(lambda (str res fail)
|
|
(cond
|
|
((not (number? res))
|
|
(fail "not a valid number"))
|
|
((equal? res default)
|
|
res)
|
|
((and lo (< res lo))
|
|
(fail (each "too low, must be greater than " lo)))
|
|
((and hi (> res hi))
|
|
(fail (each "too high, must be less than " hi)))
|
|
(else
|
|
res)))))
|
|
(input cfg name prompt proc check)))
|
|
|
|
(define (yes-or-no? cfg . prompt)
|
|
(define (is-true? str)
|
|
(and (string? str) (member (string-downcase str) '("#t" "y" "yes")) #t))
|
|
(if (conf-get cfg 'always-no?)
|
|
#f
|
|
(input cfg 'always-yes? (each (each-in-list prompt) " [y/n]: ")
|
|
is-true?)))
|