source: project/release/4/parley/trunk/parley.scm @ 24839

Last change on this file since 24839 was 24839, checked in by Christian Kellermann, 10 years ago

parley: use correct prompt at the repl

File size: 24.4 KB
Line 
1;;Copyright 2011 Christian Kellermann <ckeen@pestilenz.org>. All
2;;rights reserved.
3;;
4;;Redistribution and use in source and binary forms, with or without
5;;modification, are permitted provided that the following conditions
6;;are met:
7;;    1. Redistributions of source code must retain the above
8;;    copyright notice, this list of conditions and the following
9;;    disclaimer.
10;;    2. Redistributions in binary form must reproduce the above
11;;    copyright notice, this list of conditions and the following
12;;    disclaimer in the documentation and/or other materials provided
13;;    with the distribution.
14;; THIS SOFTWARE IS PROVIDED BY CHRISTIAN KELLERMANN ``AS IS'' AND ANY
15;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
17;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL CHRISTIAN KELLERMANN OR
18;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
19;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
20;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
21;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
22;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
23;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
24;; OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
25;; SUCH DAMAGE.
26;; The views and conclusions contained in the software and
27;; documentation are those of the authors and should not be
28;; interpreted as representing official policies, either expressed or
29;; implied, of Christian Kellermann.
30
31;; This is parley a small readline alike implementation in scheme. It
32;; has been based on the algorithm of linenoise another excellent
33;; library written by Salvatore Sanfilippo.  It aims at simplicity so
34;; you may miss certain features. Nevertheless it provides hooks for
35;; users of this library to extend its capabilities.
36;;
37;; Basic usage:
38;; (parley "Prompt> ") => string or #!eof
39;;
40;; To use it in csi add this to your .csirc:
41;;
42;;(use parley)
43;;(let ((old (current-input-port)))
44;;     (current-input-port (make-parley-port old)))
45;;
46;; TODOs: * Map string position to screen position as non printable
47;;          chars take up more than one ascii char on screen
48;;        * Support unicode somehow
49;;        * Separate state from module instance
50
51
52(module parley
53        (add-key-binding!
54         history-from-file
55         history-max-lines
56         history-to-file
57         make-parley-port
58         parley
59         terminal-supported?)
60
61        (import chicken scheme)
62        (use data-structures extras ports posix srfi-1 srfi-13 srfi-18 stty)
63
64        (define history-max-lines (make-parameter 100))
65        (define history #f)
66        (define exit-handler-installed? #f)
67        (define user-key-bindings '())
68        (define user-esc-sequences '())
69
70        (define port-list '())
71
72        (define +unsupported-terminals+ '("dumb", "cons25"))
73
74        (define (parley? p)
75          (and (port? p) (equal? (port-name p)
76                                 "(parley)")))
77
78        (define (real-port? p)
79          (call-with-current-continuation
80           (lambda (k)
81             (with-exception-handler
82              (lambda (e) (k #f))
83              (lambda ()
84                (and (port? p) (port->fileno p)))))))
85
86        (define (first-usable-port port plist)
87          (cond
88           ((and (not (port-closed? port))
89                 (real-port? port))
90            port)
91           ((null? plist) (error "No real port to read from available"))
92           (else (first-usable-port (car plist) (cdr plist)))))
93
94        (define (read-one-char port #!optional (plist port-list))
95          (let ((real-port (first-usable-port port plist)))
96            (unless (char-ready? port)
97              (thread-wait-for-i/o! (port->fileno port) #:input))
98            (read-char port)))
99
100        (define (read-one-line port)
101          (let loop ((l '())
102                     (c (read-one-char port)))
103            (cond ((equal? c #\newline)
104                   (list->string (reverse l)))
105                  ((eof-object? c) #!eof)
106                  (else
107                   (loop (cons c l) (read-one-char port))))))
108
109        (define (terminal-supported? port term)
110          (and (and (port? port) (or (parley? port) (terminal-port? port)))
111               (not (member term +unsupported-terminals+))))
112
113        (define (restore-terminal-settings port attrs)
114          (set-terminal-attributes! port TCSADRAIN attrs))
115
116        (define (install-exit-handler! port attributes)
117          (unless exit-handler-installed?
118            (on-exit (lambda ()
119                       (restore-terminal-settings
120                        port attributes)))
121            (set! exit-handler-installed #t)))
122
123        (define (enable-raw-mode port)
124          (let ((old-attrs (get-terminal-attributes port)))
125            (install-exit-handler! port old-attrs)
126            (stty port '(not echo icanon isig brkint icrnl inpck istrip ixon opost))
127            (stty port '(cs8))
128            (set-buffering-mode! port #:none)
129            old-attrs))
130
131        (define (get-terminal-columns port)
132          (receive (rows cols) (terminal-size port)
133                   (if (= 0 cols) 80 cols)))
134
135        (define +esc-sequences+
136          `(( cur-left-edge  . ,(lambda () "\x1b[0G"))
137            ( erase-to-right . ,(lambda () "\x1b[0K"))
138            ( move-to-col . ,(lambda (col) (sprintf "\x1b[~aG" col)))))
139
140        (define (esc-seq name)
141          (cond ((alist-ref name +esc-sequences+) =>
142                 identity)
143                (else (error "Unknown ESC sequence " name))))
144
145        (define (history-init!)
146          (when (not history) (set! history (make-history-cursor '()))))
147
148        (define (history-add! line)
149          (unless (equal? line "") (history 'add line))
150          line)
151
152        (define (history-to-file filename)
153          (with-output-to-file filename
154            (lambda ()
155              (for-each print (history '->list)))))
156
157        (define (history-from-file filename)
158          (for-each history-add!
159                    (with-input-from-file filename read-lines)))
160
161        (define (make-history-cursor h)
162          (let ((h h)
163                (pos 0)
164                (syntax-check
165                 (lambda (args)
166                   (if (not (= 2 (length args)))
167                       (error "make-history-cursor: expected 1 argument got "
168                              (sub1 (length args)) args)))))
169            (lambda (#!rest args)
170              (if (null? args) (list-ref pos h)
171                  (case (car args)
172                    ((reset)
173                     (set! pos 0))
174                    ((->list) h)
175                    ((replace)
176                     (syntax-check args)
177                     (if (not (null? h))
178                         (set! (car h) (cadr args))))
179                    ((add)
180                     (syntax-check args)
181                     (set! h (cons (cadr args) h))
182                     (set! pos 0)
183                     (if (> (length h)
184                            (history-max-lines))
185                         (set-cdr! (list-tail h (history-max-lines))
186                                   '())))
187                    ((next)
188                     (if (> pos 0)
189                         (begin (set! pos (sub1 pos))
190                                (list-ref h pos))
191                         ""))
192                    ((prev)
193                     (if (null? h)
194                         ""
195                         (let ((l (list-ref h pos)))
196                           (if (< (add1 pos) (length h))
197                               (set! pos (add1 pos)))
198                           l)))
199                    (else (list-ref h pos)))))))
200
201        (define (string-insert s i t)  (string-replace s t i i))
202
203        (define +caret-notation+
204          '((0 . "^@")
205            (1 . "^A")
206            (2 . "^B")
207            (3 . "^C")
208            (4 . "^D")
209            (5 . "^E")
210            (6 . "^F")
211            (7 . "^G")
212            (8 . "^H")
213            (9 . "^I")
214            (10 . "^J")
215            (11 . "^K")
216            (12 . "^L")
217            (13 . "^M")
218            (14 . "^N")
219            (15 . "^O")
220            (16 . "^P")
221            (17 . "^Q")
222            (18 . "^R")
223            (19 . "^S")
224            (20 . "^T")
225            (21 . "^U")
226            (22 . "^V")
227            (23 . "^W")
228            (24 . "^X")
229            (25 . "^Y")
230            (26 . "^Z")
231            (27 . "^[")
232            (28 . "^\\")
233            (29 . "^]")
234            (30 . "^^[j]")
235            (31 . "^_")
236            (127 . "^?")))
237
238        (define (convert-if-control-char c)
239          (cond ((alist-ref (char->integer c) +caret-notation+) => identity)
240                (else (string c))))
241
242        (define (get-complete-esc-sequence port #!optional (res #f))
243          (let ((c (read-one-char port)))
244            (cond ((eof-object? c) #f)
245                  ((and (not res)
246                        (equal? c #\x5b))
247                   (get-complete-esc-sequence port c))
248                  (res (list res c))
249                  (else #f))))
250
251        (define (get-column port)
252          (display "\x1b[6n")
253          (flush-output (current-output-port))
254          (let loop ((r '())
255                     (c (read-one-char port)))
256            (if (or (equal? c #\R)
257                    (eof-object? c))
258                (string->number (cadr (string-split (list->string (reverse r)) ";R")))
259                (loop (cons c r) (read-one-char port)))))
260
261        (define (add-key-binding! key handler #!key (esc-sequence #f))
262          (if esc-sequence
263              (set! user-esc-sequences
264                    (alist-update! key handler user-esc-sequences equal?))
265              (set! user-key-bindings
266                    (alist-update! key handler user-key-bindings equal?))))
267
268        ;; each handler gets the current prompt, in, out, line,
269        ;; position of the cursor, exit continuation and prompt offset
270        ;; and has to return a list of these arguments for the next
271        ;; loop iteration of prompt-loop
272        (define +key-handlers+
273          `((nop .
274                 ,(lambda (prompt in out line pos exit offset)
275                    (list prompt in out line pos exit offset)))
276            (discard-and-restart .
277                                 ,(lambda (prompt in out line pos exit offset)
278                                    (list prompt in out "" 0 exit offset)))
279            (delete-curr-char .
280                              ,(lambda (prompt in out line pos exit offset)
281                                 (if (> pos 0)
282                                     (let ((nline (string-append
283                                                   (string-take line (sub1 pos))
284                                                   (string-drop line pos))))
285                                       (list prompt in out nline (sub1 pos) exit offset))
286                                     (list prompt in out line pos exit offset))))
287            (swap-char .
288                       ,(lambda (prompt in out line pos exit offset)
289                          (let ((len (string-length line)))
290                            (if (and (> pos 0)
291                                     (< pos len))
292                                (let* ((before (sub1 pos))
293                                       (token-1 (string (string-ref line before)))
294                                       (token (string (string-ref line pos)))
295                                       (tmp (string-replace line token before pos))
296                                       (nline (string-replace tmp token-1 pos (add1 pos)))
297                                       (npos (if (not (= pos (sub1 len)))
298                                                 (add1 pos)
299                                                 pos)))
300                                  (refresh-line prompt out nline npos offset)
301                                  (list prompt in out nline npos exit offset))
302                                (list prompt in out line pos exit offset)))))
303            (left-arrow .
304                        ,(lambda (prompt in out line pos exit offset)
305                           (list prompt in out line (if (> pos 0) (sub1 pos) pos) exit offset)))
306            (right-arrow .
307                         ,(lambda (prompt in out line pos exit offset)
308                            (list prompt
309                                  in out
310                                  line
311                                  (if (not (= pos
312                                              (string-length line)))
313                                      (add1 pos)
314                                      pos)
315                                  exit offset)))
316            (prev-history .
317                          ,(lambda (prompt in out line pos exit offset)
318                             (let ((nline (history 'prev)))
319                               (list prompt in out nline (string-length nline) exit offset))))
320            (next-history .
321                          ,(lambda (prompt in out line pos exit offset)
322                             (let ((nline (history 'next)))
323                               (list prompt in out nline (string-length nline) exit offset))))
324            (delete-until-eol .
325                              ,(lambda (prompt in out line pos exit offset)
326                                 (list prompt in out (string-take line pos) pos exit offset)))
327            (jump-to-start-of-line .
328                                   ,(lambda (prompt in out line pos exit offset)
329                                      (list prompt in out line 0 exit offset)))
330            (jump-to-eol .
331                         ,(lambda (prompt in out line pos exit offset)
332                            (list prompt in out line (string-length line) exit offset)))
333            (escape-sequence .
334                             ,(lambda (prompt in out line pos exit offset)
335                                (cond ((get-complete-esc-sequence in) =>
336                                       (lambda (seq)
337                                         (cond ((alist-ref seq user-esc-sequences) =>
338                                                (lambda (e) (e prompt in out line pos exit offset)))
339                                               (else
340                                                (case (cadr seq)
341                                                  ((#\x43) ((handle 'right-arrow) prompt in out line pos exit offset))
342                                                  ((#\x44) ((handle 'left-arrow) prompt in out line pos exit offset))
343                                                  ((#\x41) ((handle 'prev-history) prompt in out line pos exit offset))
344                                                  ((#\x42) ((handle 'next-history) prompt in out line pos exit offset))
345                                                  (else
346                                                   (list prompt in out line pos exit offset)))))))
347                                      (else (list prompt in out line pos exit offset)))))))
348
349        (define (handle event)
350          (cond ((alist-ref event +key-handlers+) =>
351                 identity)
352                (else (error "Unhandled event " event))))
353
354        (define (refresh-line prompt port line pos offset)
355          (let* ((cols (- (get-terminal-columns port)
356                          offset))
357                 (plen (+ offset (string-length prompt)))
358                 (chunk-size (- cols plen 1))
359                 (chunkno (inexact->exact (floor (/ pos chunk-size))))
360                 (start (* chunk-size chunkno))
361                 (end (min (string-length line)
362                           (+ start chunk-size)))
363                 (npos (modulo (- pos start) chunk-size))
364                 (delimited-line (substring line start end)))
365            (parameterize ((current-output-port port))
366;                          (display ((esc-seq 'cur-left-edge)))
367                          (display ((esc-seq 'move-to-col) offset))
368                          (display prompt)
369                          (display (string-fold
370                                    (lambda (c r)
371                                      (string-append r (convert-if-control-char c)))
372                                    ""
373                                    delimited-line))
374                          (display ((esc-seq 'erase-to-right)))
375                          (display ((esc-seq 'cur-left-edge)))
376                          (display ((esc-seq 'move-to-col)
377                                     (if (= 0 (+ npos plen))
378                                         -1
379                                         (+ npos plen))))
380                          (flush-output))))
381
382        (define (prompt-loop prompt in out line pos return offset)
383          (refresh-line prompt out line pos offset)
384          (apply prompt-loop
385                 ((let ((c (read-one-char in)))
386                    (cond ((alist-ref c user-key-bindings) => identity)
387                          (else
388                           (case c
389                             ((#\xd)
390                              (newline out)
391                              (return line))
392                             ((#!eof #\x04)
393                              (display "^D" out)
394                              (if (string-null? line)
395                                  (return #!eof)
396                                  (begin
397                                    (newline out)
398                                    (return line))))
399                             ((#\x3)
400                              (display "^C" out)
401                              (newline out)
402                              (return ""))
403                             ((#\x15)
404                              (handle 'discard-and-restart))
405                             ((#\x8 #\x7f)
406                              (handle 'delete-curr-char))
407                             ((#\x14)
408                              (handle 'swap-char))
409                             ((#\x2)
410                              (handle 'left-arrow))
411                             ((#\x6)
412                              (handle 'right-arrow))
413                             ((#\x10)
414                              (handle 'prev-history))
415                             ((#\xe)
416                              (handle 'next-history))
417                             ((#\x1b)
418                              (handle 'escape-sequence))
419                             ((#\xb)
420                              (handle 'delete-until-eol))
421                             ((#\x1)
422                              (handle 'jump-to-start-of-line))
423                             ((#\x5)
424                              (handle 'jump-to-eol))
425                             (else
426                              (lambda (prompt in out line pos return offset)
427                                (list
428                                 prompt
429                                 in out
430                                 (string-insert line pos (string c))
431                                 (add1 pos)
432                                 return
433                                 offset)))))))
434                  prompt in out line pos return offset)))
435
436        (define (read-raw prompt in out offset)
437          (let ((l (call-with-current-continuation
438                    (lambda (return)
439                      (prompt-loop prompt in out "" 0 return offset)))))
440            (history-add! l)))
441
442
443        (define (parley prompt #!key (in ##sys#standard-input) (out (current-output-port)))
444          (set-buffering-mode! out #:none)
445          (let* ((parley-port (parley? in))
446                 (real-in-port (first-usable-port in port-list))
447                 (useful-term (terminal-supported? real-in-port (get-environment-variable "TERM")))
448                 (old-attrs (and useful-term (enable-raw-mode real-in-port)))
449                 (line (if useful-term
450                           (begin
451                             (history-init!)
452                             (unless (member in port-list)
453                               (set! port-list (cons in port-list)))
454                             (let ((offset (if parley-port 1 (get-column real-in-port))))
455                               (read-raw prompt real-in-port out offset)))
456                           (begin
457                             ;(print "; Warning: dumb terminal")
458                             (set-buffering-mode! real-in-port #:none)
459                             (when (or (terminal-port? in)
460                                       parley-port)
461                               (display prompt out))
462                             (flush-output out)
463                             (let ((l (read-one-line real-in-port)))
464                               l)))))
465            (if old-attrs (restore-terminal-settings real-in-port old-attrs))
466            line))
467
468        (define (input-missing? line)
469          ; Walk the line like Johnny Cash
470          (define (wtl lst esc parens brackets str quote-syntax)
471            (cond ((null? lst) (or (< 0 parens)
472                                   (< 0 brackets)
473                                   str
474                                   esc
475                                   quote-syntax))
476                  (esc (wtl (cdr lst) #f parens brackets str #f))
477                  (str (wtl (cdr lst) (equal? (car lst) #\\) parens brackets (not (equal? (car lst) #\")) #f))
478                  (else (case (car lst)
479                          ((#\\) (wtl (cdr lst) #t parens brackets str #f))
480                          ((#\") (wtl (cdr lst) #f parens brackets (not str) #f))
481                          ((#\() (wtl (cdr lst) #f (add1 parens) brackets str #f))
482                          ((#\)) (wtl (cdr lst) #f (if (> parens 0) (sub1 parens) parens) brackets str #f))
483                          ((#\[) (wtl (cdr lst) #f parens (add1 brackets) str #f))
484                          ((#\]) (wtl (cdr lst) #f parens (if (> brackets 0) (sub1 brackets) brackets) str #f))
485                          ((#\') (wtl (cdr lst) #f parens brackets str #t))
486                          (else (wtl (cdr lst) esc parens brackets str #f))))))
487          (wtl (string->list line) #f 0 0 #f #f))
488
489
490        (define (make-parley-port in #!optional prompt prompt2)
491          (let ((l "")
492                (handle #f)
493                (p1 prompt)
494                (p2 (or prompt2 "> "))
495                (pos 0))
496            (unless (member in port-list)
497              (set! port-list (cons in port-list)))
498            (letrec ((append-while-incomplete
499                      (lambda (start)
500                        (let* ((line (parley (if (string-null? start)
501                                                 (or p1 ((repl-prompt)))
502                                                 p2)
503                                          in: in))
504                               (res (and (string? line) (string-append start line))))
505                          (cond ((and (eof-object? line) (string-null? start)) line)
506                                ((eof-object? line) start)
507                                ((input-missing? res)
508                                 (append-while-incomplete res))
509                                (else res)))))
510                     (char-ready?
511                      (lambda ()
512                        (and (string? l)
513                             (< pos (string-length l)))))
514                     (get-next-char!
515                      (lambda ()
516                        (cond ((not l)
517                               #!eof)
518                              ((char-ready?)
519                               (let ((ch (string-ref l pos)))
520                                 (set! pos (+ 1 pos))
521                                 ch))
522                              (else
523                               (set! pos 0)
524                               (set! l
525                                     (append-while-incomplete ""))
526                               (if (string? l)
527                                     (set! l (string-append l "\n")))
528                               (if (not (eof-object? l))
529                                   (get-next-char!)
530                                   l))))))
531              (set! handle (lambda (s)
532                             (print-call-chain)
533                             (set! pos 0)
534                             (set! l "")
535                             (##sys#user-interrupt-hook)))
536              (set-signal-handler! signal/int handle)
537              (let ((p (make-input-port
538                        get-next-char!
539                        char-ready?
540                        (lambda ()
541                          (set-signal-handler! signal/int #f)
542                          'closed-parley-port))))
543                (set-port-name! p "(parley)")
544                p)))))
Note: See TracBrowser for help on using the repository browser.