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

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

ported to chicken-4

File size: 6.1 KB
Line 
1;;;;;; Menus: displays of an object's components
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-menu
8  (make-dissection-menu entries index)
9  dissection-menu?
10  (entries dissection-menu-entries set-dissection-menu-entries!)
11  (index dissection-menu-index set-dissection-menu-index!))
12
13(define (prepare-dissection-menu object)
14  (make-dissection-menu (dissect-components object) 0))
15
16(define (shift-dissection-menu! menu count)
17  (let ((index (+ (dissection-menu-index menu) count)))
18    (cond ((and (negative? count)
19                (negative? index))
20           (error "Shifted menu too far backwards"))
21          ((and (not (negative? count))
22                (stream-length<? (dissection-menu-entries menu)
23                                 index))
24           (error "Shifted menu too far forwards"))
25          (else
26           (set-dissection-menu-index! menu index)))))
27
28(define (dissection-select1 dissection index)
29  (let ((focus (dissection-focus dissection)))
30    (cond ((undissectable? focus)
31           (error "Can't dissect further into undissectable"))
32          ((stream-maybe-drop (dissection-menu-entries
33                               (dissection-menu dissection))
34                              index)
35           => (lambda (tail)
36                (cond ((stream-null? tail)
37                       (error "Dissection index out of bounds" index))
38                      (else
39                       (dissection-push! dissection
40                                         (cdr (stream-car tail)))
41                       (display-dissection dissection)))))
42          (else (error "Dissection index out of bounds")))))
43
44(define (dissection-select2+ dissection indices)
45  (let loop ((indices indices) (index-count 0))
46    (if (null? indices)
47        (display-dissection dissection)
48        (let ((focus   (dissection-focus dissection))
49              (index1  (car indices))
50              (index2+ (cdr indices)))
51          (cond ((undissectable? focus)
52                 (error "Can't dissect further into undissectable"))
53                ((stream-maybe-drop (dissection-menu-entries
54                                     (dissection-menu dissection))
55                                    index1)
56                 => (lambda (tail)
57                      (cond ((stream-null? tail)
58                             (error "Dissection index out of bounds"))
59                            (else
60                             (dissection-push! dissection
61                                               (cdr (stream-car tail)))
62                             (loop index2+ (+ index-count 1))))))
63                (else
64                 (error "Dissection index out of bounds"
65                        `(after selecting further into object
66                          ,index-count times))))))))
67
68
69
70;;; --------------------
71;;; Displaying the menus
72
73(define (display-dissection-menu menu port)
74  (let* ((origin (dissection-menu-index menu))
75         (padding-width
76          (string-length (number->string
77                          ;; Get the length of the biggest index to be
78                          ;; printed in this menu section.
79                          (+ origin (dissection-menu-section-size))))))
80    (let loop ((entries (stream-drop (dissection-menu-entries menu)
81                                     origin))
82               (index origin))
83      (cond ((stream-null? entries) #t)
84            ((>= (- index origin) (dissection-menu-section-size))
85             (display "(more)" port)
86             (newline port))
87            (else
88             (receive (e1 e2+)
89                      (stream-car+cdr entries)
90               (display-dissected-entry e1 index padding-width port)
91               (loop e2+ (+ index 1))))))
92    (flush-output port)))
93
94(define (display-dissected-entry entry index padding-width port)
95  (display "  [" port)
96  (display (pad-string (number->string index 10) padding-width) port)
97  (cond ((car entry)
98         => (lambda (name)
99              (display ": " port)
100              (write name port))))
101  (display "] " port)
102  ((dissection-menu-entry-printer)
103   (cdr entry)
104   (+ padding-width
105      (cond ((car entry)
106             (+ (string-length (->string (car entry)))
107                2))                     ; ": "
108            (else 0))
109      3                                 ; "  ["
110      2)                                ; "] "
111   port)
112  (newline port))
113
114
115
116;;; --------------------
117;;; Menu-related dissector commands
118
119(define-dissection-command 'menu '(m)
120  "Prints just the current menu."
121  #f #f
122  0
123  (lambda (dissection)
124    (if (undissectable? (dissection-focus dissection))
125        (error "No subcomponents in object to make menu of")
126        (display-dissection-menu (dissection-menu dissection)
127                                 (dissection-outport dissection)))))
128
129(define-dissection-command 'walk '(w)
130  "Walks up and down the focus object's component menu."
131  "[<slot-count>]"
132  '("Moves the current menu selection by SLOT-COUNT.  If SLOT-COUNT is"
133    "negative, the menu is moved backwards; if it's positive, it is"
134    "moved forwards.  If it is absent, the menu is moved forward by"
135    "(dissection-menu-section-size) slots.")
136  '(0 1)
137  (letrec ((walk
138            (case-lambda
139              ((dissection)
140               (walk dissection (dissection-menu-section-size)))
141              ((dissection slot-count)
142               (let ((menu (dissection-menu dissection)))
143                 (shift-dissection-menu!  menu slot-count)
144                 (display-dissection-menu menu
145                   (dissection-outport dissection)))))))
146    walk))
147
148(define-dissection-command 'select '(s)
149  "Selects a component of the focus object to dissect."
150  "<index> [<deep-index> ...]"
151  '("Selects the INDEX'th slot in the focus object to dissect next."
152    "INDEX must be a valid index into the focus object, as shown by"
153    "the menu.  If more than one index is passed, it is as if the"
154    "select command were applied multiple times, to each successive"
155    "index.")
156  -2
157  (case-lambda
158    ((dissection index)
159     (dissection-select1 dissection index))
160    ((dissection index . indices)
161     (dissection-select2+ dissection (cons index indices)))))
Note: See TracBrowser for help on using the repository browser.