source: project/release/3/readline/readline.scm @ 9164

Last change on this file since 9164 was 9164, checked in by elf, 12 years ago

new version. fixed multiple sessions clobbering each others histories.

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