[bpt/guile.git] / guile-readline / ice-9 / readline.scm

;;;; readline.scm --- support functions for command-line editing
;;;;
;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011,
;;;;   2013, 2014 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; 
;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
;;;; Extensions based upon code by
;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.

\f

(define-module (ice-9 readline)
  #:use-module (ice-9 session)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 buffered-input)
  #:no-backtrace
  #:export (filename-completion-function
	    add-history
	    read-history
	    write-history
	    clear-history))

\f

;;; Dynamically link the glue code for accessing the readline library,
;;; but only when it isn't already present.

(if (not (provided? 'readline))
    (load-extension "guile-readline" "scm_init_readline"))

(if (not (provided? 'readline))
    (scm-error 'misc-error
	       #f
	       "readline is not provided in this Guile installation"
	       '()
	       '()))

\f

;;; Run-time options

(export
 readline-options
 readline-enable
 readline-disable)
(export-syntax
 readline-set!)

(define-option-interface
  (readline-options-interface
   (readline-options readline-enable readline-disable)
   (readline-set!)))

\f

;;; MDJ 980513 <djurfeldt@nada.kth.se>:
;;; There should probably be low-level support instead of this code.

;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed,
;;; guile will enter an endless loop or crash.

(define-once new-input-prompt "")
(define-once continuation-prompt "")
(define-once input-port (current-input-port))
(define-once output-port (current-output-port))
(define-once read-hook #f)

(define (make-readline-port)
  (let ((history-buffer #f))
    (make-line-buffered-input-port (lambda (continuation?)
                                     ;; When starting a new read, add
                                     ;; the previously read expression
                                     ;; to the history.
                                     (if (and (not continuation?)
                                              history-buffer)
                                         (begin
                                           (add-history history-buffer)
                                           (set! history-buffer #f)))
                                     ;; Set up prompts and read a line.
                                     (let* ((prompt (if continuation?
                                                        continuation-prompt
                                                        new-input-prompt))
                                            (str (%readline (if (string? prompt)
                                                                prompt
                                                                (prompt))
                                                            input-port
                                                            output-port
                                                            read-hook)))
                                       (or (eof-object? str)
                                           (string=? str "")
                                           (set! history-buffer
                                                 (if history-buffer
                                                     (string-append history-buffer
                                                                    "\n"
                                                                    str)
                                                     str)))
                                       str)))))

;;; We only create one readline port.  There's no point in having
;;; more, since they would all share the tty and history ---
;;; everything except the prompt.  And don't forget the
;;; compile/load/run phase distinctions.  Also, the readline library
;;; isn't reentrant.
(define-once the-readline-port #f)

(define-once history-variable "GUILE_HISTORY")
(define-once history-file (string-append (getenv "HOME") "/.guile_history"))

(define-public readline-port
  (let ((do (lambda (r/w)
	      (if (memq 'history-file (readline-options-interface))
		  (r/w (or (getenv history-variable)
			   history-file))))))
    (lambda ()
      (if (not the-readline-port)
	  (begin
	    (do read-history) 
	    (set! the-readline-port (make-readline-port))
	    (add-hook! exit-hook (lambda () 
				   (do write-history)
				   (clear-history)))))
      the-readline-port)))

;;; The user might try to use readline in his programs.  It then
;;; becomes very uncomfortable that the current-input-port is the
;;; readline port...
;;;
;;; Here, we detect this situation and replace it with the
;;; underlying port.
;;;
;;; %readline is the low-level readline procedure.

(define-public (readline . args)
  (let ((prompt new-input-prompt)
	(inp input-port))
    (cond ((not (null? args))
	   (set! prompt (car args))
	   (set! args (cdr args))
	   (cond ((not (null? args))
		  (set! inp (car args))
		  (set! args (cdr args))))))
    (apply %readline
	   prompt
	   (if (eq? inp the-readline-port)
	       input-port
	       inp)
	   args)))

(define-public (set-readline-prompt! p . rest)
  (set! new-input-prompt p)
  (if (not (null? rest))
      (set! continuation-prompt (car rest))))

(define-public (set-readline-input-port! p)
  (cond ((or (not (file-port? p)) (not (input-port? p)))
	 (scm-error 'wrong-type-arg "set-readline-input-port!"
		    "Not a file input port: ~S" (list p) #f))
	((port-closed? p)
	 (scm-error 'misc-error "set-readline-input-port!"
		    "Port not open: ~S" (list p) #f))
	(else
	 (set! input-port p))))

(define-public (set-readline-output-port! p)
  (cond ((or (not (file-port? p)) (not (output-port? p)))
	 (scm-error 'wrong-type-arg "set-readline-input-port!"
		    "Not a file output port: ~S" (list p) #f))
	((port-closed? p)
	 (scm-error 'misc-error "set-readline-output-port!"
		    "Port not open: ~S" (list p) #f))
	(else
	 (set! output-port p))))

(define-public (set-readline-read-hook! h)
  (set! read-hook h))

(define-public apropos-completion-function
  (let ((completions '()))
    (lambda (text cont?)
      (if (not cont?)
          (set! completions
                (map symbol->string
                     (apropos-internal
                      (string-append "^" (regexp-quote text))))))
      (if (null? completions)
          #f
          (let ((retval (car completions)))
            (begin (set! completions (cdr completions))
                   retval))))))

(if (provided? 'regex)
    (set! *readline-completion-function* apropos-completion-function))

(define-public (with-readline-completion-function completer thunk)
  "With @var{completer} as readline completion function, call @var{thunk}."
  (let ((old-completer *readline-completion-function*))
    (dynamic-wind
	(lambda ()
	  (set! *readline-completion-function* completer))
	thunk
	(lambda ()
	  (set! *readline-completion-function* old-completer)))))

(define-once readline-repl-reader
  (let ((boot-9-repl-reader repl-reader))
    (lambda* (repl-prompt #:optional (reader (fluid-ref current-reader)))
      (let ((port (current-input-port)))
        (if (eq? port (readline-port))
            (let ((outer-new-input-prompt new-input-prompt)
                  (outer-continuation-prompt continuation-prompt)
                  (outer-read-hook read-hook))
              (dynamic-wind
                (lambda ()
                  (set-buffered-input-continuation?! port #f)
                  (set-readline-prompt! repl-prompt "... ")
                  (set-readline-read-hook! (lambda ()
                                             (run-hook before-read-hook))))
                (lambda () ((or reader read) port))
                (lambda ()
                  (set-readline-prompt! outer-new-input-prompt
                                        outer-continuation-prompt)
                  (set-readline-read-hook! outer-read-hook))))
            (boot-9-repl-reader repl-prompt reader))))))

(define-public (activate-readline)
  (if (isatty? (current-input-port))
      (begin
        (set-current-input-port (readline-port))
        (set! repl-reader readline-repl-reader)
        (set! (using-readline?) #t))))

(define-public (make-completion-function strings)
  "Construct and return a completion function for a list of strings.
The returned function is suitable for passing to
@code{with-readline-completion-function.  The argument @var{strings}
should be a list of strings, where each string is one of the possible
completions."
  (letrec ((strs '())
	   (regexp #f)
	   (completer (lambda (text continue?)
			(if continue?
			    (if (null? strs)
				#f
				(let ((str (car strs)))
				  (set! strs (cdr strs))
				  (if (string-match regexp str)
				      str
				      (completer text #t))))
			    (begin
			      (set! strs strings)
			      (set! regexp
				    (string-append "^" (regexp-quote text)))
			      (completer text #t))))))
    completer))
Commit	Line	Data
74c88f53 RB	1	;;;; readline.scm --- support functions for command-line editing
74c88f53 RB	2	;;;;
475772ea MW	3	;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011,
475772ea MW	4	;;;; 2013, 2014 Free Software Foundation, Inc.
74c88f53 RB	5	;;;;
	6	;;;; This program is free software; you can redistribute it and/or modify
	7	;;;; it under the terms of the GNU General Public License as published by
b82a8b48	8	;;;; the Free Software Foundation; either version 3, or (at your option)
74c88f53 RB	9	;;;; any later version.
	10	;;;;
	11	;;;; This program is distributed in the hope that it will be useful,
	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;;; GNU General Public License for more details.
	15	;;;;
	16	;;;; You should have received a copy of the GNU General Public License
	17	;;;; along with this software; see the file COPYING. If not, write to
92205699 MV	18	;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
92205699 MV	19	;;;; Boston, MA 02110-1301 USA
74c88f53 RB	20	;;;;
	21	;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
	22	;;;; Extensions based upon code by
	23	;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
	24
	25	\f
	26
	27	(define-module (ice-9 readline)
f84c500d NJ	28	#:use-module (ice-9 session)
	29	#:use-module (ice-9 regex)
	30	#:use-module (ice-9 buffered-input)
	31	#:no-backtrace
	32	#:export (filename-completion-function
	33	add-history
	34	read-history
	35	write-history
	36	clear-history))
74c88f53 RB	37
	38	\f
	39
	40	;;; Dynamically link the glue code for accessing the readline library,
	41	;;; but only when it isn't already present.
	42
	43	(if (not (provided? 'readline))
545d776e	44	(load-extension "guile-readline" "scm_init_readline"))
74c88f53 RB	45
	46	(if (not (provided? 'readline))
	47	(scm-error 'misc-error
	48	#f
	49	"readline is not provided in this Guile installation"
	50	'()
	51	'()))
	52
	53	\f
	54
	55	;;; Run-time options
	56
	57	(export
	58	readline-options
	59	readline-enable
	60	readline-disable)
	61	(export-syntax
	62	readline-set!)
	63
	64	(define-option-interface
	65	(readline-options-interface
	66	(readline-options readline-enable readline-disable)
	67	(readline-set!)))
	68
	69	\f
	70
	71	;;; MDJ 980513 <djurfeldt@nada.kth.se>:
	72	;;; There should probably be low-level support instead of this code.
	73
	74	;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed,
	75	;;; guile will enter an endless loop or crash.
	76
15b06ca9 AW	77	(define-once new-input-prompt "")
	78	(define-once continuation-prompt "")
	79	(define-once input-port (current-input-port))
	80	(define-once output-port (current-output-port))
	81	(define-once read-hook #f)
74c88f53 RB	82
74c88f53 RB	83	(define (make-readline-port)
8b755a75 NJ	84	(let ((history-buffer #f))
	85	(make-line-buffered-input-port (lambda (continuation?)
	86	;; When starting a new read, add
	87	;; the previously read expression
	88	;; to the history.
	89	(if (and (not continuation?)
	90	history-buffer)
	91	(begin
	92	(add-history history-buffer)
	93	(set! history-buffer #f)))
	94	;; Set up prompts and read a line.
	95	(let* ((prompt (if continuation?
	96	continuation-prompt
	97	new-input-prompt))
	98	(str (%readline (if (string? prompt)
	99	prompt
	100	(prompt))
	101	input-port
	102	output-port
	103	read-hook)))
	104	(or (eof-object? str)
	105	(string=? str "")
	106	(set! history-buffer
	107	(if history-buffer
	108	(string-append history-buffer
b27ad2f3	109	"\n"
8b755a75 NJ	110	str)
	111	str)))
	112	str)))))
74c88f53 RB	113
	114	;;; We only create one readline port. There's no point in having
	115	;;; more, since they would all share the tty and history ---
	116	;;; everything except the prompt. And don't forget the
	117	;;; compile/load/run phase distinctions. Also, the readline library
	118	;;; isn't reentrant.
15b06ca9	119	(define-once the-readline-port #f)
74c88f53	120
15b06ca9 AW	121	(define-once history-variable "GUILE_HISTORY")
15b06ca9 AW	122	(define-once history-file (string-append (getenv "HOME") "/.guile_history"))
74c88f53 RB	123
	124	(define-public readline-port
	125	(let ((do (lambda (r/w)
	126	(if (memq 'history-file (readline-options-interface))
	127	(r/w (or (getenv history-variable)
	128	history-file))))))
	129	(lambda ()
	130	(if (not the-readline-port)
	131	(begin
	132	(do read-history)
	133	(set! the-readline-port (make-readline-port))
	134	(add-hook! exit-hook (lambda ()
	135	(do write-history)
	136	(clear-history)))))
	137	the-readline-port)))
	138
	139	;;; The user might try to use readline in his programs. It then
	140	;;; becomes very uncomfortable that the current-input-port is the
	141	;;; readline port...
	142	;;;
	143	;;; Here, we detect this situation and replace it with the
	144	;;; underlying port.
	145	;;;
	146	;;; %readline is the low-level readline procedure.
	147
	148	(define-public (readline . args)
3bff1789	149	(let ((prompt new-input-prompt)
74c88f53 RB	150	(inp input-port))
	151	(cond ((not (null? args))
	152	(set! prompt (car args))
	153	(set! args (cdr args))
	154	(cond ((not (null? args))
	155	(set! inp (car args))
	156	(set! args (cdr args))))))
	157	(apply %readline
	158	prompt
	159	(if (eq? inp the-readline-port)
	160	input-port
	161	inp)
	162	args)))
	163
	164	(define-public (set-readline-prompt! p . rest)
3bff1789	165	(set! new-input-prompt p)
74c88f53	166	(if (not (null? rest))
3bff1789	167	(set! continuation-prompt (car rest))))
74c88f53 RB	168
	169	(define-public (set-readline-input-port! p)
	170	(cond ((or (not (file-port? p)) (not (input-port? p)))
	171	(scm-error 'wrong-type-arg "set-readline-input-port!"
	172	"Not a file input port: ~S" (list p) #f))
	173	((port-closed? p)
	174	(scm-error 'misc-error "set-readline-input-port!"
	175	"Port not open: ~S" (list p) #f))
	176	(else
	177	(set! input-port p))))
	178
	179	(define-public (set-readline-output-port! p)
	180	(cond ((or (not (file-port? p)) (not (output-port? p)))
	181	(scm-error 'wrong-type-arg "set-readline-input-port!"
	182	"Not a file output port: ~S" (list p) #f))
	183	((port-closed? p)
	184	(scm-error 'misc-error "set-readline-output-port!"
	185	"Port not open: ~S" (list p) #f))
	186	(else
	187	(set! output-port p))))
	188
	189	(define-public (set-readline-read-hook! h)
	190	(set! read-hook h))
	191
64e5d08d AW	192	(define-public apropos-completion-function
	193	(let ((completions '()))
	194	(lambda (text cont?)
	195	(if (not cont?)
	196	(set! completions
	197	(map symbol->string
	198	(apropos-internal
	199	(string-append "^" (regexp-quote text))))))
	200	(if (null? completions)
	201	#f
	202	(let ((retval (car completions)))
	203	(begin (set! completions (cdr completions))
	204	retval))))))
	205
74c88f53	206	(if (provided? 'regex)
64e5d08d	207	(set! readline-completion-function apropos-completion-function))
74c88f53 RB	208
	209	(define-public (with-readline-completion-function completer thunk)
	210	"With @var{completer} as readline completion function, call @var{thunk}."
	211	(let ((old-completer readline-completion-function))
	212	(dynamic-wind
	213	(lambda ()
	214	(set! readline-completion-function completer))
	215	thunk
	216	(lambda ()
	217	(set! readline-completion-function old-completer)))))
	218
15b06ca9	219	(define-once readline-repl-reader
1924145d AW	220	(let ((boot-9-repl-reader repl-reader))
	221	(lambda* (repl-prompt #:optional (reader (fluid-ref current-reader)))
	222	(let ((port (current-input-port)))
	223	(if (eq? port (readline-port))
	224	(let ((outer-new-input-prompt new-input-prompt)
	225	(outer-continuation-prompt continuation-prompt)
	226	(outer-read-hook read-hook))
	227	(dynamic-wind
	228	(lambda ()
	229	(set-buffered-input-continuation?! port #f)
	230	(set-readline-prompt! repl-prompt "... ")
	231	(set-readline-read-hook! (lambda ()
	232	(run-hook before-read-hook))))
	233	(lambda () ((or reader read) port))
	234	(lambda ()
	235	(set-readline-prompt! outer-new-input-prompt
	236	outer-continuation-prompt)
	237	(set-readline-read-hook! outer-read-hook))))
	238	(boot-9-repl-reader repl-prompt reader))))))
	239
74c88f53	240	(define-public (activate-readline)
adb825b6	241	(if (isatty? (current-input-port))
1924145d AW	242	(begin
	243	(set-current-input-port (readline-port))
	244	(set! repl-reader readline-repl-reader)
	245	(set! (using-readline?) #t))))
1b09b607 KR	246
	247	(define-public (make-completion-function strings)
	248	"Construct and return a completion function for a list of strings.
	249	The returned function is suitable for passing to
	250	@code{with-readline-completion-function. The argument @var{strings}
	251	should be a list of strings, where each string is one of the possible
	252	completions."
	253	(letrec ((strs '())
	254	(regexp #f)
	255	(completer (lambda (text continue?)
	256	(if continue?
	257	(if (null? strs)
	258	#f
	259	(let ((str (car strs)))
	260	(set! strs (cdr strs))
	261	(if (string-match regexp str)
	262	str
	263	(completer text #t))))
	264	(begin
	265	(set! strs strings)
	266	(set! regexp
	267	(string-append "^" (regexp-quote text)))
	268	(completer text #t))))))
	269	completer))