source: project/release/4/readline/readline.scm @ 14325

Last change on this file since 14325 was 14325, checked in by felix winkelmann, 11 years ago

ported to chicken 4, version is 1.98

File size: 14.3 KB
Line 
1;;; Add-in module to support using GNU readline from Chicken.
2;
3; (Readline is GPLed, so that makes this file GPLed too, because this
4; file will only run if it's linked against readline.)
5;
6; Copyright (c) 2002 Tony Garnock-Jones
7; Copyright (c) 2006 Heath Johns (paren bouncing and auto-completion code)
8;
9; This program is free software; you can redistribute it and/or modify
10; it under the terms of the GNU General Public License as published by
11; the Free Software Foundation; either version 2 of the License, or
12; (at your option) any later version.
13;
14; This program is distributed in the hope that it will be useful,
15; but WITHOUT ANY WARRANTY; without even the implied warranty of
16; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17; GNU General Public License for more details.
18;
19; You should have received a copy of the GNU General Public License
20; along with this program; if not, write to the Free Software
21; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
22
23;---------------------------------------------------------------------------
24; csc -s readline.scm -L -lreadline -L -ltermcap
25;
26; To get csi to support line editing, install this library and put the
27; following lines in your ~/.csirc:
28;
29;   (require 'readline)
30;   (current-input-port (make-gnu-readline-port "csi> "))
31;
32; If you also want to make the command history span sessions, add the
33; following:
34;
35;   (gnu-history-install-file-manager (string-append (or (getenv "HOME") ".") "/.csi.history"))
36;
37; By default this will save 1000 lines of history between sessions (it
38; will prune the history file to 1000 lines at startup). For a
39; different history size, pass the desired number of lines as the
40; (optional) second argument to gnu-history-install-file-manager. If
41; #f is passed in, no history-file-pruning will take place.
42;
43;
44; Esoteric Options
45; -----------------
46;
47; To change the bouncing parenthesis time (default is 500ms):
48;
49; (gnu-readline-set-bounce-ms 1000)
50;
51; To turn it off completely:
52;
53; (gnu-readline-set-bounce-ms 0)
54;
55;
56; To pass configuration options to readline (see the readline manual page for
57; details):
58;
59; (gnu-readline-parse-and-bind "set editing-mode vi")
60;
61;
62; To change the "still waiting for input" prompt, just pass it as a second
63; argument to make-readline-port:
64;
65; (current-input-port (make-gnu-readline-port "csi> " ".... "))
66;
67;
68; The neato line numbered display that's the csi default doesn't work, but
69; here's how to write a replacement:
70;
71;(repl-prompt
72;  (let ((history-count -1))
73;       (lambda ()
74;         (set! history-count (+ 1 history-count))
75;         (sprintf "#;~A> " hist))))
76
77#|
78
79TODO:
80- C-w terminal thingy
81- tab completion with procedure info
82
83|#
84
85
86(declare
87 (usual-integrations))
88
89; hack around missing export from `chicken' in 4.0.1:
90
91(define ##readline#repl-prompt repl-prompt)
92
93(module readline
94 
95    (gnu-readline
96     make-gnu-readline-port
97     %gnu-readline-signal-cleanup
98     gnu-readline-clear-history
99     gnu-readline-read-history
100     gnu-readline-write-history
101     gnu-readline-append-history
102     gnu-readline-truncate-history
103     gnu-history-new-lines
104     gnu-history-install-file-manager
105 
106     gnu-readline-parse-and-bind
107     gnu-readline-set-bounce-ms
108 
109     gnu-readline-completions)
110
111  (import scheme chicken foreign ports data-structures)
112
113 (use posix)
114
115 ; gnu-readline
116 ; make-gnu-readline-port
117 ; %gnu-readline-signal-cleanup
118 ;
119 ; gnu-readline-clear-history
120 ; gnu-readline-read-history
121 ; gnu-readline-write-history
122 ; gnu-readline-append-history
123 ; gnu-readline-truncate-history
124 ; gnu-history-new-lines
125 ; gnu-history-install-file-manager
126 ;
127 ; gnu-readline-parse-and-bind
128 ; gnu-readline-set-bounce-ms
129 ;
130 ; gnu-readline-completions
131 ; )
132
133
134#>
135 #include "readline-egg.c"
136<#
137
138
139;; Initialise (note the extra set of parens)
140((foreign-lambda void "gnu_readline_init"))
141
142
143;; Various C funcs
144
145(define gnu-readline
146  (foreign-safe-lambda c-string "gnu_readline_readline" c-string c-string))
147
148(define %gnu-readline-signal-cleanup
149    (foreign-lambda void "gnu_readline_signal_cleanup"))
150
151(define gnu-readline-clear-history
152  (foreign-lambda void "clear_history"))
153
154;;; (gnu-readline-read-history <filename-or-false>) -> 0 for success, errno for failure
155(define gnu-readline-read-history
156  (foreign-lambda int "read_history" c-string))
157
158;;; (gnu-readline-write-history <filename-or-false>) -> 0 for success, errno for failure
159(define gnu-readline-write-history
160  (foreign-lambda int "write_history" c-string))
161
162(define gnu-readline-append-history
163    (foreign-lambda int "gnu_readline_append_history" c-string))
164
165;;; (gnu-readline-truncate-history <filename-or-false> <numlines>) -> 0 succ, errno fail
166(define gnu-readline-truncate-history
167  (foreign-lambda int "history_truncate_file" c-string int))
168
169(define gnu-history-new-lines
170    (foreign-lambda int "gnu_history_new_lines"))
171
172;; Useful...
173(define gnu-readline-parse-and-bind
174  (foreign-lambda int "rl_parse_and_bind" c-string))
175
176;; Set the amount of time the cursor spends bouncing
177(define gnu-readline-set-bounce-ms
178  (foreign-lambda* void ((int time))
179        "gnu_readline_bounce_ms = time;"))
180
181;; get access to the quoting flag
182(define-foreign-variable is-quoted? int "rl_completion_quote_character")
183(define-foreign-variable filename-completion int "rl_filename_completion_desired")
184
185;; Handler for the command history file
186(define (gnu-history-install-file-manager filename . nlines)
187  (define (hook param)
188    (param (let ((next (param)))
189             (lambda args
190               ;(gnu-readline-write-history filename)
191               (gnu-readline-append-history filename)
192               (apply next args)))))
193  (if (pair? nlines)
194      (set! nlines (car nlines))
195      (set! nlines 1000))
196  (if nlines
197      (gnu-readline-truncate-history filename nlines))
198  (gnu-readline-read-history filename)
199  (hook exit-handler)
200  (hook implicit-exit-handler))
201
202
203;; Prompt2 is displayed when there are still open parens, this just makes a reasonable one
204(define (make-prompt2 prompt)
205  (let ((len (string-length prompt)))
206        (case len
207          ((0) "")
208          ((1) ">")
209          ((2) "> ")
210          (else (conc (make-string (- len 2) #\-) "> ")))))
211
212
213;; Creates a port that reads using readline
214(define (make-gnu-readline-port #!optional prompt prompt2)
215    (let ((buffer   "")
216          (pos      0)
217          (p1       prompt)
218          (p2       prompt2)
219          (handle   #f))
220        (letrec ((char-ready?
221                    (lambda ()
222                        (< pos (string-length buffer))))
223                 (get-next-char!
224                    (lambda ()
225                        (cond ((not buffer)
226                                  #!eof)
227                              ((char-ready?)
228                                  (let ((ch   (string-ref buffer pos)))
229                                      (set! pos (+ 1 pos))
230                                      ch))
231                              (else
232                                  (set! pos 0)
233                                  (set! buffer
234                                        (let* ((prompt    (or prompt
235                                                              ((##readline#repl-prompt))))
236                                               (prompt2   (make-prompt2
237                                                              prompt)))
238                                            (gnu-readline prompt prompt2)))
239                                  (if (string? buffer)
240                                      (set! buffer (string-append buffer "\n")))
241                                  (get-next-char!))))))
242            (set! handle (lambda (s)
243                             (print-call-chain)
244                             (set! pos 0)
245                             (set! buffer "")
246                             ((foreign-lambda void
247                                  "gnu_readline_signal_cleanup"))
248                             (##sys#user-interrupt-hook)))
249            (set-signal-handler! signal/int handle)
250            (let ((p   (make-input-port
251                           get-next-char!
252                           char-ready?
253                           (lambda ()
254                               (set-signal-handler! signal/int #f)
255                               'closed-gnu-readline-port))))
256                (set-port-name! p "(gnu-readline)")
257                p))))
258
259
260;;;;;;;; Tab Completion ;;;;;;;;
261
262
263;; Borrowed from the oblist egg
264(define find-symbol-table (foreign-lambda c-pointer "C_find_symbol_table" c-string))
265(define enum-symbols! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object))
266
267;; Globally defined enumeration state (callbacks can't be closures)
268(define enum-funcs '())
269
270;; Creates a list of closures that enumerate anything the user would want to type
271(define (create-symbol-ef word)
272        (let ((global-symbol-index (cons -1 '()))
273                  (global-symbol-pointer (find-symbol-table ".")))
274          (lambda ()
275                (let loop ()
276                  (let ((symb (enum-symbols! global-symbol-pointer 
277                                                                         global-symbol-index)))
278                        (cond ((not symb)
279                                   "")
280                                  ((not (##sys#symbol-has-toplevel-binding? symb))
281                                   (loop))
282                                  (else
283                                        (let ((str (##sys#symbol->qualified-string symb)))
284                                          ;; Possibly undo the mangling of keywords
285                                          (if (not (substring=? "###" str))
286                                                str
287                                                (string-append (substring str 3) ":"))))))))))
288                                               
289;; R5RS keywords (including some special forms not included in above)
290(define (create-static-ef word)
291        (let ((index -1)
292                  (v-len (vector-length static-keywords)))
293          (lambda ()
294                (set! index (+ 1 index))
295                (if (not (>= index v-len))
296                  (vector-ref static-keywords index)
297                  ""))))
298                 
299;; Macros (thanks to Kon Lovett for suggesting ##sys#macro-environment)
300(define (create-macro-ef word)
301        (let ((index -1))
302          (lambda ()
303                (let loop ()
304                  (set! index (+ 1 index))
305                  (cond ((>= index (vector-length ##sys#macro-environment)) 
306                                 "")
307                                (else
308                                  (let ((ref (vector-ref ##sys#macro-environment index)))
309                                        (if (null? ref)
310                                          (loop)
311                                          (symbol->string (caar ref))))))))))
312
313;; handling filename completion
314(define (turn-on-filenames)
315  (set! filename-completion 1))
316 
317(define (create-file-ef word)
318  (turn-on-filenames)
319  (let ((files (glob (string-append word "*"))))
320    (lambda ()
321      (if (null? files) ""
322        (let ((current (car files)))
323          (set! files (cdr files))
324          current)))))
325         
326(define gnu-readline-completions 
327  (make-parameter 
328    (list
329      (cons 'macros create-macro-ef)
330      (cons 'statics create-static-ef) 
331      (cons 'symbols create-symbol-ef))))
332
333(define gnu-readline-quoted-completions
334  (make-parameter
335    (list
336      (cons 'files create-file-ef))))
337     
338;; This is the completion function called by readline
339;; It's called repeatedly until it returns an empty string
340;; (lambda'd to stop the compiler complaining about unused global var)
341((lambda ()
342   (define-external (gnu_readline_scm_complete (c-string word) (int len) (int state)) scheme-object
343         ;; If state is zero, init enumeration funcs.  Don't try to complete an empty string...
344         ;(print is-quoted?)
345         (when (zero? state)
346           (if (not (zero? len))
347                 (set! enum-funcs (choose-completion-procs word))
348                 ""))
349         ;; Call the enumeration funcs, discarding the ones that are done
350         (let loop ()
351           (if (null? enum-funcs)
352                 ""
353                 (let ((result ((car enum-funcs))))
354                   (cond ((equal? result "")
355                                  (set! enum-funcs (cdr enum-funcs))
356                                  (loop))
357                                 ((substring=? word result 0 0 len)
358                                  result) ;; Return only ones that are a substring of the word typed
359                                 (else (loop)))))))))
360
361;; This function simply chooses which completion type is appropriate
362;; and then gets those procedures ready.
363(define (choose-completion-procs word)
364  (map
365    (lambda (pair) ((cdr pair) word)) 
366    (if (= 34 is-quoted?)
367      (gnu-readline-quoted-completions)
368      (gnu-readline-completions))))
369
370;; Things that will always be there...
371(define static-keywords (vector
372                                                ; R5RS
373                                                "abs" "acos" "and" "angle" "append" "apply" "asin" 
374                                                "assoc" "assq" "assv" "atan" "begin" "boolean?" 
375                                                "caar" "cadr" "call-with-current-continuation" 
376                                                "call-with-input-file" "call-with-output-file" 
377                                                "call-with-values" "car" "case" "cdddar" "cddddr" 
378                                                "cdr" "ceiling" "char->integer" "char-alphabetic?" 
379                                                "char-ci<=?" "char-ci<?" "char-ci=?" "char-ci>=?" 
380                                                "char-ci>?" "char-downcase" "char-lower-case?" 
381                                                "char-numeric?" "char-ready?" "char-upcase" 
382                                                "char-upper-case?" "char-whitespace?" "char<=?" 
383                                                "char<?" "char=?" "char>=?" "char>?" "char?" 
384                                                "close-input-port" "close-output-port" "complex?" 
385                                                "cond" "cons" "cos" "current-input-port" 
386                                                "current-output-port" "define" "define-syntax" 
387                                                "delay" "denominator" "display" "do" "dynamic-wind" 
388                                                "else" "eof-object?" "eq?" "equal?" "eqv?" "eval" 
389                                                "even?" "exact->inexact" "exact?" "exp" "expt" 
390                                                "floor" "for-each" "force" "gcd" "if" "imag-part" 
391                                                "inexact->exact" "inexact?" "input-port?" 
392                                                "integer->char" "integer?" "interaction-environment" 
393                                                "lambda" "lcm" "length" "let" "let*" "let-syntax" 
394                                                "letrec" "letrec-syntax" "list" "list->string" 
395                                                "list->vector" "list-ref" "list-tail" "list?" "load" 
396                                                "log" "magnitude" "make-polar" "make-rectangular" 
397                                                "make-string" "make-vector" "map" "max" "member" 
398                                                "memq" "memv" "min" "modulo" "negative?" "newline" 
399                                                "not" "null-environment" "null?" "number->string" 
400                                                "number?" "numerator" "odd?" "open-input-file" 
401                                                "open-output-file" "or" "output-port?" "pair?" 
402                                                "peek-char" "port?" "positive?" "procedure?" 
403                                                "quasiquote" "quote" "quotient" "rational?" 
404                                                "rationalize" "read" "read-char" "real-part" 
405                                                "real?" "remainder" "reverse" "round" 
406                                                "scheme-report-environment" "set!" "set-car!" 
407                                                "set-cdr!" "setcar" "sin" "sqrt" "string" 
408                                                "string->list" "string->number" "string->symbol" 
409                                                "string-append" "string-ci<=?" "string-ci<?" 
410                                                "string-ci=?" "string-ci>=?" "string-ci>?" 
411                                                "string-copy" "string-fill!" "string-length" 
412                                                "string-ref" "string-set!" "string<=?" "string<?" 
413                                                "string=?" "string>=?" "string>?" "string?" 
414                                                "substring" "symbol->string" "symbol?" 
415                                                "syntax-rules" "tan" "transcript-off" 
416                                                "transcript-on" "truncate" "values" "vector" 
417                                                "vector->list" "vector-fill!" "vector-length" 
418                                                "vector-ref" "vector-set!" "vector?" 
419                                                "with-input-from-file" "with-output-to-file" 
420                                                "write" "write-char" "zero?"
421                                                ; csi commands
422                                                ",?" ",p" ",d" ",du" ",dur" ",q" ",l" ",ln" ",r"
423                                                ",s" ",tr" ",utr" ",t" ",x" 
424                                                ))
425
426
427)
Note: See TracBrowser for help on using the repository browser.