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

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

Comments, reflow, defaults vars, ##sys#macro?

File size: 10.7 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    (if (not info) 'procedure
227        `(procedure . ,(cdr info)) ) ) )
228
229(define (apropos-information sym macenv)
230  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
231        ((keyword? sym) 'keyword)
232        (else
233          (let ((binding (global-ref sym)))
234            (if (procedure? binding) (apropos-procedure-information binding)
235                'identifier ) ) ) ) )
236
237(define (display-spaces cnt)
238  (do ((i cnt (sub1 i)))
239      ((negative? i))
240    (display #\space) ) )
241
242(define (display-symbol-information sym maxsymlen macenv)
243  (display sym) (display-spaces (- maxsymlen (symbol-string-length sym)))
244  (let ((info (apropos-information sym macenv)))
245    (display #\space)
246    (if (symbol? info) (display info)
247        (begin (display (car info)) (display #\space) (display (cdr info)) ) ) )
248  (newline) )
249
250;;; API
251
252;; Original
253
254(define (apropos patt . args)
255  (receive (macenv syms) (parse-arguments 'apropos patt args)
256    (let ((maxsymlen (max-symbol-print-width syms)))
257      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
258
259(define (apropos-list patt . args)
260  (receive (macenv syms) (parse-arguments 'apropos-list patt args)
261    syms ) )
262
263(define (apropos-information-list patt . args)
264  (receive (macenv syms) (parse-arguments 'apropos-information-list patt args)
265    (map (lambda (sym) (list sym (apropos-information sym macenv))) syms) ) )
266
267;; Crispy
268
269(define (apropos/environment patt env #!key qualified?)
270  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
271    (let ((maxsymlen (max-symbol-print-width syms)))
272      (newline)
273      (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
274
275(define (apropos-list/environment patt env #!key qualified?)
276  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
277    syms ) )
278
279(define (apropos-information-list/environment patt env #!key qualified?)
280  (receive (macenv syms) (parse-arguments/environment 'apropos/environment patt env qualified?)
281    (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) ) )
282
283;; Extra Crispy
284
285(define (apropos/environments patt . args)
286  (let ((i 0))
287    (for-each
288      (lambda (macenv+syms)
289        (set! i (add1 i))
290        (newline) (print "** Environment " i " **") (newline)
291        (let ((macenv (car macenv+syms))
292              (syms (cdr macenv+syms)))
293          (let ((maxsymlen (max-symbol-print-width syms)))
294            (for-each (cut display-symbol-information <> maxsymlen macenv) syms) ) ) )
295      (parse-arguments/environments 'apropos/environments patt args)) ) )
296   
297(define (apropos-list/environments patt . args)
298  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
299
300(define (apropos-information-list/environments patt . args)
301  (map
302    (lambda (macenv+syms)
303      (let ((macenv (car macenv+syms)))
304        (map (lambda (sym) (cons sym (apropos-information sym macenv))) (cdr macenv+syms)) ) )
305    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
306
307) ;module apropos
Note: See TracBrowser for help on using the repository browser.