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

Last change on this file since 13748 was 13748, checked in by Kon Lovett, 12 years ago

Rmvd unused disable-interrupts.

File size: 16.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;; - 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  (fixnum)
27  (inline)
28  (local)
29  (no-procedure-checks)
30  (bound-to-procedure
31    ##sys#qualified-symbol? ##sys#symbol->qualified-string ##sys#qualified-symbol-prefix
32    ##sys#symbol->string
33    ##sys#current-environment ##sys#macro-environment
34    ##sys#syntactic-environment? ##sys#syntactic-environment-symbols ##sys#macro?
35    ##sys#environment? ##sys#environment-symbols
36    ##sys#signal-hook))
37
38;;
39
40(cond-expand
41  (unsafe
42    (include "chicken-primitive-object-inlines") )
43  (else ) )
44
45;; Argument Checking
46
47(define-inline (%check-search-pattern loc obj argnam)
48  (cond-expand
49    (unsafe
50      (unless (or (%keyword? obj) (%symbol? obj) (%string? obj) (regexp? obj))
51        (error-invalid-search loc obj argnam) ) )
52    (else
53      (unless (or (keyword? obj) (symbol? obj) (string? obj) (regexp? obj))
54        (error-invalid-search loc obj argnam) ) ) ) )
55
56#; ;UNUSED
57(define-inline (%check-environment* loc obj argnam)
58  (cond ((##sys#environment? obj) #f)
59        ((##sys#syntactic-environment? obj) obj)
60        (else
61          (error-invalid-environment loc obj argnam) ) ) )
62
63(define-inline (%check-sortkey-argument loc obj)
64  (unless (or (not obj) (eq? #:name obj) (eq? #:kind obj))
65    (error-invalid-sortkey loc obj) ) )
66
67;;;
68
69(require-library regex lolevel data-structures ports extras utils srfi-13)
70
71(module apropos (;export
72  ; Original
73  apropos apropos-list apropos-information-list
74  ; Crispy
75  #;apropos/environment #;apropos-list/environment #;apropos-information-list/environment
76  ; Extra Crispy
77  #;apropos/environments #;apropos-list/environments #;apropos-information-list/environments)
78
79(import scheme chicken regex lolevel data-structures ports extras utils srfi-13 csi)
80
81;;; Support
82
83;; Errors
84
85(define (error-argument-type loc obj kndnam #!optional argnam)
86  (##sys#signal-hook
87    #:type-error
88    loc
89    (conc "bad " (if argnam (conc #\` argnam #\') "") " argument type - wanted " kndnam)
90    obj) )
91
92(define (error-invalid-search loc obj argnam)
93  (error-argument-type loc obj "symbol/string/regexp" argnam) )
94
95#; ;UNUSED
96(define (error-invalid-environment loc obj argnam)
97  (error-argument-type loc obj 'environment argnam) )
98
99(define (error-invalid-sortkey loc obj)
100  (error-argument-type loc obj "#:name, #:kind or #f" #:sort) )
101
102(define (error-invalid-argument loc arg)
103  (if (keyword? arg) (error loc "unrecognized keyword argument" arg)
104      (error loc "unrecognized argument" arg) ) )
105
106;; Symbols
107
108(define (symbol->keyword sym)
109  (if (keyword? sym) sym
110      (string->keyword (symbol->string sym)) ) )
111
112(define (symbol=? x y)
113  (cond-expand
114    (unsafe
115      (%string=? (%symbol-string x) (%symbol-string y)) )
116    (else
117      (let ((sx (##sys#symbol->string x))
118            (sy (##sys#symbol->string y))
119            (px (##sys#qualified-symbol-prefix x))
120            (py (##sys#qualified-symbol-prefix y)))
121        (cond (px (and py (string=? px py) (string=? sx sy)))
122              (py (or (not px) (and (string=? px py) (string=? sx sy))))
123              (else (string=? sx sy) ) ) ) ) ) )
124
125(define (symbol<? x y)
126  (cond-expand
127    (unsafe
128      (%string<? (%symbol-string x) (%symbol-string y)) )
129    (else
130      (let ((sx (##sys#symbol->string x))
131            (sy (##sys#symbol->string y))
132            (px (##sys#qualified-symbol-prefix x))
133            (py (##sys#qualified-symbol-prefix y)))
134        (cond (px (and py (string<? px py) (string<? sx sy)))
135              (py (or (not px) (and (string<? px py) (string<? sx sy))))
136              (else (string<? sx sy) ) ) ) ) ) )
137
138(define (symbol-print-length sym)
139  (cond-expand
140    (unsafe
141      (let ((siz (%string-size (%symbol-string sym))))
142              ; assumes keyword style is not #:none
143        (cond ((%keyword? sym) siz)
144              ; compensate for the '##'
145              ((%qualified-symbol? sym) (%fx+ siz 2))
146              ; plain old string
147              (else siz) ) ) )
148    (else
149      (let ([len (string-length (##sys#symbol->qualified-string sym))])
150        (if (keyword? sym) (- len 2) ; compensate for leading '###' when only a ':' is printed
151            len ) ) ) ) )
152
153(define (max-symbol-print-width syms)
154  (let ((maxlen 0))
155    (for-each (lambda (sym) (set! maxlen (fxmax maxlen (symbol-print-length sym)))) syms)
156    maxlen ) )
157
158(define (symbol-match? sym regexp)
159  (cond-expand
160    (unsafe
161      (string-search regexp (%symbol-string sym)) )
162    (else
163      (string-search regexp (symbol->string sym)) ) ) )
164
165;; Environment Search
166
167(define (*apropos-list/environment loc regexp env macenv? qualified?)
168
169  (define (search-environment/searcher searcher pred)
170    (searcher env (lambda (sym) (and (symbol-match? sym regexp) (pred sym)))) )
171
172  (define (search-environment)
173    (search-environment/searcher
174      ##sys#environment-symbols
175      (if qualified? global-bound?
176          (lambda (x) (and (not (##sys#qualified-symbol? x)) (global-bound? x))))) )
177
178  (define (search-macro-environment)
179    (search-environment/searcher
180      ##sys#syntactic-environment-symbols
181      (if qualified? any?
182          (lambda (x) (not (##sys#qualified-symbol? x))))) )
183
184  (if macenv? (search-macro-environment) (search-environment)) )
185
186; => (envsyms . macenvsyms)
187(define (*apropos-list loc regexp env macenv qualified?)
188  (append
189    (*apropos-list/environment loc regexp env #f qualified?)
190    (if (not macenv) '()
191        (*apropos-list/environment loc regexp macenv #t qualified?))) )
192
193;; Argument List Parsing
194
195(define default-environment interaction-environment)
196(define default-macro-environment ##sys#macro-environment)
197
198(define (make-apropos-regexp patt)
199  (when (symbol? patt) (set! patt (symbol->string patt)))
200  (when (string? patt) (set! patt (regexp (regexp-escape patt))))
201  patt )
202
203; => (values val args)
204(define (keyword-argument args kwd #!optional val)
205  (let loop ((args args) (oargs '()))
206    (if (null? args) (values val (reverse oargs))
207        (let ((arg (car args)))
208          (cond ((eq? kwd arg)
209                  (set! val (cadr args))
210                  (loop (cddr args) oargs) )
211                (else
212                  (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
213
214; => (values sortkey args)
215(define (parse-sortkey-argument loc args)
216  (receive (sortkey args) (keyword-argument args #:sort #:kind)
217    (%check-sortkey-argument loc sortkey)
218    (values sortkey args) ) )
219
220; #!optional (env (default-environment)) macenv
221; #!key macros? qualified?
222;
223; macenv is #t for default macro environment or a syntactic-environment object.
224;
225; => (values syms macenv)
226
227(define (parse-arguments loc patt args)
228
229  ; => (values env macenv qualified?)
230  (define (parse-rest-arguments)
231    (let ((env (default-environment))
232          (macenv #f)
233          (qualified? #f)
234          (1st-arg? #t))
235      (let loop ((args args))
236        (if (null? args) (values env macenv qualified?)
237            (let ((arg (car args)))
238                    ;keyword argument?
239              (cond ((eq? #:macros? arg)
240                      (when (cadr args) (set! macenv (default-macro-environment)))
241                      (loop (cddr args)) )
242                    ((eq? #:qualified? arg)
243                      (when (cadr args) (set! qualified? #t))
244                      (loop (cddr args)) )
245                    ;environment argument?
246                    (1st-arg?
247                      (unless (##sys#environment? arg)
248                        (error-invalid-argument loc arg) )
249                      (set! 1st-arg? #f)
250                      (set! env arg)
251                      (loop (cdr args)) )
252                    ;unkown argument
253                    (else
254                      (error-invalid-argument loc arg) ) ) ) ) ) ) )
255
256  (%check-search-pattern loc patt 'pattern)
257  (receive (env macenv qualified?) (parse-rest-arguments)
258    (values (*apropos-list loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
259
260#|
261; => (values envsyms macenv)
262
263(define (parse-arguments/environment loc patt env qualified?)
264  (%check-search-pattern loc patt 'pattern)
265  (let ((macenv (%check-environment* loc env 'environment)))
266    (values (*apropos-list/environment loc (make-apropos-regexp patt) env macenv qualified?) macenv) ) )
267
268; #!key qualified? sort?
269;
270; => (... (macenv . syms) ...)
271
272(define (parse-arguments/environments loc patt args)
273
274  (define (parse-rest-arguments)
275    (let ((qualified? #f))
276      (let loop ((args args) (envs '()))
277        (if (null? args) (values (reverse envs) qualified?)
278            (let ((arg (car args)))
279                    ;keyword argument?
280              (cond ((eq? #:qualified? arg)
281                      (when (cadr args) (set! qualified? #t))
282                      (loop (cddr args) envs) )
283                    ;environment argument?
284                    (else
285                      (unless (##sys#environment? arg)
286                        (error-invalid-argument loc arg) )
287                      (loop (cdr args) (cons env envs)) ) ) ) ) ) ) )
288
289  (%check-search-pattern loc patt 'pattern)
290  (receive (envs qualified?) (parse-rest-arguments)
291    (let ((regexp (make-apropos-regexp patt)))
292      (let loop ((envs envs) (envsyms '()))
293        (if (null? envs) (reverse envsyms)
294            (let* ((env (car envs))
295                   (macenv (%check-environment* loc env 'environment))
296                   (make-envsyms
297                    (lambda ()
298                      `(,macenv . ,(*apropos-list/environment loc regexp env macenv qualified?)) ) ) )
299              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) )
300|#
301
302;; Display
303
304; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
305(define (apropos-procedure-information proc)
306  (let ((info (procedure-information proc)))
307    (cond ((not info) 'procedure)
308          ((pair? info) `(procedure . ,(cdr info)))
309          (else `(procedure . ,(symbol->string info))) ) ) )
310
311; => 'macro | 'keyword | 'variable | <procedure-information>
312(define (apropos-information sym macenv)
313  (cond ((and macenv (##sys#macro? sym macenv)) 'macro)
314        ((keyword? sym) 'keyword)
315        (else
316          (let ((binding (global-ref sym)))
317            (if (procedure? binding) (apropos-procedure-information binding)
318                'variable ) ) ) ) )
319
320(define (*apropos-information-list syms macenv)
321  (map (lambda (sym) (cons sym (apropos-information sym macenv))) syms) )
322
323(define (display-spaces cnt)
324  (do ((i cnt (sub1 i)))
325      ((zero? i))
326    (display #\space) ) )
327
328(define (apropos-information-name<? apr1 apr2)
329  (symbol<? (car apr1) (car apr2)) )
330
331(define (apropos-information-kind=? apr1 apr2)
332  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
333    (symbol=? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
334
335(define (apropos-information-kind<? apr1 apr2)
336  (let ((i1 (cdr apr1)) (i2 (cdr apr2)))
337    (symbol<? (if (symbol? i1) i1 (car i1)) (if (symbol? i2) i2 (car i2))) ) )
338
339(define (apropos-information<? apr1 apr2)
340  (if (apropos-information-kind=? apr1 apr2) (apropos-information-name<? apr1 apr2)
341      (apropos-information-kind<? apr1 apr2) ) )
342
343(define (display-apropos syms macenv sortkey)
344  (let ((maxsymlen (max-symbol-print-width syms)))
345
346    (define (display-symbol-information apr)
347      (let ((sym (car apr)))
348        (display sym) (display #\space) (display-spaces (- maxsymlen (symbol-print-length sym))) )
349      (display #\space)
350      (let ((info (cdr apr)))
351        (cond ((symbol? info) (display info) )
352              (else (display (car info)) (display #\space) (write (cdr info)) ) ) )
353      (newline) )
354
355    (let ((lessp
356            (case sortkey
357              ((#:name) apropos-information-name<? )
358              ((#:kind) apropos-information<? )
359              (else     #f ) ) )
360          (ail (*apropos-information-list syms macenv)))
361      (for-each display-symbol-information (if lessp (sort ail lessp) ail)) ) ) )
362
363;;; API
364
365;; Original
366
367(define (apropos patt . args)
368  (receive (sortkey args) (parse-sortkey-argument 'apropos args)
369    (receive (syms macenv) (parse-arguments 'apropos patt args)
370      (display-apropos syms macenv sortkey) ) ) )
371
372(define (apropos-list patt . args)
373  (receive (syms macenv) (parse-arguments 'apropos-list patt args)
374    syms ) )
375
376(define (apropos-information-list patt . args)
377  (receive (syms macenv) (parse-arguments 'apropos-information-list patt args)
378    (*apropos-information-list syms macenv) ) )
379
380;; Crispy
381
382#|
383==== apropos/environment
384
385<procedure>(apropos/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?] [#:sort SORT])</procedure>
386
387Displays information about identifiers matching {{PATTERN}} in the
388{{ENVIRONMENT}}.
389
390Like {{apropos}}.
391
392; {{ENVIRONMENT}} : An {{environment}} or a {{syntactic-environment}}.
393
394==== apropos-list/environment
395
396<procedure>(apropos-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
397
398Like {{apropos-list}}.
399
400==== apropos-information-list/environment
401
402<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT [#:qualified? QUALIFIED?])</procedure>
403
404Like {{apropos-information-list}}.
405
406(define (apropos/environment patt env #!key qualified? (sort #:name))
407  (%check-sortkey-argument 'apropos/environment sort)
408  (receive (syms macenv)
409           (parse-arguments/environment 'apropos/environment patt env qualified?)
410    (newline)
411    (display-apropos syms macenv sortkey) ) )
412
413(define (apropos-list/environment patt env #!key qualified?)
414  (receive (syms macenv)
415           (parse-arguments/environment 'apropos/environment patt env qualified?)
416    syms ) )
417
418(define (apropos-information-list/environment patt env #!key qualified?)
419  (receive (syms macenv)
420           (parse-arguments/environment 'apropos/environment patt env qualified?)
421    (*apropos-information-list syms macenv) ) )
422
423;; Extra Crispy
424
425==== apropos/environments
426
427<procedure>(apropos/environments PATTERN [#:qualified? QUALIFIED?] [#:sort SORT] ENVIRONMENT...)</procedure>
428
429Displays information about identifiers matching {{PATTERN}} in each
430{{ENVIRONMENT}}.
431
432Like {{apropos}}.
433
434; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
435
436==== apropos-list/environments
437
438<procedure>(apropos-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
439
440
441Like {{apropos-list}}.
442
443==== apropos-information-list/environments
444
445<procedure>(apropos-information-list/environments PATTERN [#:qualified? QUALIFIED?] ENVIRONMENT...)</procedure>
446
447Like {{apropos-information-list}}.
448
449(define (apropos/environments patt . args)
450  (receive (sortkey args) (parse-sortkey-argument 'apropos/environments args)
451    (let ((i 0))
452      (for-each
453        (lambda (macenv+syms)
454          (set! i (add1 i))
455          (newline) (print "** Environment " i " **") (newline)
456          (display-apropos (cdr macenv+syms) (car macenv+syms) sortkey) )
457        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
458
459(define (apropos-list/environments patt . args)
460  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
461
462(define (apropos-information-list/environments patt . args)
463  (map
464    (lambda (macenv+syms) (*apropos-information-list (cdr macenv+syms) (car macenv+syms)))
465    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
466|#
467
468;;;
469
470(define (parse-csi-apropos-arguments args)
471  (let loop ((args args) (oargs '()))
472    (if (null? args) (reverse oargs)
473        (let ((arg (car args)))
474          (case arg
475            ((macros)
476              (loop (cdr args) (cons #t (cons #:macros? oargs))) )
477            ((qualified)
478              (loop (cdr args) (cons #t (cons #:qualified? oargs))) )
479            ((sort)
480              (let* ((val (cadr args))
481                     (key (if (symbol? val) (symbol->keyword val) val)))
482                (loop (cddr args) (cons key (cons #:sort oargs))) ) )
483            (else
484              (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
485
486(when (feature? csi:)
487  (toplevel-command 'a
488    (lambda ()
489      (apply apropos
490        (parse-csi-apropos-arguments
491          (with-input-from-string (string-trim-both (read-line)) read-file))) )
492    ",a PATT [ARG...]  Apropos of PATT with ARG from macros, qualified, or sort name/#f") )
493
494) ;module apropos
Note: See TracBrowser for help on using the repository browser.