1;;;
2;;; gauche/listener - listerner utility
3;;;
4;;;   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34;; provides functions useful to implement a repl listener
35
36(define-module gauche.listener
37  (use srfi-13)
38  (export <listener>
39          listener-read-handler
40          listener-show-prompt
41          complete-sexp?)   ;now built-in, exported for the compatibility
42  )
43(select-module gauche.listener)
44
45;; Listener class
46;;
47;;   <listener> is a single-buffered, that is, only the input is
48;;   buffered until it consists a valid S-expression.  The output
49;;   is directly sent to the output port.  It's enough to handle
50;;   usual situation.
51;;
52;;   A possible variant of <listener> is a double-buffered listener,
53;;   that buffers output as well, which will be sent to the output
54;;   port whenever it is ready.
55
56(define-class <listener> ()
57  ((input-port  :init-keyword :input-port  :init-form (current-input-port))
58   (output-port :init-keyword :output-port :init-form (current-output-port))
59   (error-port  :init-keyword :error-port  :init-form (current-error-port))
60   (reader      :init-keyword :reader    :init-form read)
61   (evaluator   :init-keyword :evaluator :init-form eval)
62   (printer     :init-keyword :printer
63                :init-form (lambda args
64                             (for-each (^r (write r) (newline)) args)))
65   (prompter    :init-keyword :prompter
66                :init-form (cut display "listener> "))
67   (environment :init-keyword :environment
68                :init-form (interaction-environment))
69   (finalizer   :init-keyword :finalizer :init-form #f)
70   (error-handler :init-keyword :error-handler
71                  :init-form report-error)
72   (fatal-handler :init-keyword :fatal-handler
73                  :init-form #f)
74   ;; Private
75   (rbuf        :init-value "")
76   (original-input-port)    ; capture std ports when listener-read-handler is
77   (original-output-port)   ;   called.
78   (original-error-port)    ;
79   ))
80
81(define-method listener-show-prompt ((self <listener>))
82  (guard (e [(sigpipe? e)
83             (or (listener-fatal self e)
84                 (listener-finalize self))
85             #f])
86    (with-output-to-port (ref self 'output-port)
87      (^[]
88        ((ref self 'prompter))
89        (flush)
90        #t))))
91
92;; Returns a thunk which should be called whenever input is
93;; available.
94
95;; Error handling is rather convoluted, for we have to deal with
96;; a few different cases:
97;;
98;;  - I/O errors with reading/writing the client is regarded a
99;;    fatal error.  The fatal-handler is called if the listener
100;;    has any.  If the fatal-handler returns #f or the listener
101;;    doesn't have one, the finalizer is called.  Usually these
102;;    handlers removes listener to be called again.
103;;
104;;  - Errors during fatal handler or finalizer are "passed through"
105;;    to the caller of the listener handler.  Usually it has a
106;;    fatal consequence.  The fatal-handler and finalizer should
107;;    be written so that foreseeable errors are properly handled
108;;    within them.
109;;
110;;  - Other errors (e.g. read error while reading provided S-expr,
111;;    or evaluation error) are handled by listener's error-handler.
112;;    Double fault is regarded as a fatal error.
113
114(define-method listener-read-handler ((self <listener>))
115
116  (define (body return)
117    (define (finish)
118      (guard (e [else (return e)])
119        (listener-finalize self)
120        (return #f)))
121    (define (abort e)
122      (guard (e [else (return e)])
123        (or (listener-fatal self e) (listener-finalize self))
124        (return #f)))
125
126    (let1 chunk (guard (e [else (abort e)])
127                  (read-block 8192 (ref self 'input-port)))
128      (when (eof-object? chunk) (finish))
129      (with-ports
130          (ref self 'input-port)
131          (ref self 'output-port)
132          (ref self 'error-port)
133        (^[]
134          (update! (ref self 'rbuf) (cut string-append <> chunk))
135          (string-incomplete->complete (ref self 'rbuf))
136          (guard (e [else
137                     (set! (ref self 'rbuf) "")
138                     (guard (e1 [else (abort e1)])
139                       ((ref self 'error-handler) e)
140                       (listener-show-prompt self)
141                       #f)])
142            (let loop ()
143              (update! (ref self 'rbuf) (cut string-trim <> #[\s]))
144              (and (not (string-null? (ref self 'rbuf)))
145                   (complete-sexp? (ref self 'rbuf))
146                   (begin
147                     (with-input-from-string (ref self 'rbuf)
148                       (^[]
149                         (let1 expr ((ref self 'reader))
150                           (when (eof-object? expr) (finish))
151                           (receive r
152                               ((ref self 'evaluator) expr
153                                (ref self 'environment))
154                             (guard (e [(sigpipe? e) (abort e)])
155                               (apply (ref self 'printer) r)
156                               (flush)))
157                           (set! (ref self 'rbuf)
158                                 (get-remaining-input-string
159                                  (current-input-port))))))
160                     (and (listener-show-prompt self)
161                          (loop))))))))))
162
163  ;; Capture std ports when the handler is created
164  (set! (ref self 'original-input-port)  (current-input-port))
165  (set! (ref self 'original-output-port) (current-output-port))
166  (set! (ref self 'original-error-port)  (current-error-port))
167
168  ;; Returns a handler closure.
169  (^[]
170    (cond [(call/cc body) => raise]
171          [else #t]))
172  )
173
174;;;
175;;; Private utils
176;;;
177
178(define-method listener-finalize ((self <listener>))
179  (and-let* ([f (ref self 'finalizer)])
180    (with-ports
181        (ref self 'original-input-port)
182        (ref self 'original-output-port)
183        (ref self 'original-error-port)
184      f)))
185
186(define-method listener-fatal ((self <listener>) e)
187  (and-let* ([f (ref self 'fatal-handler)])
188    (with-ports
189        (ref self 'original-input-port)
190        (ref self 'original-output-port)
191        (ref self 'original-error-port)
192      (cut f e))))
193
194(define (sigpipe? e)
195  (cond-expand
196   [gauche.os.windows #f]
197   [else (and (<unhandled-signal-error> e)
198              (eqv? (ref e 'signal) SIGPIPE))]))
199
200