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

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

parley: fix bug 721 and improve pasting

This fixes:

  • preservance of newlines for dumb terminal usage (e.g. piping input to csi) -> bug 721
  • Before determining the column offset all existing input is now preserved and fed to the parsing procedure afterwards. This fixes pasting but csi's repl my look a but unfamliliar:

#;1> 1
1
#;2> 2
#;2> 3
#;2> 4
2
3
4
#;5>

History is preserved correctly.

  • simple comments are now ignored by the input-missing? procedure. Block comments and #; syntax are not (yet).
File size: 26.2 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         parley-debug
60         terminal-supported?)
61
62        (import chicken scheme)
63        (use data-structures extras ports posix srfi-1 srfi-13 srfi-18 stty)
64
65        (define parley-debug (make-parameter #f))
66
67        (define-syntax dbg
68          (syntax-rules ()
69            ((_ fmt ...) (if (parley-debug) (fprintf (current-error-port) fmt ...)))))
70
71
72        (define history-max-lines (make-parameter 100))
73        (define history #f)
74        (define exit-handler-installed? #f)
75        (define user-key-bindings '())
76        (define user-esc-sequences '())
77
78        (define port-list '())
79
80        (define +unsupported-terminals+ '("dumb", "cons25"))
81
82        (define (parley? p)
83          (and (port? p) (equal? (port-name p)
84                                 "(parley)")))
85
86        (define (real-port? p)
87          (call-with-current-continuation
88           (lambda (k)
89             (with-exception-handler
90              (lambda (e) (k #f))
91              (lambda ()
92                (and (port? p) (port->fileno p)))))))
93
94        (define (first-usable-port port plist)
95          (cond
96           ((and (not (port-closed? port))
97                 (real-port? port))
98            port)
99           ((null? plist) (error "No real port to read from available"))
100           (else (first-usable-port (car plist) (cdr plist)))))
101
102        (define (read-one-char port #!optional (plist port-list))
103          (let ((real-port (first-usable-port port plist)))
104            (unless (char-ready? port)
105              (thread-wait-for-i/o! (port->fileno real-port) #:input))
106            (read-char port)))
107
108        (define (read-one-line port)
109          (let loop ((l '())
110                     (c (read-one-char port)))
111            (cond ((equal? c #\newline)
112                   (list->string (reverse (cons c l))))
113                  ((eof-object? c) #!eof)
114                  (else
115                   (loop (cons c l) (read-one-char port))))))
116
117        (define (terminal-supported? port term)
118          (and (and (port? port) (or (parley? port) (terminal-port? port)))
119               (not (member term +unsupported-terminals+))))
120
121        (define (restore-terminal-settings port attrs)
122          (set-terminal-attributes! port TCSADRAIN attrs))
123
124        (define (install-exit-handler! port attributes)
125          (unless exit-handler-installed?
126            (on-exit (lambda ()
127                       (restore-terminal-settings
128                        port attributes)))
129            (set! exit-handler-installed #t)))
130
131        (define (enable-raw-mode port)
132          (let ((old-attrs (get-terminal-attributes port)))
133            (install-exit-handler! port old-attrs)
134            (stty port '(not echo icanon isig brkint icrnl inpck istrip ixon opost))
135            (stty port '(cs8))
136            (set-buffering-mode! port #:none)
137            old-attrs))
138
139        (define (get-terminal-columns port)
140          (receive (rows cols) (terminal-size port)
141                   (if (= 0 cols) 80 cols)))
142
143        (define +esc-sequences+
144          `(( cur-left-edge  . ,(lambda () "\x1b[0G"))
145            ( erase-to-right . ,(lambda () "\x1b[0K"))
146            ( move-forward   . ,(lambda (n) (sprintf "\x1b[~aC" n)))
147            ( move-backward  . ,(lambda (n) (sprintf "\x1b[~aD" n)))
148            ( move-to-col    . ,(lambda (col) (sprintf "\x1b[~aG" col)))
149            ( save-position  . ,(lambda () "\x1b[s"))
150            ( restore-position . ,(lambda () "\x1b[u"))))
151
152        (define (esc-seq name)
153          (cond ((alist-ref name +esc-sequences+) =>
154                 identity)
155                (else (error "Unknown ESC sequence " name))))
156
157        (define (history-init!)
158          (when (not history) (set! history (make-history-cursor '()))))
159
160        (define (history-add! line)
161          (unless (equal? line "") (history 'add line))
162          line)
163
164        (define (history-to-file filename)
165          (with-output-to-file filename
166            (lambda ()
167              (for-each print (history '->list)))))
168
169        (define (history-from-file filename)
170          (for-each history-add!
171                    (with-input-from-file filename read-lines)))
172
173        (define (make-history-cursor h)
174          (let ((h h)
175                (pos 0)
176                (syntax-check
177                 (lambda (args)
178                   (if (not (= 2 (length args)))
179                       (error "make-history-cursor: expected 1 argument got "
180                              (sub1 (length args)) args)))))
181            (lambda (#!rest args)
182              (if (null? args) (list-ref pos h)
183                  (case (car args)
184                    ((reset)
185                     (set! pos 0))
186                    ((->list) h)
187                    ((replace)
188                     (syntax-check args)
189                     (if (not (null? h))
190                         (set! (car h) (cadr args))))
191                    ((add)
192                     (syntax-check args)
193                     (set! h (cons (cadr args) h))
194                     (set! pos 0)
195                     (if (> (length h)
196                            (history-max-lines))
197                         (set-cdr! (list-tail h (history-max-lines))
198                                   '())))
199                    ((next)
200                     (if (> pos 0)
201                         (begin (set! pos (sub1 pos))
202                                (list-ref h pos))
203                         ""))
204                    ((prev)
205                     (if (null? h)
206                         ""
207                         (let ((l (list-ref h pos)))
208                           (if (< (add1 pos) (length h))
209                               (set! pos (add1 pos)))
210                           l)))
211                    (else (list-ref h pos)))))))
212
213        (define (string-insert s i t)  (string-replace s t i i))
214
215        (define +caret-notation+
216          '((0 . "^@")
217            (1 . "^A")
218            (2 . "^B")
219            (3 . "^C")
220            (4 . "^D")
221            (5 . "^E")
222            (6 . "^F")
223            (7 . "^G")
224            (8 . "^H")
225            (9 . "^I")
226            (10 . "^J")
227            (11 . "^K")
228            (12 . "^L")
229            (13 . "^M")
230            (14 . "^N")
231            (15 . "^O")
232            (16 . "^P")
233            (17 . "^Q")
234            (18 . "^R")
235            (19 . "^S")
236            (20 . "^T")
237            (21 . "^U")
238            (22 . "^V")
239            (23 . "^W")
240            (24 . "^X")
241            (25 . "^Y")
242            (26 . "^Z")
243            (27 . "^[")
244            (28 . "^\\")
245            (29 . "^]")
246            (30 . "^^[j]")
247            (31 . "^_")
248            (127 . "^?")))
249
250        (define (convert-if-control-char c)
251          (cond ((alist-ref (char->integer c) +caret-notation+) => identity)
252                (else (string c))))
253
254        (define (get-complete-esc-sequence port #!optional (res #f))
255          (let ((c (read-one-char port)))
256            (cond ((eof-object? c) #f)
257                  ((and (not res)
258                        (equal? c #\x5b))
259                   (get-complete-esc-sequence port c))
260                  (res (list res c))
261                  (else #f))))
262
263        (define (slurp-all-input port)
264          (let loop ((r '()))
265            (if (char-ready? port)
266                (loop (cons (read-one-char port) r))
267                (reverse r))))
268
269        (define (get-column port)
270          (display "\x1b[6n")
271          (flush-output (current-output-port))
272          (let loop ((r '())
273                     (c (read-one-char port)))
274            (if (or (equal? c #\R)
275                    (eof-object? c))
276                (string->number (cadr (string-split (list->string (reverse r)) ";R")))
277                (loop (cons c r) (read-one-char port)))))
278
279        (define (add-key-binding! key handler #!key (esc-sequence #f))
280          (if esc-sequence
281              (set! user-esc-sequences
282                    (alist-update! key handler user-esc-sequences equal?))
283              (set! user-key-bindings
284                    (alist-update! key handler user-key-bindings equal?))))
285
286        ;; each handler gets the current prompt, in, out, line,
287        ;; position of the cursor, exit continuation and prompt offset
288        ;; and has to return a list of these arguments for the next
289        ;; loop iteration of prompt-loop
290        (define +key-handlers+
291          `((nop .
292                 ,(lambda (prompt in out line pos exit offset)
293                    (list prompt in out line pos exit offset)))
294            (discard-and-restart .
295                                 ,(lambda (prompt in out line pos exit offset)
296                                    (list prompt in out "" 0 exit offset)))
297            (delete-curr-char .
298                              ,(lambda (prompt in out line pos exit offset)
299                                 (if (> pos 0)
300                                     (let ((nline (string-append
301                                                   (string-take line (sub1 pos))
302                                                   (string-drop line pos))))
303                                       (list prompt in out nline (sub1 pos) exit offset))
304                                     (list prompt in out line pos exit offset))))
305            (swap-char .
306                       ,(lambda (prompt in out line pos exit offset)
307                          (let ((len (string-length line)))
308                            (if (and (> pos 0)
309                                     (< pos len))
310                                (let* ((before (sub1 pos))
311                                       (token-1 (string (string-ref line before)))
312                                       (token (string (string-ref line pos)))
313                                       (tmp (string-replace line token before pos))
314                                       (nline (string-replace tmp token-1 pos (add1 pos)))
315                                       (npos (if (not (= pos (sub1 len)))
316                                                 (add1 pos)
317                                                 pos)))
318                                  (refresh-line prompt out nline npos offset)
319                                  (list prompt in out nline npos exit offset))
320                                (list prompt in out line pos exit offset)))))
321            (left-arrow .
322                        ,(lambda (prompt in out line pos exit offset)
323                           (list prompt in out line (if (> pos 0) (sub1 pos) pos) exit offset)))
324            (right-arrow .
325                         ,(lambda (prompt in out line pos exit offset)
326                            (list prompt
327                                  in out
328                                  line
329                                  (if (not (= pos
330                                              (string-length line)))
331                                      (add1 pos)
332                                      pos)
333                                  exit offset)))
334            (prev-history .
335                          ,(lambda (prompt in out line pos exit offset)
336                             (let ((nline (history 'prev)))
337                               (list prompt in out nline (string-length nline) exit offset))))
338            (next-history .
339                          ,(lambda (prompt in out line pos exit offset)
340                             (let ((nline (history 'next)))
341                               (list prompt in out nline (string-length nline) exit offset))))
342            (delete-until-eol .
343                              ,(lambda (prompt in out line pos exit offset)
344                                 (list prompt in out (string-take line pos) pos exit offset)))
345            (jump-to-start-of-line .
346                                   ,(lambda (prompt in out line pos exit offset)
347                                      (list prompt in out line 0 exit offset)))
348            (jump-to-eol .
349                         ,(lambda (prompt in out line pos exit offset)
350                            (list prompt in out line (string-length line) exit offset)))
351            (escape-sequence .
352                             ,(lambda (prompt in out line pos exit offset)
353                                (cond ((get-complete-esc-sequence in) =>
354                                       (lambda (seq)
355                                         (cond ((alist-ref seq user-esc-sequences) =>
356                                                (lambda (e) (e prompt in out line pos exit offset)))
357                                               (else
358                                                (case (cadr seq)
359                                                  ((#\x43) ((handle 'right-arrow) prompt in out line pos exit offset))
360                                                  ((#\x44) ((handle 'left-arrow) prompt in out line pos exit offset))
361                                                  ((#\x41) ((handle 'prev-history) prompt in out line pos exit offset))
362                                                  ((#\x42) ((handle 'next-history) prompt in out line pos exit offset))
363                                                  (else
364                                                   (list prompt in out line pos exit offset)))))))
365                                      (else (list prompt in out line pos exit offset)))))))
366
367        (define (handle event)
368          (cond ((alist-ref event +key-handlers+) =>
369                 identity)
370                (else (error "Unhandled event " event))))
371
372        (define (refresh-line prompt port line pos offset)
373          (let* ((cols (- (get-terminal-columns port)
374                          offset))
375                 (plen (+ offset (string-length prompt)))
376                 (chunk-size (- cols plen 1))
377                 (chunkno (inexact->exact (floor (/ pos chunk-size))))
378                 (start (* chunk-size chunkno))
379                 (end (min (string-length line)
380                           (+ start chunk-size)))
381                 (npos (modulo (- pos start) chunk-size))
382                 (delimited-line (substring line start end)))
383            (parameterize ((current-output-port port))
384;                          (display ((esc-seq 'cur-left-edge)))
385                          (display ((esc-seq 'move-to-col) offset))
386                          (display prompt)
387                          (display (string-fold
388                                    (lambda (c r)
389                                      (string-append r (convert-if-control-char c)))
390                                    ""
391                                    delimited-line))
392                          (display ((esc-seq 'erase-to-right)))
393                          (display ((esc-seq 'cur-left-edge)))
394                          (display ((esc-seq 'move-to-col)
395                                     (if (= 0 (+ npos plen))
396                                         -1
397                                         (+ npos plen))))
398                          (flush-output))))
399
400        (define (prompt-loop prompt in out line pos return offset)
401          (refresh-line prompt out line pos offset)
402          (apply prompt-loop
403                 ((let ((c (read-one-char in)))
404                    (cond ((alist-ref c user-key-bindings) => identity)
405                          (else
406                           (case c
407                             ((#\xd)
408                              (newline out)
409                              (return line))
410                             ((#!eof #\x04)
411                              (if (string-null? line)
412                                  (begin
413                                    (display "^D" out)
414                                    (return #!eof))
415                                  (begin
416                                    (newline out)
417                                    (return line))))
418                             ((#\x3)
419                              (display "^C" out)
420                              (newline out)
421                              (return ""))
422                             ((#\x15)
423                              (handle 'discard-and-restart))
424                             ((#\x8 #\x7f)
425                              (handle 'delete-curr-char))
426                             ((#\x14)
427                              (handle 'swap-char))
428                             ((#\x2)
429                              (handle 'left-arrow))
430                             ((#\x6)
431                              (handle 'right-arrow))
432                             ((#\x10)
433                              (handle 'prev-history))
434                             ((#\xe)
435                              (handle 'next-history))
436                             ((#\x1b)
437                              (handle 'escape-sequence))
438                             ((#\xb)
439                              (handle 'delete-until-eol))
440                             ((#\x1)
441                              (handle 'jump-to-start-of-line))
442                             ((#\x5)
443                              (handle 'jump-to-eol))
444                             (else
445                              (lambda (prompt in out line pos return offset)
446                                (list
447                                 prompt
448                                 in out
449                                 (string-insert line pos (string c))
450                                 (add1 pos)
451                                 return
452                                 offset)))))))
453                  prompt in out line pos return offset)))
454
455        (define (read-raw prompt in out offset)
456          (let ((l (call-with-current-continuation
457                    (lambda (return)
458                      (prompt-loop prompt in out "" 0 return offset)))))
459            (history-add! l)))
460
461        (define (useful-term? port)
462          (terminal-supported?
463           (first-usable-port port port-list)
464           (get-environment-variable "TERM")))
465
466        (define (parley prompt #!key (in ##sys#standard-input) (out (current-output-port)))
467          (set-buffering-mode! out #:none)
468          (let* ((parley-port (parley? in))
469                 (real-in-port (first-usable-port in port-list))
470                 (useful-term (terminal-supported? real-in-port (get-environment-variable "TERM")))
471                 (old-attrs (and useful-term (enable-raw-mode real-in-port))))
472            (let ((lines (if useful-term
473                             (begin
474                               (history-init!)
475                               (unless (member in port-list)
476                                 (set! port-list (cons in port-list)))
477                               (let* ((prev-input (and (char-ready? in) (slurp-all-input in)))
478                                      (offset (if parley-port 1 (get-column real-in-port))))
479                                 (if prev-input
480                                     (call-with-input-string
481                                         (list->string prev-input)
482                                       (lambda (in)
483                                         (let loop ((r '()))
484                                           (if (eof-object? (peek-char in))
485                                               (reverse r)
486                                               (loop (cons (read-raw prompt in out offset) r))))))
487                                     (read-raw prompt real-in-port out offset))))
488                             (begin
489                               (dbg "; Warning: dumb terminal")
490                               (set-buffering-mode! real-in-port #:none)
491                               (when (or (terminal-port? in)
492                                         parley-port)
493                                 (display prompt out))
494                               (flush-output out)
495                               (let ((l (read-one-line real-in-port)))
496                                 l)))))
497              (if old-attrs (restore-terminal-settings real-in-port old-attrs))
498              lines)))
499
500        (define (input-missing? line)
501          ; Walk the line like Johnny Cash
502          (define (wtl lst esc parens brackets str quote-syntax)
503            (cond ((null? lst) (or (< 0 parens)
504                                   (< 0 brackets)
505                                   str
506                                   esc
507                                   quote-syntax))
508                  (esc (wtl (cdr lst) #f parens brackets str #f))
509                  (str (wtl (cdr lst) (equal? (car lst) #\\) parens brackets (not (equal? (car lst) #\")) #f))
510                  (else (case (car lst)
511                          ((#\;) (let (( r (drop-while (lambda (c) (not (equal? c #\newline))) lst)))
512                                   (wtl (if (pair? r) (cdr r) r)  #f parens brackets str #f)))
513                          ((#\\) (wtl (cdr lst) #t parens brackets str #f))
514                          ((#\") (wtl (cdr lst) #f parens brackets (not str) #f))
515                          ((#\() (wtl (cdr lst) #f (add1 parens) brackets str #f))
516                          ((#\)) (wtl (cdr lst) #f (if (> parens 0) (sub1 parens) parens) brackets str #f))
517                          ((#\[) (wtl (cdr lst) #f parens (add1 brackets) str #f))
518                          ((#\]) (wtl (cdr lst) #f parens (if (> brackets 0) (sub1 brackets) brackets) str #f))
519                          ((#\') (wtl (cdr lst) #f parens brackets str #t))
520                          (else (wtl (cdr lst) esc parens brackets str #f))))))
521          (wtl (string->list line) #f 0 0 #f #f))
522
523        (define (make-parley-port in #!optional prompt prompt2)
524          (let ((l "")
525                (handle #f)
526                (p1 prompt)
527                (p2 (or prompt2 "> "))
528                (pos 0))
529            (unless (member in port-list)
530              (set! port-list (cons in port-list)))
531            (letrec ((append-while-incomplete
532                      (lambda (start)
533                        (let* ((lines (parley (if (string-null? start)
534                                                 (or p1 ((repl-prompt)))
535                                                 p2)
536                                          in: in))
537                               (line (if (list? lines) (string-intersperse lines (string #\newline)) lines))
538                               (res (and (string? line) (string-append start line))))
539                          (cond ((and (eof-object? line) (string-null? start)) line)
540                                ((eof-object? line) start)
541                                ((input-missing? res)
542                                 (append-while-incomplete res))
543                                (else res)))))
544                     (char-ready?
545                      (lambda ()
546                        (and (string? l)
547                             (< pos (string-length l)))))
548                     (get-next-char!
549                      (lambda ()
550                        (cond ((not l)
551                               #!eof)
552                              ((char-ready?)
553                               (let ((ch (string-ref l pos)))
554                                 (set! pos (+ 1 pos))
555                                 ch))
556                              (else
557                               (set! pos 0)
558                               (set! l
559                                     (append-while-incomplete ""))
560                               (if (and (useful-term? in) (string? l))
561                                     (set! l (string-append l "\n")))
562                               (if (not (eof-object? l))
563                                   (get-next-char!)
564                                   l))))))
565              (set! handle (lambda (s)
566                             (print-call-chain)
567                             (set! pos 0)
568                             (set! l "")
569                             (##sys#user-interrupt-hook)))
570              (set-signal-handler! signal/int handle)
571              (let ((p (make-input-port
572                        get-next-char!
573                        char-ready?
574                        (lambda ()
575                          (set-signal-handler! signal/int #f)
576                          'closed-parley-port))))
577                (set-port-name! p "(parley)")
578                p)))))
Note: See TracBrowser for help on using the repository browser.