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

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

Use of core immutable.

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