source: project/readline/readline.scm @ 2179

Last change on this file since 2179 was 2179, checked in by felix winkelmann, 13 years ago

readline update

File size: 16.7 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 (export
90
91  gnu-readline
92  make-gnu-readline-port
93
94  gnu-readline-clear-history
95  gnu-readline-read-history
96  gnu-readline-write-history
97  gnu-readline-truncate-history
98  gnu-history-install-file-manager
99
100  gnu-readline-parse-and-bind
101  gnu-readline-set-bounce-ms
102  ))
103
104
105#>
106#include <stdlib.h>
107#include <string.h>
108#include <stdio.h>
109#include <sys/poll.h>
110#include <readline/readline.h>
111#include <readline/history.h>
112
113static char *gnu_readline_buf = NULL;
114static int gnu_readline_bounce_ms = 500;
115static int gnu_readline_paren_balance = 0;
116static int gnu_readline_brace_balance = 0;
117
118////\\\\//// Paren Bouncing ////\\\\////
119
120/* Returns: (if positive) the position of the matching paren
121            (if negative) the number of unmatched closing parens */
122int gnu_readline_skip(int pos, int open_key, int close_key)
123{
124        while (--pos > -1) {
125                if (pos > 0 && rl_line_buffer[pos - 1] == '\\') {
126                        continue;
127                } else if (rl_line_buffer[pos] == open_key) {
128                        return pos;
129                } else if (rl_line_buffer[pos] == close_key) {
130                        pos = gnu_readline_skip(pos, open_key, close_key);
131                } else if (rl_line_buffer[pos] == '"') {
132                        pos = gnu_readline_skip(pos, '"', '"');
133                }
134        }
135        return pos;
136}
137
138// Return what the balance is between opening and closing keys
139int gnu_readline_match_balance(int open_key, int close_key)
140{
141        int pos;
142        int open = 0;
143
144        // Can't use rl_end intead of strlen: gives length of whole buffer
145        pos = gnu_readline_skip(strlen(rl_line_buffer), open_key, close_key);
146        if (pos < 0)
147                return pos + 1;
148
149        while (pos >= 0) {
150                open++;
151                pos = gnu_readline_skip(pos, open_key, close_key);
152        }
153
154        return open;
155}
156
157// Resets the global vars that track paren balance
158void gnu_readline_clear_balances()
159{
160        gnu_readline_paren_balance = 0;
161        gnu_readline_brace_balance = 0;
162}
163
164
165// Finds the matching paren (starting from just left of the cursor)
166int gnu_readline_find_match(int key)
167{
168        if (key == ')')
169                return gnu_readline_skip(rl_point - 1, '(', ')');
170        else if (key == ']')
171                return gnu_readline_skip(rl_point - 1, '[', ']');
172       
173        return 0;
174}
175
176// Delays, but returns early if key press occurs
177void gnu_readline_timid_delay(ms)
178{
179        struct pollfd pfd;
180       
181        pfd.fd = fileno(rl_instream);
182        pfd.events = POLLIN || POLLPRI;
183        pfd.revents = 0;
184       
185        poll(&pfd, 1, ms);
186}
187
188// Bounces the cursor to the matching paren for a while
189int gnu_readline_paren_bounce(int count, int key)
190{
191        int insert_success;
192        int old_point;
193        int matching;
194
195        if (gnu_readline_bounce_ms == 0)
196                return 0;
197
198        // Write the just entered paren out first
199        insert_success = rl_insert(count, key);
200        if (insert_success != 0)
201                return insert_success;
202        rl_redisplay();
203
204        // Need at least two chars to bounce...
205        if (rl_point < 2) // rl_point set to next char (implicit +1)
206                return 0;
207
208        // If it's an escaped paren, don't bounce...
209        if (rl_line_buffer[rl_point - 2] == '\\')
210                return 0;
211
212        // Bounce
213        old_point = rl_point;
214        matching = gnu_readline_find_match(key);
215        if (matching < 0)
216                return 0;
217        else
218                rl_point = matching;
219        rl_redisplay();
220        gnu_readline_timid_delay(gnu_readline_bounce_ms);
221        rl_point = old_point;
222
223        return 0;
224}
225
226
227////\\\\//// Tab Completion ////\\\\////
228
229// Prototype for callback into scm
230C_word gnu_readline_scm_complete(char *, int, int);
231
232// Gets called (repeatedly) when readline tries to do a completion
233char *gnu_readline_tab_complete(const char *text, int status) {
234        C_word result;
235        char *str;
236        int len;
237        char *copied_str;
238
239        /* All of this is for older versions of chicken (< 2.3), which don't
240           reliably null-terminate strings */
241
242        // Get scheme string for possible completion via callback
243        result = gnu_readline_scm_complete((char *)text, strlen(text), status);
244
245        if (result == C_SCHEME_FALSE)
246                return NULL;
247
248        // Convert into C types
249        str = C_c_string(result);
250        len = C_num_to_int(C_i_string_length(result));
251
252        if (len == 0)
253                return NULL;
254
255        // Copy (note: the readline lib frees this copy)
256        copied_str = (char *)malloc(len + 1);
257        strncpy(copied_str, str, len);
258        copied_str[len] = '\0';
259
260        return copied_str;
261}
262
263
264////\\\\//// Other Stuff ////\\\\////
265
266/*
267// This is code that is supposed to alter the behaviour of ctrl-w so that it recognizes
268// parens as delimiters.  It works, but I can't bind it to ctrl-w, because that key code
269// is intercepted by the terminal (I think).
270
271// Ripped off from readline src
272#define emacs_mode 1
273#define whitespace_ext(c) ( ((c) == ' ') || ((c) == '\t') || ((c) == '(') || ((c) == '[') )
274
275int gnu_readline_lisp_word_rubout(int count, int key)
276{
277        int orig_point;
278
279        if (rl_point == 0) {
280                rl_ding ();
281        } else {
282                orig_point = rl_point;
283                if (count <= 0)
284                        count = 1;
285
286                while (count--) {
287                        while (rl_point && whitespace (rl_line_buffer[rl_point - 1]))
288                                rl_point--;
289
290                        while (rl_point && (whitespace_ext (rl_line_buffer[rl_point - 1]) == 0))
291                                rl_point--;
292                }
293               
294                if (orig_point == rl_point &&
295                        (rl_line_buffer[rl_point - 1] == '(' || rl_line_buffer[rl_point - 1] == '['))
296                        rl_point--;
297
298                rl_kill_text (orig_point, rl_point);
299                if (rl_editing_mode == emacs_mode)
300                        rl_mark = rl_point;
301        }
302
303        return 0;
304}
305*/
306
307
308// Set everything up
309void gnu_readline_init()
310{
311        using_history();
312        rl_bind_key(')', gnu_readline_paren_bounce);
313        rl_bind_key(']', gnu_readline_paren_bounce);
314        rl_completion_entry_function = &gnu_readline_tab_complete;
315        //rl_add_defun ("lisp-word-rubout" , gnu_readline_lisp_word_rubout, -1);
316}
317
318
319// Called from scheme to get user input
320char *gnu_readline_readline(char *prompt, char *prompt2)
321{
322        char *empty_prompt;
323        int prompt_len;
324        HIST_ENTRY *h;
325
326        if (gnu_readline_buf != NULL) {
327                free(gnu_readline_buf);
328                gnu_readline_buf = NULL;
329        }
330
331        if ((gnu_readline_paren_balance || gnu_readline_brace_balance) == 0)
332                gnu_readline_buf = readline(prompt);
333        else
334                gnu_readline_buf = readline(prompt2);
335
336        if (gnu_readline_buf != NULL && *gnu_readline_buf != '\0') {
337                h = history_get(history_base + history_length - 1);
338                if (NULL == h || 0 != strcmp(h->line, gnu_readline_buf)) {
339                        add_history(gnu_readline_buf);
340                }
341        }
342
343        gnu_readline_paren_balance += gnu_readline_match_balance('(', ')');
344        gnu_readline_brace_balance += gnu_readline_match_balance('[', ']');
345        if (gnu_readline_paren_balance < 0 || gnu_readline_brace_balance < 0)
346                gnu_readline_clear_balances();
347
348        return(gnu_readline_buf);
349}
350
351<#
352
353
354;; Initialise (note the extra set of parens)
355((foreign-lambda void "gnu_readline_init"))
356
357
358;; Various C funcs
359
360(define gnu-readline
361  (foreign-safe-lambda c-string "gnu_readline_readline" c-string c-string))
362
363(define gnu-readline-clear-history
364  (foreign-lambda void "clear_history"))
365
366;;; (gnu-readline-read-history <filename-or-false>) -> 0 for success, errno for failure
367(define gnu-readline-read-history
368  (foreign-lambda int "read_history" c-string))
369
370;;; (gnu-readline-write-history <filename-or-false>) -> 0 for success, errno for failure
371(define gnu-readline-write-history
372  (foreign-lambda int "write_history" c-string))
373
374;;; (gnu-readline-truncate-history <filename-or-false> <numlines>) -> 0 succ, errno fail
375(define gnu-readline-truncate-history
376  (foreign-lambda int "history_truncate_file" c-string int))
377
378;; Useful...
379(define gnu-readline-parse-and-bind
380  (foreign-lambda int "rl_parse_and_bind" c-string))
381
382;; Set the amount of time the cursor spends bouncing
383(define gnu-readline-set-bounce-ms
384  (foreign-lambda* void ((int time))
385        "gnu_readline_bounce_ms = time;"))
386
387
388
389;; Handler for the command history file
390(define (gnu-history-install-file-manager filename . nlines)
391  (define (hook param)
392    (param (let ((next (param)))
393             (lambda args
394               (gnu-readline-write-history filename)
395               (apply next args)))))
396  (if (pair? nlines)
397      (set! nlines (car nlines))
398      (set! nlines 1000))
399  (if nlines
400      (gnu-readline-truncate-history filename nlines))
401  (gnu-readline-read-history filename)
402  (hook exit-handler)
403  (hook implicit-exit-handler))
404
405
406;; Prompt2 is displayed when there are still open parens, this just makes a reasonable one
407(define (make-prompt2 prompt)
408  (let ((len (string-length prompt)))
409        (case len
410          ((0) "")
411          ((1) ">")
412          ((2) "> ")
413          (else (conc (make-string (- len 2) #\-) "> ")))))
414
415
416;; Creates a port that reads using readline
417(define (make-gnu-readline-port #!optional prompt prompt2)
418  (let ((buffer "")
419                (pos 0))
420        (letrec ((char-ready? (lambda ()
421                                                        (< pos (string-length buffer))))
422                         (get-next-char! 
423                           (lambda ()
424                                 (cond
425                                   ((not buffer) #!eof)
426                                   ((char-ready?)
427                                        (let ((ch (string-ref buffer pos)))
428                                          (set! pos (+ pos 1))
429                                          ch))
430                                   (else
431                                         (set! pos 0)
432                                         (set! buffer 
433                                           (let* ((prompt (or prompt ((repl-prompt))))
434                                                          (prompt2 (make-prompt2 prompt)))
435                                                 (gnu-readline prompt prompt2)) )
436                                         (if (string? buffer)
437                                           (set! buffer (string-append buffer "\n")))
438                                         (get-next-char!))))))
439          (let ((p (make-input-port get-next-char! char-ready?
440                                                                (lambda () 'closed-gnu-readline-port))))
441                (set-port-name! p "(gnu-readline)")
442                p))))
443
444
445;;;;;;;; Tab Completion ;;;;;;;;
446
447
448;; Borrowed from the oblist egg
449(define find-symbol-table (foreign-lambda c-pointer "C_find_symbol_table" c-string))
450(define enum-symbols! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object))
451
452;; Globally defined enumeration state (callbacks can't be closures)
453(define enum-funcs '())
454
455;; Creates a list of closures that enumerate anything the user would want to type
456(define (create-enum-funcs word len)
457  ;; Environment symbols
458  (define (create-symbol-ef)
459        (let ((global-symbol-index (cons -1 '()))
460                  (global-symbol-pointer (find-symbol-table ".")))
461          (lambda ()
462                (let loop ()
463                  (let ((symb (enum-symbols! global-symbol-pointer 
464                                                                         global-symbol-index)))
465                        (cond ((not symb)
466                                   "")
467                                  ((not (##sys#symbol-has-toplevel-binding? symb))
468                                   (loop))
469                                  (else
470                                        (let ((str (##sys#symbol->qualified-string symb)))
471                                          ;; Possibly undo the mangling of keywords
472                                          (if (not (substring=? "###" str))
473                                                str
474                                                (string-append (substring str 3) ":"))))))))))
475  ;; R5RS keywords (including some special forms not included in above)
476  (define (create-static-ef)
477        (let ((index -1)
478                  (v-len (vector-length static-keywords)))
479          (lambda ()
480                (set! index (+ 1 index))
481                (if (not (>= index v-len))
482                  (vector-ref static-keywords index)
483                  ""))))
484  ;; Macros (thanks to Kon Lovett for suggesting ##sys#macro-environment)
485  (define (create-macro-ef)
486        (let ((index -1))
487          (lambda ()
488                (let loop ()
489                  (set! index (+ 1 index))
490                  (cond ((>= index (vector-length ##sys#macro-environment)) 
491                                 "")
492                                (else
493                                  (let ((ref (vector-ref ##sys#macro-environment index)))
494                                        (if (null? ref)
495                                          (loop)
496                                          (symbol->string (caar ref))))))))))
497  ;; Return a list of the above closures
498  (list (create-symbol-ef) (create-static-ef) (create-macro-ef)))
499
500
501
502;; This is the completion function called by readline
503;; It's called repeatedly until it returns an empty string
504;; (lambda'd to stop the compiler complaining about unused global var)
505((lambda ()
506   (define-external (gnu_readline_scm_complete (c-string word) (int len) (int state)) scheme-object
507         ;; If state is zero, init enumeration funcs.  Don't try to complete an empty string...
508         (when (zero? state)
509           (if (not (zero? len))
510                 (set! enum-funcs (create-enum-funcs word len))
511                 ""))
512         ;; Call the enumeration funcs, discarding the ones that are done
513         (let loop ()
514           (if (null? enum-funcs)
515                 ""
516                 (let ((result ((car enum-funcs))))
517                   (cond ((equal? result "")
518                                  (set! enum-funcs (cdr enum-funcs))
519                                  (loop))
520                                 ((substring=? word result 0 0 len)
521                                  result) ;; Return only ones that are a substring of the word typed
522                                 (else (loop)))))))))
523
524
525
526;; Things that will always be there...
527(define static-keywords (vector
528                                                ; R5RS
529                                                "abs" "acos" "and" "angle" "append" "apply" "asin" 
530                                                "assoc" "assq" "assv" "atan" "begin" "boolean?" 
531                                                "caar" "cadr" "call-with-current-continuation" 
532                                                "call-with-input-file" "call-with-output-file" 
533                                                "call-with-values" "car" "case" "cdddar" "cddddr" 
534                                                "cdr" "ceiling" "char->integer" "char-alphabetic?" 
535                                                "char-ci<=?" "char-ci<?" "char-ci=?" "char-ci>=?" 
536                                                "char-ci>?" "char-downcase" "char-lower-case?" 
537                                                "char-numeric?" "char-ready?" "char-upcase" 
538                                                "char-upper-case?" "char-whitespace?" "char<=?" 
539                                                "char<?" "char=?" "char>=?" "char>?" "char?" 
540                                                "close-input-port" "close-output-port" "complex?" 
541                                                "cond" "cons" "cos" "current-input-port" 
542                                                "current-output-port" "define" "define-syntax" 
543                                                "delay" "denominator" "display" "do" "dynamic-wind" 
544                                                "else" "eof-object?" "eq?" "equal?" "eqv?" "eval" 
545                                                "even?" "exact->inexact" "exact?" "exp" "expt" 
546                                                "floor" "for-each" "force" "gcd" "if" "imag-part" 
547                                                "inexact->exact" "inexact?" "input-port?" 
548                                                "integer->char" "integer?" "interaction-environment" 
549                                                "lambda" "lcm" "length" "let" "let*" "let-syntax" 
550                                                "letrec" "letrec-syntax" "list" "list->string" 
551                                                "list->vector" "list-ref" "list-tail" "list?" "load" 
552                                                "log" "magnitude" "make-polar" "make-rectangular" 
553                                                "make-string" "make-vector" "map" "max" "member" 
554                                                "memq" "memv" "min" "modulo" "negative?" "newline" 
555                                                "not" "null-environment" "null?" "number->string" 
556                                                "number?" "numerator" "odd?" "open-input-file" 
557                                                "open-output-file" "or" "output-port?" "pair?" 
558                                                "peek-char" "port?" "positive?" "procedure?" 
559                                                "quasiquote" "quote" "quotient" "rational?" 
560                                                "rationalize" "read" "read-char" "real-part" 
561                                                "real?" "remainder" "reverse" "round" 
562                                                "scheme-report-environment" "set!" "set-car!" 
563                                                "set-cdr!" "setcar" "sin" "sqrt" "string" 
564                                                "string->list" "string->number" "string->symbol" 
565                                                "string-append" "string-ci<=?" "string-ci<?" 
566                                                "string-ci=?" "string-ci>=?" "string-ci>?" 
567                                                "string-copy" "string-fill!" "string-length" 
568                                                "string-ref" "string-set!" "string<=?" "string<?" 
569                                                "string=?" "string>=?" "string>?" "string?" 
570                                                "substring" "symbol->string" "symbol?" 
571                                                "syntax-rules" "tan" "transcript-off" 
572                                                "transcript-on" "truncate" "values" "vector" 
573                                                "vector->list" "vector-fill!" "vector-length" 
574                                                "vector-ref" "vector-set!" "vector?" 
575                                                "with-input-from-file" "with-output-to-file" 
576                                                "write" "write-char" "zero?"
577                                                ; csi commands
578                                                ",?" ",p" ",d" ",du" ",dur" ",q" ",l" ",ln" ",r"
579                                                ",s" ",tr" ",utr" ",t" ",x" 
580                                                ))
581
582
Note: See TracBrowser for help on using the repository browser.