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 prompt2 "")
  32 (define input-port (current-input-port))
  33 (define output-port (current-output-port))
  34 (define read-hook #f)
  35
  36 (define (make-readline-port)
  37   (let ((read-string "")
  38         (string-index -1))
  39     (letrec ((get-character
  40               (lambda ()
  41                 (cond
  42                  ((eof-object? read-string)
  43                   read-string)
  44                  ((>= string-index (string-length read-string))
  45                   (begin
  46                     (set! string-index -1)
  47                     #\nl))
  48                  ((= string-index -1)
  49                   (begin
  50                     (set! read-string
  51                           (%readline (if (string? prompt)
  52                                          prompt
  53                                          (prompt))
  54                                      input-port
  55                                      output-port
  56                                      read-hook))
  57                     (set! string-index 0)
  58                     (if (not (eof-object? read-string))
  59                         (begin
  60                           (or (string=? read-string "")
  61                               (begin
  62                                 (add-history read-string)
  63                                 (set! prompt prompt2)))
  64                           (get-character))
  65                         read-string)))
  66                  (else
  67                   (let ((res (string-ref read-string string-index)))
  68                     (set! string-index (+ 1 string-index))
  69                     res))))))
  70       (make-soft-port
  71        (vector write-char display #f get-character #f)
  72        "rw"))))
  73
  74 ;;; We only create one readline port.  There's no point in having
  75 ;;; more, since they would all share the tty and history ---
  76 ;;; everything except the prompt.  And don't forget the
  77 ;;; compile/load/run phase distinctions.  Also, the readline library
  78 ;;; isn't reentrant.
  79 (define the-readline-port #f)
  80
  81 (define history-variable "GUILE_HISTORY")
  82 (define history-file (string-append (getenv "HOME") "/.guile_history"))
  83
  84 (define-public readline-port
  85   (let ((do (lambda (r/w)
  86               (if (memq 'history-file (readline-options-interface))
  87                   (r/w (or (getenv history-variable)
  88                            history-file))))))
  89     (lambda ()
  90       (if (not the-readline-port)
  91           (begin
  92             (do read-history)
  93             (set! the-readline-port (make-readline-port))
  94             (add-hook! exit-hook (lambda () (do write-history)))))
  95       the-readline-port)))
  96
  97 ;;; The user might try to use readline in his programs.  It then
  98 ;;; becomes very uncomfortable that the current-input-port is the
  99 ;;; readline port...
 100 ;;;
 101 ;;; Here, we detect this situation and replace it with the
 102 ;;; underlying port.
 103 ;;;
 104 ;;; %readline is the orginal readline procedure.
 105 (if (not (defined? '%readline))
 106     (begin
 107       (define-public %readline readline)
 108       (variable-set! (builtin-variable 'readline)
 109                      (lambda args
 110                        (let ((prompt prompt)
 111                              (inp input-port))
 112                          (cond ((not (null? args))
 113                                 (set! prompt (car args))
 114                                 (set! args (cdr args))
 115                                 (cond ((not (null? args))
 116                                        (set! inp (car args))
 117                                        (set! args (cdr args))))))
 118                          (apply %readline
 119                                 prompt
 120                                 (if (eq? inp the-readline-port)
 121                                     input-port
 122                                     inp)
 123                                 args))))))
 124
 125 (define-public (set-readline-prompt! p . rest)
 126   (set! prompt p)
 127   (if (not (null? rest))
 128       (set! prompt2 (car rest))))
 129
 130 (define-public (set-readline-input-port! p)
 131   (set! input-port p))
 132
 133 (define-public (set-readline-output-port! p)
 134   (set! output-port p))
 135
 136 (define-public (set-readline-read-hook! h)
 137   (set! read-hook h))
 138
 139 (define-public apropos-completion-function
 140   (let ((completions '()))
 141     (lambda (text cont?)
 142       (if (not cont?)
 143           (set! completions
 144                 (map symbol->string
 145                      (apropos-internal (string-append "^"
 146                                                       (regexp-quote text))))))
 147       (if (null? completions)
 148           #f
 149           (let ((retval (car completions)))
 150             (begin (set! completions (cdr completions))
 151                    retval))))))
 152
 153 (set! *readline-completion-function* apropos-completion-function)