guile-examples/input-output/user-input-output.scm

(library (user-input-output)
  (export read-line
          write-string
          remove-whitespace-chars
          ask-user
          ask-user-for-text
          ask-user-for-character
          ask-user-for-number
          ask-user-for-integer-number
          ask-user-for-yes-no-decision
          ask-user-for-decision
          ask-user-for-decision-with-continuations
          confirm-info-message
          string-format)
  (import
    (except (rnrs base) let-values map error)
    (only (guile)
          ;; lambda forms
          lambda* λ
          ;; conditionals
          when
          ;; input output
          simple-format
          current-output-port
          call-with-output-string
          current-input-port
          ;; strings
          string-trim
          string-join
          string-append
          string-delete
          ;; other
          error)
    (ice-9 textual-ports)
    (ice-9 optargs)
    ;; srfi-1 for list procedures
    (srfi srfi-1)))


(define read-line
  (lambda* (#:optional (input-port (current-input-port)))
    (get-line input-port)))


(define write-string
  (lambda* (string #:optional (output-port (current-output-port)))
    (put-string output-port string)))


(define (remove-whitespace-chars string)
  (string-delete (lambda (char)
                   (memq char '(#\newline #\tab #\return #\space)))
                 string))


(define trim-whitespace-chars
  (λ (string)
    "Trim whitespace characters from the left and right end
of the given string."
    (string-trim string
                 (lambda (char)
                   (memq char '(#\newline #\tab #\return #\space))))))


(define* (ask-user question pred
                   #:key
                   (input-cleanup-proc trim-whitespace-chars)
                   (possible-answers #f)
                   (q-a-separator ": ")
                   (choices-opener "(")
                   (choices-separator "/")
                   (choices-closer ")")
                   (question-to-choices-separator " ")
                   (invalid-input-message "Invalid input.\n"))
  "Ask a question clean the input of its answer using the
given INPUT-CLEANUP-PROC and check the cleaned answer using
the given predicate PRED. Either provide POSSIBLE-ANSWERS or
leave it at its default #f."

  (define ask-question
    (λ ()
      (write-string question)
      (when possible-answers
        (write-string (string-append question-to-choices-separator
                                     choices-opener
                                     (string-join possible-answers choices-separator)
                                     choices-closer))
        (write-string ""))
      (write-string q-a-separator)
      (read-line)))

  (let try-again ([input (ask-question)])
    (let ([cleaned-input (input-cleanup-proc input)])
      (cond
       ;; ... and check whether it satisfies the predicate
       [(pred cleaned-input)
        ;; if possible-answers are specified check,
        ;; whether the answer is a member of the
        ;; possible-answers
        (cond [possible-answers
               (cond [(member cleaned-input possible-answers) cleaned-input]
                     ;; if the answer is not valid ...
                     [else
                      ;; ... output the invalid input
                      ;; message ...
                      (write-string invalid-input-message)
                      ;; ... and ask the question again
                      (try-again (ask-question))])]
              [else cleaned-input])]
       [else (write-string invalid-input-message)
             (try-again (ask-question))]))))


(define ask-user-for-decision-with-continuations
  (λ (question choices choice-texts continuations)

    (define build-question-text
      (λ (question choices choice-texts)
        (call-with-output-string
          (λ (string-port)
            (simple-format string-port "~a\n" question)
            (let next-choice ([rest-choices choices] [rest-choice-texts choice-texts])
              (cond
               [(null? rest-choices)
                (simple-format string-port "")]
               [else
                (simple-format string-port "~a: ~a\n" (first rest-choices) (first rest-choice-texts))
                (next-choice (cdr rest-choices)
                             (cdr rest-choice-texts))]))))))

    (let ([choi (ask-user (build-question-text question choices choice-texts)
                          (λ (input)
                            (member input choices))
                          #:possible-answers choices
                          #:question-to-choices-separator "")])

      (let next ([rest-choices choices] [rest-continuations continuations])
        (cond
         [(null? rest-choices)
          (error "one of the choices should have been equal" choi choices)]
         [(string=? choi (first rest-choices))
          ((first rest-continuations))]
         [else
          (next (cdr rest-choices)
                (cdr rest-continuations))])))))


(define ask-user-for-text
  (λ (question)
    (ask-user question (λ (input) #t))))


(define ask-user-for-character
  (lambda* (question
            char-pred
            #:key
            (invalid-input-message "Invalid input. Enter a character.\n"))
    (ask-user question
              (λ (input)
                (and (= (string-length input) 1)
                     (char-pred (car (string->list input)))))
              #:invalid-input-message invalid-input-message)))


(define ask-user-for-number
  (λ (question number-pred)
    "Ask the user for a input, which must be a number and
secondly must satisfy the given number predicate."
    (string->number
     (ask-user question
               (lambda (input)
                 (and (string->number input)
                      (number-pred (string->number input))))))))


(define ask-user-for-integer-number
  (λ (question number-pred)
    (ask-user-for-number question (λ (num) (and (number-pred num)
                                                (integer? num))))))


(define ask-user-for-yes-no-decision
  (λ (question positive-answers negative-answers)
    (let ([user-input
           (ask-user question
                     (λ (input)
                       (member input
                               (lset-union string=? positive-answers negative-answers)))
                     #:possible-answers (reverse (lset-union string=?
                                                             positive-answers
                                                             negative-answers)))])
      (member user-input positive-answers))))


(define ask-user-for-decision
  (λ (question decisions)
    (ask-user question
              (λ (input)
                (member input decisions))
              #:possible-answers decisions)))


(define confirm-info-message
  (λ (msg)
    (simple-format (current-output-port) "~a" msg)
    (read-line)))


(define string-format
  (λ (format-string . args)
    (call-with-output-string
      (λ (string-port)
        (apply simple-format
               (cons string-port (cons format-string args)))))))