guile-readline/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, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
  21 ;;;; Extensions based upon code by
  22 ;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
  23
  24 (define-module (ice-9 readline)
  25   :use-module (ice-9 session)
  26   :use-module (ice-9 regex))
  27
  28 ;;; Dynamically link the glue code for accessing the readline library
  29
  30 (dynamic-call "scm_init_readline" (dynamic-link "libguilereadline.so"))
  31
  32 ;;; MDJ 980513 <djurfeldt@nada.kth.se>:
  33 ;;; There should probably be low-level support instead of this code.
  34
  35 (define prompt "")
  36 (define prompt2 "")
  37 (define input-port (current-input-port))
  38 (define output-port (current-output-port))
  39 (define read-hook #f)
  40
  41 (define (make-readline-port)
  42   (let ((read-string "")
  43         (string-index -1))
  44     (letrec ((get-character
  45               (lambda ()
  46                 (cond
  47                  ((eof-object? read-string)
  48                   read-string)
  49                  ((>= string-index (string-length read-string))
  50                   (begin
  51                     (set! string-index -1)
  52                     #\nl))
  53                  ((= string-index -1)
  54                   (begin
  55                     (set! read-string
  56                           (%readline (if (string? prompt)
  57                                          prompt
  58                                          (prompt))
  59                                      input-port
  60                                      output-port
  61                                      read-hook))
  62                     (set! string-index 0)
  63                     (if (not (eof-object? read-string))
  64                         (begin
  65                           (or (string=? read-string "")
  66                               (begin
  67                                 (add-history read-string)
  68                                 (set! prompt prompt2)))
  69                           (get-character))
  70                         read-string)))
  71                  (else
  72                   (let ((res (string-ref read-string string-index)))
  73                     (set! string-index (+ 1 string-index))
  74                     res))))))
  75       (make-soft-port
  76        (vector write-char display #f get-character #f)
  77        "rw"))))
  78
  79 ;;; We only create one readline port.  There's no point in having
  80 ;;; more, since they would all share the tty and history ---
  81 ;;; everything except the prompt.  And don't forget the
  82 ;;; compile/load/run phase distinctions.  Also, the readline library
  83 ;;; isn't reentrant.
  84 (define the-readline-port #f)
  85
  86 (define history-variable "GUILE_HISTORY")
  87 (define history-file (string-append (getenv "HOME") "/.guile_history"))
  88
  89 (define-public readline-port
  90   (let ((do (lambda (r/w)
  91               (if (memq 'history-file (readline-options-interface))
  92                   (r/w (or (getenv history-variable)
  93                            history-file))))))
  94     (lambda ()
  95       (if (not the-readline-port)
  96           (begin
  97             (do read-history)
  98             (set! the-readline-port (make-readline-port))
  99             (add-hook! exit-hook (lambda () (do write-history)))))
 100       the-readline-port)))
 101
 102 ;;; The user might try to use readline in his programs.  It then
 103 ;;; becomes very uncomfortable that the current-input-port is the
 104 ;;; readline port...
 105 ;;;
 106 ;;; Here, we detect this situation and replace it with the
 107 ;;; underlying port.
 108 ;;;
 109 ;;; %readline is the low-level readline procedure.
 110
 111 (define-public (readline . args)
 112   (let ((prompt prompt)
 113         (inp input-port))
 114     (cond ((not (null? args))
 115            (set! prompt (car args))
 116            (set! args (cdr args))
 117            (cond ((not (null? args))
 118                   (set! inp (car args))
 119                   (set! args (cdr args))))))
 120     (apply %readline
 121            prompt
 122            (if (eq? inp the-readline-port)
 123                input-port
 124                inp)
 125            args)))
 126
 127 (define-public (set-readline-prompt! p . rest)
 128   (set! prompt p)
 129   (if (not (null? rest))
 130       (set! prompt2 (car rest))))
 131
 132 (define-public (set-readline-input-port! p)
 133   (set! input-port p))
 134
 135 (define-public (set-readline-output-port! p)
 136   (set! output-port p))
 137
 138 (define-public (set-readline-read-hook! h)
 139   (set! read-hook h))
 140
 141 (define-public apropos-completion-function
 142   (let ((completions '()))
 143     (lambda (text cont?)
 144       (if (not cont?)
 145           (set! completions
 146                 (map symbol->string
 147                      (apropos-internal (string-append "^"
 148                                                       (regexp-quote text))))))
 149       (if (null? completions)
 150           #f
 151           (let ((retval (car completions)))
 152             (begin (set! completions (cdr completions))
 153                    retval))))))
 154
 155 (set! *readline-completion-function* apropos-completion-function)
 156
 157 (define-public (activate-readline)
 158   (if (and (isatty? (current-input-port))
 159            (not (and (module-defined? the-root-module
 160                                       'use-emacs-interface)
 161                      use-emacs-interface)))
 162       (let ((read-hook (lambda () (run-hook before-read-hook))))
 163         (set-current-input-port (readline-port))
 164         (set! repl-reader
 165               (lambda (prompt)
 166                 (dynamic-wind
 167                     (lambda ()
 168                       (set-readline-prompt! prompt "... ")
 169                       (set-readline-read-hook! read-hook))
 170                     (lambda () (read))
 171                     (lambda ()
 172                       (set-readline-prompt! "" "")
 173                       (set-readline-read-hook! #f))))))))