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

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

Bug fix for procedure-information is-a symbol. Chgd 'identifier back to 'variable.

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