source: project/release/4/dissector/dissection.scm @ 12396

Last change on this file since 12396 was 12396, checked in by felix winkelmann, 12 years ago

proper fix for overview-printing, by Taylor

File size: 8.7 KB
Line 
1;;;;;; Dissection state
2
3;;; Copyright (C) 2004, Taylor Campbell
4;;; All rights reserved.
5;;; See the LICENCE file for details.
6
7(define-record-type rtd/dissection
8  (make-dissection focus menu history quit-cont inport outport)
9  dissection?
10  (focus dissection-focus set-dissection-focus!)
11  (menu dissection-menu set-dissection-menu!)
12  (history dissection-history set-dissection-history!)
13  (quit-cont dissection-quit-cont)
14  (inport dissection-inport)
15  (outport dissection-outport))
16
17(define (dissection-push! dissection object)
18  (set-dissection-history! dissection
19                           (cons (dissection-focus dissection)
20                                 (dissection-history dissection)))
21  (set-dissection-focus! dissection object)
22  (set-dissection-menu! dissection (prepare-dissection-menu object)))
23
24(define (dissection-pop! dissection)
25  (let ((history (dissection-history dissection)))
26    (if (null? history)
27        (error "No more objects in dissection's history" dissection)
28        (let ((focus (car history)))
29          (set-dissection-history! dissection (cdr history))
30          (set-dissection-focus! dissection focus)
31          (set-dissection-menu! dissection
32                                (prepare-dissection-menu focus))))))
33
34(define (dissection-pop-multiple! dissection count)
35  (let ((history (dissection-history dissection)))
36    (cond ((maybe-drop history (- count 1))
37           => (lambda (history*)
38                (let ((focus (car history*)))
39                  (set-dissection-history! dissection (cdr history*))
40                  (set-dissection-focus! dissection focus)
41                  (set-dissection-menu!
42                   dissection (prepare-dissection-menu focus)))))
43          (else
44           (error "Too many history elements popped" count)))))
45
46
47
48;;; --------------------
49;;; Evaluating Scheme code, manipulating the focus object
50
51(define (dissection-apply dissection expression)
52  (call-with-values (lambda ()
53                      (eval expression (interaction-environment)))
54    (case-lambda
55      ((function)
56       (receive results
57                (function (dissection-focus dissection))
58         (let ((port (dissection-outport dissection)))
59           (cond ((null? results)
60                  (display "; No values retrned" port))
61                 ((null? (cdr results))
62                  (write (car results) port))
63                 (else
64                  (display "; " port)
65                  (write (length results) port)
66                  (display " values returned" port)
67                  (for-each (lambda (result)
68                              (newline port)
69                              (write result port))
70                            results)))
71           (newline port)
72           (flush-output port))))
73      (results
74       (error "Wrong number of values returned"
75              results)))))
76
77(define (dissection-apply/dissect dissection expression)
78  (call-with-values (lambda ()
79                      (eval expression (interaction-environment)))
80    (case-lambda
81      ((function)
82       (receive results
83                (function (dissection-focus dissection))
84         (cond ((null? results)
85                (error "Can't dissect zero values"))
86               ((null? (cdr results))
87                (dissection-push! dissection (car results))
88                (display-dissection dissection))
89               (else
90                (let ((port (dissection-outport dissection)))
91                  (display "; Dissecting " port)
92                  (write (length results)  port)
93                  (display " values"       port)
94                  (newline                 port)
95                  (dissection-push! dissection results)
96                  (display-dissection dissection))))))
97      (results
98       (error "Wrong number of values returned"
99              results)))))
100
101
102
103;;; --------------------
104;;; Printing the dissection state
105
106(define (display-dissection dissection)
107  (let ((port (dissection-outport dissection)))
108    ((dissection-overview-printer) (dissection-focus dissection) port)
109    (if (not (undissectable? (dissection-focus dissection)))
110        (display-dissection-menu (dissection-menu dissection) port))))
111
112
113
114;;; --------------------
115;;; Main dissection loop
116
117(define (dissection-loop dissection)
118  (let ((inport  (dissection-inport  dissection))
119        (outport (dissection-outport dissection)))
120    (let loop ()
121      (display (dissection-prompt) outport)
122      (flush-output outport)
123      (read-dissection-command inport
124        (lambda stuff                   ; EOF case: throw back to where
125          ((dissection-quit-cont        ;   the original dissection
126            dissection)                 ;   occurred.
127           (lambda () (apply values stuff))))
128                       
129        (lambda (line)                  ; Invalid line case: retry
130          ;; Debugging changes/additions are marked with ;++
131          (display "Invalid dissection command line" outport)
132          (write-char
133;++        #\:
134           #\.
135           outport)
136          (newline outport)
137;++       (display "    " outport)
138;++       (display line outport)
139;++       (newline outport)
140          (flush-output outport)
141          (loop))
142        loop                            ; Blank line case
143        (lambda (command-name args)     ; Success case
144          (carefully-handle-dissection-command command-name dissection
145                                               args)
146          (loop))))))
147
148
149
150;;; --------------------
151;;; Dissector commands
152
153;;; General dissection commands
154
155(define-dissection-command 'print '(p)
156  "Prints out the entirety of the current dissection."
157  #f #f
158  0
159  display-dissection)
160
161(define-dissection-command 'overview '(o)
162  "Prints the focus value, without a menu."
163  #f #f
164  0
165  (lambda (dissection)
166    ((dissection-overview-printer)
167     (dissection-focus dissection)
168     (dissection-outport dissection))))
169
170(define-dissection-command 'up '(u)
171  "Moves back up the history of dissected objects."
172  "[<count>]"
173  '("Moves COUNT elements back up the history of dissected objects."
174    "If COUNT is absent, it defaults to 1.")
175  '(0 1)
176  (case-lambda
177    ((dissection)
178     (dissection-pop! dissection)
179     (display-dissection dissection))
180    ((dissection count)
181     (cond ((not (and (integer? count)
182                      (exact?   count)
183                      (<=   0   count)))
184            (error "Invalid count"
185                   '(expected exact nonnegative integer)))
186           ((= count 1)
187            (dissection-pop! dissection))
188           ((not (zero? count))
189            (dissection-pop-multiple! dissection count)))
190     (display-dissection dissection))))
191
192(define-dissection-command 'history '(h)
193  "Prints the dissection history."
194  #f #f
195  0
196  (lambda (dissection)
197    (let ((port (dissection-outport dissection)))
198      (call-with-limited-output-port port (dissector-right-margin)
199        (lambda (port)
200          (write (dissection-history dissection) port)))
201      (newline port)
202      (flush-output port))))
203
204(define-dissection-command 'quit '(q exit)
205  "Quits the dissection."
206  #f #f
207  0
208  (lambda (dissection)
209    ((dissection-quit-cont dissection) unspecific)))
210
211
212
213;;; Evaluating Scheme code, manipulating the focus object
214
215(define-dissection-command 'eval '(e scheme)
216  "Evaluates an expression."
217  "<expression>"
218  '("Evalutes EXPRESSION in the interaction environment and prints the"
219    "results.  This does not modify the current dissection.")
220  1
221  (lambda (dissection expression)
222    (dissection-apply dissection
223                      `(lambda (,(gensym)) ,expression))))
224
225(define-dissection-command 'apply '(a)
226  "Apply a function to the focus object."
227  "<expression>"
228  '("Evaluates EXPRESSION in the interaction environment, which should"
229    "produce a unary function, and applies it to the current focus"
230    "object.  This does not modify the current dissection.")
231  1
232  dissection-apply)
233
234(define-dissection-command 'dissect '(d)
235  "Dissect a completely new object."
236  "<expression>"
237  '("Evaluates EXPRESSION in the interaction environment and dissects"
238    "the value that is produced.  EXPRESSION may evaluate to one or"
239    "more values.  With one value, that value is dissected; with more,"
240    "a list of the values is dissected.")
241  1
242  (lambda (dissection expression)
243    (dissection-apply/dissect dissection
244                              `(lambda (,(gensym)) ,expression))))
245
246(define-dissection-command 'apply/dissect '(ad)
247  "Apply a function to the focus object & dissect its result."
248  "<expression>"
249  '("Evaluates EXPRESSION in the interaction environment, which should"
250    "produce a unary function, and applies it to the current focus"
251    "object.  It must return at least one value.  If it returns one"
252    "value, that value is dissected; if it returns more than one, a"
253    "list containing the values is dissected.")
254  1
255  dissection-apply/dissect)
Note: See TracBrowser for help on using the repository browser.