source: project/release/4/apropos/trunk/apropos.scm @ 13715

Last change on this file since 13715 was 13715, checked in by Kon Lovett, 11 years ago

Save.

File size: 10.5 KB
Line 
1;;;; apropos.scm -*- Hen -*-
2;;;; Kon Lovett, Mar '09
3;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
4
5;; Issues
6;;
7;; - Doesn't show something similar to procedure-information for macros.
8;;
9;; - Runtime macros?
10;;
11;; - Should be re-written to use the "environments" extension. Which in turn would
12;; need to support syntactic environments, at least for lookup opertations.
13
14;;; Prelude
15
16(declare
17  (usual-integrations)
18  (disable-interrupts)
19  (fixnum)
20  (inline)
21  (local)
22  (no-procedure-checks)
23  (bound-to-procedure
24    ##sys#current-environment ##sys#syntactic-environment? ##sys#syntactic-environment-symbols
25    ##sys#environment? ##sys#environment-symbols
26    ##sys#qualified-symbol? ##sys#symbol->qualified-string
27    ##sys#signal-hook ) )
28
29;;; Support
30
31;; Argument Checking
32
33(define-inline (%check-environment loc obj)
34  (unless (##sys#environment? obj)
35    (error-invalid-environment loc obj) ) )
36
37(define-inline (%check-macro-environment loc obj)
38  (unless (or (not obj) (##sys#syntactic-environment? obj))
39    (error-invalid-macro-environment loc obj) ) )
40
41(define-inline (%check-search-pattern loc obj)
42  (unless (or (string? obj) (symbol? obj) (regexp? obj))
43    (error-invalid-search loc patt) ) )
44
45;;;
46
47(require-library regex lolevel data-structures)
48
49(module apropos (;export
50  ; Original
51  apropos
52  apropos-list
53  apropos-information-list
54  ; Crispy
55  apropos/environment
56  apropos-list/environment
57  apropos-information-list/environment
58  ; Extra Crispy
59  apropos/environments
60  apropos-list/environments
61  apropos-information-list/environments)
62
63(import scheme chicken regex lolevel data-structures)
64
65;;; Suuport
66
67;; Errors
68
69(define-inline (error-invalid-search loc obj)
70  (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" obj) )
71
72(define-inline (error-invalid-environment loc obj)
73  (##sys#signal-hook #:type-error loc "bad argument type - not an environment" obj) )
74
75(define-inline (error-invalid-macro-environment loc obj)
76  (##sys#signal-hook #:type-error loc "bad argument type - not a macro environment" obj) )
77
78(define-inline (error-invalid-any-environment loc obj)
79  (##sys#signal-hook #:type-error loc "bad argument type - not an environment or macro environment" obj) )
80
81;;
82
83(define (check-any-environment/->syntactic-environment? loc obj)
84  (cond ((##sys#environment? obj)           #f)
85        ((##sys#syntactic-environment? obj) obj)
86        (else
87          (error-invalid-any-environment loc obj) ) ) )
88
89;; Symbols
90
91(define (symbol-string-length sym)
92  (let ((len (string-length (##sys#symbol->qualified-string sym))))
93    (if (keyword? sym) (- len 2) ;compensate for leading '##'
94        len ) ) )
95
96(define (max-symbol-print-width syms)
97  (let ((maxlen 0))
98    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-string-length sym)))) syms)
99    maxlen ) )
100
101(define (symbol-match? sym regexp) (string-search regexp (symbol->string sym)))
102
103;; Environment Search
104
105(define (search-environment env regexp pred)
106  (##sys#environment-symbols
107    env
108    (lambda (sym)
109      (and (symbol-match? sym regexp) (pred sym)))) )
110
111(define (search-macro-environment macenv regexp pred)
112  (##sys#syntactic-environment-symbols
113    macenv
114    (lambda (sym)
115      (and (symbol-match? sym regexp) (pred sym)))) )
116
117;; Environment Search -> List
118
119(define (*apropos-list loc regexp env macenv qualified?)
120  (append
121   (search-environment
122     env
123     regexp
124     (if qualified? global-bound?
125         (lambda (x)
126           (and (not (##sys#qualified-symbol? x)) (global-bound? x)))))
127    (if (not macenv) '()
128        (search-macro-environment
129         macenv
130         regexp
131         (if qualified? any?
132             (lambda (x)
133               (not (##sys#qualified-symbol? x))))))) )
134
135(define (*apropos-list/environment loc regexp env macenv qualified?)
136  (if macenv (search-macro-environment env regexp #f)
137      (search-environment
138        env
139        regexp
140        (if qualified? global-bound?
141            (lambda (x)
142              (and (not (##sys#qualified-symbol? x)) (global-bound? x)) ) ) ) ) )
143
144;; Argument List Parsing
145
146(define (make-apropos-regexp patt)
147  (when (symbol? patt) (set! patt (symbol->string patt)))
148  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
149  patt )
150
151; #!optional (env (interaction-environment)) macenv
152; #!key macros? qualified?
153;
154; macenv is #t for default macro environment (##sys#current-environment) or a
155; syntactic-environment object.
156;
157; => (values macenv qualified? syms)
158(define (parse-arguments loc patt args)
159  (define (parse-rest-arguments args)
160    (let ((env (interaction-environment))
161          (macenv #f)
162          (qualified? #f)
163          (1st-optarg #t)) ;keyword argument not considered an optional argument here
164      (let loop ((args args))
165        (if (null? args) (values env qualified? macenv)
166            (let ((arg (car args)))
167                    ;keyword argument?
168              (cond ((eq? #:macros? arg)
169                      (when (cadr args) (set! macenv (##sys#current-environment)))
170                      (loop (cddr args)) )
171                    ((eq? #:qualified? arg)
172                      (when (cadr args) (set! qualified? #t))
173                      (loop (cddr args)) )
174                    ;optional argument?
175                    (arg
176                           ;specific environment?
177                      (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
178                            ;default macro environment?
179                            ((boolean? args) (set! macenv (##sys#current-environment)))
180                            ;specific macro environment?
181                            (else (set! macenv arg)))
182                      (loop (cdr args)) )
183                    ;accept #f for macenv
184                    (else
185                      (loop (cdr args)) ) ) ) ) ) ) )
186  (%check-search-pattern loc patt)
187  (receive (env macenv qualified?) (parse-rest-arguments args)
188    (%check-environment loc env)
189    (%check-macro-environment loc macenv)
190    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?)) ) )
191
192; => (values macenv syms)
193(define (parse-arguments/environment loc patt env qualified?)
194  (%check-search-pattern loc patt)
195  (let ((macenv (check-any-environment/->syntactic-environment? loc env)))
196    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?)) ) )
197
198; => (... (macenv . syms) ...)
199(define (parse-arguments/environments loc patt args)
200  (define (parse-rest-arguments args)
201    (let ((qualified? #f))
202      (let loop ((args args) (envs '()))
203        (if (null? args) (values (reverse envs) qualified?)
204            (let ((arg (car args)))
205                    ;keyword argument?
206              (cond ((eq? #:qualified? arg)
207                      (when (cadr args) (set! qualified? #t))
208                      (loop (cddr args) envs) )
209                    (else
210                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
211  (%check-search-pattern loc patt)
212  (receive (envs qualified?) (parse-rest-arguments args)
213    (let ((regexp (make-apropos-regexp patt)))
214      (let loop ((envs envs) (envsyms '()))
215        (if (null? envs) (reverse envsyms)
216            (let* ((env (car envs))
217                   (macenv (check-any-environment/->syntactic-environment? loc env)) )
218              (loop
219                (cdr envs)
220                (cons
221                  `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?))
222                  envsyms)) ) ) ) ) ) )
223
224
225;; Display
226
227(define (apropos-procedure-information proc)
228  (let ((info (procedure-information proc)))
229    (if (not info) 'procedure
230        `(procedure . ,(cdr info)) ) ) )
231
232(define (apropos-information sym macenv)
233  (cond ((and macenv (macro? sym macenv)) 'macro)
234        ((keyword? sym)                   'keyword)
235        (else
236          (let ((binding (global-ref sym)))
237            (if (procedure? binding) (apropos-procedure-information binding) )
238                'identifier ) ) ) )
239
240(define (display-spaces cnt)
241  (do ((i cnt (sub1 i)))
242      ((negative? i))
243    (display #\space) ) )
244
245(define (display-symbol-information sym maxsymlen macenv)
246  (display sym) (display-spaces (- maxsymlen (symbol-string-length sym)))
247  (let ((info (apropos-information sym macenv)))
248    (display #\space)
249    (if (symbol? info) (display info)
250        (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
251  (newline) )
252
253;;; API
254
255;; Original
256
257(define (apropos patt . args)
258  (receive (macenv syms) (parse-arguments 'apropos patt args)
259    (let ((maxsymlen (max-symbol-print-width syms)))
260      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
261
262(define (apropos-list patt . args)
263  (receive (macenv syms) (parse-arguments 'apropos-list patt args)
264    syms ) )
265
266(define (apropos-information-list patt . args)
267  (receive (macenv syms) (parse-arguments 'apropos-information-list patt args)
268    (map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )
269
270;; Crispy
271
272(define (apropos/environment patt env #!key qualified?)
273  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
274    (let ((maxsymlen (max-symbol-print-width syms)))
275      (newline)
276      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
277
278(define (apropos-list/environment patt env #!key qualified?)
279  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
280    syms ) )
281
282(define (apropos-information-list/environment patt env #!key qualified?)
283  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
284    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
285
286;; Extra Crispy
287
288(define (apropos/environments patt . args)
289  (let ((i 0))
290    (for-each
291      (lambda (macenv+syms)
292        (set! i (add1 i))
293        (newline) (print "** Environment " i " **") (newline)
294        (let ((macenv (car macenv+syms))
295              (syms (cdr macenv+syms)))
296          (let ((maxsymlen (max-symbol-print-width syms)))
297            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
298      (parse-arguments/environments 'apropos/environments patt args)) ) )
299   
300(define (apropos-list/environments patt . args)
301  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
302
303(define (apropos-information-list/environments patt . args)
304  (map
305    (lambda (macenv+syms)
306      (let ((macenv (car macenv+syms)))
307        (map
308          (lambda (sym) (cons sym (apropos-information sym macenv)))
309          (cdr macenv+syms)) ) )
310    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
311
312) ;module apropos
Note: See TracBrowser for help on using the repository browser.