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

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

Added safe/unsafe, sorting, qualified symbols.

File size: 13.2 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;; - Use of Unit lolevel 'global-' routines is just wrong when an
8;; evaluation-environment (##sys#environment?) is not the
9;; interaction-environment.
10;;
11;; - Doesn't show something similar to procedure-information for macros.
12;;
13;; - Runtime macros?
14;;
15;; - Should be re-written to use the "environments" extension. Which in turn would
16;; need to support syntactic environments, at least for lookup opertations.
17;;
18;; - The Chicken 'environment' object does not hold the (syntactic) bindings
19;; for all syntactic keywords from the R5RS. The public API of 'apropos'
20;; attempts to hide this fact.
21
22;;; Prelude
23
24(declare
25  (usual-integrations)
26  #;(disable-interrupts)
27  (fixnum)
28  (inline)
29  (local)
30  (no-procedure-checks)
31  (bound-to-procedure
32    ##sys#qualified-symbol? ##sys#symbol->qualified-string ##sys#qualified-symbol-prefix
33    ##sys#symbol->string
34    ##sys#current-environment ##sys#macro-environment
35    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
36    ##sys#environment? ##sys#environment-symbols
37    ##sys#signal-hook))
38
39;;
40
41(cond-expand
42  (unsafe
43    (include "chicken-primitive-object-inlines") )
44  (else ) )
45
46;; Argument Checking
47
48(define-inline (%check-search-pattern loc obj argnam)
49  (unless (or (string? obj) (and (symbol? obj) (not (keyword? obj))) (regexp? obj))
50    (error-invalid-search loc obj argnam) ) )
51
52(define-inline (%check-environment loc obj argnam)
53  (unless (or (##sys#environment? obj) (##sys#syntactic-environment? obj))
54    (error-invalid-environment loc obj argnam) ) )
55
56(define-inline (%check-environment* loc obj argnam)
57  (cond ((##sys#environment? obj) #f)
58        ((##sys#syntactic-environment? obj) obj)
59        (else
60          (error-invalid-environment loc obj argnam) ) ) )
61
62;;;
63
64(require-library regex lolevel data-structures)
65
66(module apropos (;export
67  ; Original
68  apropos
69  apropos-list
70  apropos-information-list
71  ; Crispy
72  apropos/environment
73  apropos-list/environment
74  apropos-information-list/environment
75  ; Extra Crispy
76  apropos/environments
77  apropos-list/environments
78  apropos-information-list/environments)
79
80(import scheme chicken regex lolevel data-structures)
81
82;;; Support
83
84;; Errors
85
86(define (error-argument-type loc obj kndnam #!optional argnam)
87  (##sys#signal-hook
88    #:type-error
89    loc
90    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
91    obj) )
92
93(define (error-invalid-search loc obj argnam)
94  (error-argument-type loc obj "symbol/string/regexp" argnam) )
95
96(define (error-invalid-environment loc obj argnam)
97  (error-argument-type loc obj 'environment argnam) )
98
99(define (error-type-procedure loc obj argnam)
100  (error-argument-type loc obj 'procedure argnam) )
101
102;; Symbols
103
104(define (symbol<? x y)
105  (cond-expand
106    (unsafe
107      (%string<? (%symbol-string x) (%symbol-string y)) )
108    (else
109      (let ((x (##sys#symbol->string x))
110            (y (##sys#symbol->string y))
111            (px (##sys#qualified-symbol-prefix x))
112            (py (##sys#qualified-symbol-prefix y)))
113        (cond (px (and py (string<? px py) (string<? x y)))
114              (py (or (not px) (and (string<? px py) (string<? x y))))
115              (else (string<? x y) ) ) ) ) ) )
116
117(define (symbol-print-length sym)
118  (cond-expand
119    (unsafe
120      (let ((siz (%string-size (%symbol-string sym))))
121              ; assumes keyword style is not #:none
122        (cond ((%keyword? sym) siz)
123              ; compensate for the '##'
124              ((%qualified-symbol? sym) (%fx+ siz 2))
125              ; plain old string
126              (else siz) ) ) )
127    (else
128      (let ([len (string-length (##sys#symbol->qualified-string sym))])
129        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
130            len ) ) ) ) )
131
132(define (max-symbol-print-width syms)
133  (let ((maxlen 0))
134    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
135    maxlen ) )
136
137(define (symbol-match? sym regexp)
138  (cond-expand
139    (unsafe
140      (string-search regexp (%symbol-string sym)) )
141    (else
142      (string-search regexp (symbol->string sym)) ) ) )
143
144;; Environment Search
145
146(define (search-environment/searcher searcher env regexp pred lessp)
147  (let ((syms (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym))))))
148    (if lessp (sort syms lessp)
149        syms ) ) )
150
151(define (search-environment env regexp pred lessp)
152  (search-environment/searcher ##sys#environment-symbols env regexp pred lessp) )
153
154(define (search-macro-environment macenv regexp pred lessp)
155  (search-environment/searcher ##sys#syntactic-environment-symbols macenv regexp pred lessp) )
156
157(define (environment-predicate qualified?)
158  (if qualified? global-bound?
159      (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))) ) )
160
161(define (macro-environment-predicate qualified?)
162  (if qualified? any?
163      (lambda (x) (not (##sys#qualified-symbol? x))) ) )
164
165(define (*apropos-list loc regexp env macenv qualified? lessp)
166  (append
167   (search-environment env regexp (environment-predicate qualified?) lessp)
168    (if (not macenv) '()
169        (search-macro-environment macenv regexp (macro-environment-predicate qualified?) lessp))) )
170
171(define (*apropos-list/environment loc regexp env macenv? qualified? lessp)
172  (if macenv? (search-macro-environment env regexp (macro-environment-predicate qualified?) lessp))
173      (search-environment env regexp (environment-predicate qualified?) lessp) )
174
175;; Argument List Parsing
176
177(define default-environment interaction-environment)
178(define default-macro-environment ##sys#macro-environment)
179
180(define (make-apropos-regexp patt)
181  (when (symbol? patt) (set! patt (symbol->string patt)))
182  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
183  patt )
184
185; #!optional (env (default-environment)) macenv
186; #!key macros? qualified? sort?
187;
188; macenv is #t for default macro environment or a syntactic-environment object.
189;
190; => (values macenv syms)
191
192(define (parse-arguments loc patt args)
193
194  (define (parse-rest-arguments)
195    (let ((env (default-environment))
196          (macenv #f)
197          (qualified? #f)
198          (lessp #f)
199          (1st-optarg #t)) ;keyword argument not considered an optional argument here
200      (let loop ((args args))
201        (if (null? args) (values env macenv qualified? lessp)
202            (let ((arg (car args)))
203                    ;keyword argument?
204              (cond ((eq? #:macros? arg)
205                      (when (cadr args) (set! macenv (default-macro-environment)))
206                      (loop (cddr args)) )
207                    ((eq? #:qualified? arg)
208                      (when (cadr args) (set! qualified? #t))
209                      (loop (cddr args)) )
210                    ((eq? #:sort? arg)
211                      (and-let* ((lsp (cadr args)))
212                        (set! lessp
213                          (cond ((boolean? lsp) symbol<?)
214                                ((procedure? lsp) lsp)
215                                (else
216                                  (error-type-procedure loc lsp #:sort?)))))
217                      (loop (cddr args)) )
218                    ;optional argument?
219                    (arg
220                           ;specific environment?
221                      (cond (1st-optarg (set! env arg) (set! 1st-optarg #f))
222                            ;default macro environment?
223                            ((boolean? args) (set! macenv (default-macro-environment)))
224                            ;specific macro environment?
225                            (else (set! macenv arg)))
226                      (loop (cdr args)) )
227                    ;accept #f for macenv
228                    (else
229                      (loop (cdr args)) ) ) ) ) ) ) )
230
231  (%check-search-pattern loc patt 'pattern)
232  (receive (env macenv qualified? lessp) (parse-rest-arguments)
233    (%check-environment loc env 'environment)
234    (when macenv (%check-environment loc macenv #:macros?))
235    (values macenv (*apropos-list loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
236
237; => (values macenv syms)
238
239(define (parse-arguments/environment loc patt env qualified? lessp)
240  (%check-search-pattern loc patt 'pattern)
241  (when (and lessp (not (procedure? lessp))) (error-type-procedure loc lessp #:sort?))
242  (let ((macenv (%check-environment* loc env 'environment)))
243    (values macenv (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified? lessp)) ) )
244
245; #!key qualified? sort?
246;
247; => (... (macenv . syms) ...)
248
249(define (parse-arguments/environments loc patt args)
250
251  (define (parse-rest-arguments)
252    (let ((qualified? #f)
253          (lessp #f))
254      (let loop ((args args) (envs '()))
255        (if (null? args) (values (reverse envs) qualified? lessp)
256            (let ((arg (car args)))
257                    ;keyword argument?
258              (cond ((eq? #:qualified? arg)
259                      (when (cadr args) (set! qualified? #t))
260                      (loop (cddr args) envs) )
261                    ((eq? #:sort? arg)
262                      (and-let* ((lsp (cadr args)))
263                        (set! lessp
264                          (cond ((boolean? lsp) symbol<?)
265                                ((procedure? lsp) lsp)
266                                (else
267                                  (error-type-procedure loc lsp #:sort?)))))
268                      (loop (cddr args) envs) )
269                    (else
270                      (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
271
272  (%check-search-pattern loc patt 'pattern)
273  (receive (envs qualified? lessp) (parse-rest-arguments)
274    (let ((regexp (make-apropos-regexp patt)))
275      (let loop ((envs envs) (envsyms '()))
276        (if (null? envs) (reverse envsyms)
277            (let* ((env (car envs))
278                   (macenv (%check-environment* loc env 'environment))
279                   (make-envsyms
280                    (lambda ()
281                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified? lessp)) ) ) )
282              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
283
284
285;; Display
286
287(define (apropos-procedure-information proc)
288  (let ((info (procedure-information proc)))
289    (cond ((not info) 'procedure)
290          ((pair? info) `(procedure . ,(cdr info)))
291          (else `(procedure . ,(symbol->string info))) ) ) )
292
293(define (apropos-information sym macenv)
294  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
295        ((keyword? sym) 'keyword)
296        (else
297          (let ((binding (global-ref sym)))
298            (if (procedure? binding) (apropos-procedure-information binding)
299                'variable ) ) ) ) )
300
301(define (display-spaces cnt)
302  (do ((i cnt (sub1 i)))
303      ((negative? i))
304    (display #\space) ) )
305
306(define (display-symbol-information sym maxsymlen macenv)
307  (display sym) (display-spaces (- maxsymlen (symbol-print-length sym)))
308  (let ((info (apropos-information sym macenv)))
309    (display #\space)
310    (if (symbol? info) (display info)
311        (begin (display (car info)) (display #\space) (write (cdr info)) ) ) )
312  (newline) )
313
314;;; API
315
316;; Original
317
318(define (apropos patt . args)
319  (receive (macenv syms) (parse-arguments 'apropos patt args)
320    (let ((maxsymlen (max-symbol-print-width syms)))
321      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
322
323(define (apropos-list patt . args)
324  (receive (macenv syms) (parse-arguments 'apropos-list patt args)
325    syms ) )
326
327(define (apropos-information-list patt . args)
328  (receive (macenv syms) (parse-arguments 'apropos-information-list patt args)
329    (map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )
330
331;; Crispy
332
333(define (apropos/environment patt env #!key qualified? (sort? symbol<?))
334  (receive (macenv syms)
335           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
336    (let ((maxsymlen (max-symbol-print-width syms)))
337      (newline)
338      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
339
340(define (apropos-list/environment patt env #!key qualified? (sort? symbol<?))
341  (receive (macenv syms)
342           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
343    syms ) )
344
345(define (apropos-information-list/environment patt env #!key qualified? (sort? symbol<?))
346  (receive (macenv syms)
347           (parse-arguments/environment 'apropos/environment patt env qualified? sort?)
348    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
349
350;; Extra Crispy
351
352(define (apropos/environments patt . args)
353  (let ((i 0))
354    (for-each
355      (lambda (macenv+syms)
356        (set! i (add1 i))
357        (newline) (print "** Environment " i " **") (newline)
358        (let ((macenv (car macenv+syms))
359              (syms (cdr macenv+syms)))
360          (let ((maxsymlen (max-symbol-print-width syms)))
361            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
362      (parse-arguments/environments 'apropos/environments patt args)) ) )
363   
364(define (apropos-list/environments patt . args)
365  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
366
367(define (apropos-information-list/environments patt . args)
368  (map
369    (lambda (macenv+syms)
370      (let ((macenv (car macenv+syms)))
371        (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) )
372    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
373
374) ;module apropos
Note: See TracBrowser for help on using the repository browser.