ice-9/readline.scm

   1 ;;;; readline.scm --- support functions for command-line editing
   2 ;;;;
   3 ;;;;    Copyright (C) 1997 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18 ;;;;
  19 ;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
  20 ;;;; Extensions based upon code by
  21 ;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
  22
  23 (define-module (ice-9 readline)
  24   :use-module (ice-9 session)
  25   :use-module (ice-9 regex))
  26
  27 ;;; MDJ 980513 <djurfeldt@nada.kth.se>:
  28 ;;; There should probably be low-level support instead of this code.
  29
  30 (define prompt "")
  31 (define input-port (current-input-port))
  32 (define output-port (current-output-port))
  33 (define read-hook #f)
  34
  35 (define (make-readline-port)
  36   (let ((read-string "")
  37         (string-index -1))
  38     (letrec ((get-character
  39               (lambda ()
  40                 (cond
  41                  ((eof-object? read-string)
  42                   read-string)
  43                  ((>= string-index (string-length read-string))
  44                   (begin
  45                     (set! string-index -1)
  46                     #\nl))
  47                  ((= string-index -1)
  48                   (begin
  49                     (set! read-string
  50                           (%readline (if (string? prompt)
  51                                          prompt
  52                                          (prompt))
  53                                      input-port
  54                                      output-port
  55                                      read-hook))
  56                     (set! string-index 0)
  57                     (if (not (eof-object? read-string))
  58                         (begin
  59                           (or (string=? read-string "")
  60                               (begin
  61                                 (add-history read-string)
  62                                 (set! prompt "... ")))
  63                           (get-character))
  64                         read-string)))
  65                  (else
  66                   (let ((res (string-ref read-string string-index)))
  67                     (set! string-index (+ 1 string-index))
  68                     res))))))
  69       (make-soft-port
  70        (vector write-char display #f get-character #f)
  71        "rw"))))
  72
  73 ;;; We only create one readline port.  There's no point in having
  74 ;;; more, since they would all share the tty and history ---
  75 ;;; everything except the prompt.  And don't forget the
  76 ;;; compile/load/run phase distinctions.  Also, the readline library
  77 ;;; isn't reentrant.
  78 (define the-readline-port #f)
  79
  80 (define history-variable "GUILE_HISTORY")
  81 (define history-file (string-append (getenv "HOME") "/.guile_history"))
  82
  83 (define-public readline-port
  84   (let ((do (lambda (r/w)
  85               (if (memq 'history-file (readline-options-interface))
  86                   (r/w (or (getenv history-variable)
  87                            history-file))))))
  88     (lambda ()
  89       (if (not the-readline-port)
  90           (begin
  91             (do read-history)
  92             (set! the-readline-port (make-readline-port))
  93             (add-hook! exit-hook (lambda () (do write-history)))))
  94       the-readline-port)))
  95
  96 ;;; The user might try to use readline in his programs.  It then
  97 ;;; becomes very uncomfortable that the current-input-port is the
  98 ;;; readline port...
  99 ;;;
 100 ;;; Here, we detect this situation and replace it with the
 101 ;;; underlying port.
 102 ;;;
 103 ;;; %readline is the orginal readline procedure.
 104 (if (not (defined? '%readline))
 105     (begin
 106       (define-public %readline readline)
 107       (variable-set! (builtin-variable 'readline)
 108                      (lambda args
 109                        (let ((prompt prompt)
 110                              (inp input-port))
 111                          (cond ((not (null? args))
 112                                 (set! prompt (car args))
 113                                 (set! args (cdr args))
 114                                 (cond ((not (null? args))
 115                                        (set! inp (car args))
 116                                        (set! args (cdr args))))))
 117                          (apply %readline
 118                                 prompt
 119                                 (if (eq? inp the-readline-port)
 120                                     input-port
 121                                     inp)
 122                                 args))))))
 123
 124 (define-public (set-readline-prompt! p)
 125   (set! prompt p))
 126
 127 (define-public (set-readline-input-port! p)
 128   (set! input-port p))
 129
 130 (define-public (set-readline-output-port! p)
 131   (set! output-port p))
 132
 133 (define-public (set-readline-read-hook! h)
 134   (set! read-hook h))
 135
 136 (define-public apropos-completion-function
 137   (let ((completions '()))
 138     (lambda (text cont?)
 139       (if (not cont?)
 140           (set! completions
 141                 (map symbol->string
 142                      (apropos-internal (string-append "^"
 143                                                       (regexp-quote text))))))
 144       (if (null? completions)
 145           #f
 146           (let ((retval (car completions)))
 147             (begin (set! completions (cdr completions))
 148                    retval))))))
 149
 150 (set! *readline-completion-function* apropos-completion-function)