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

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

Rmvd any ref to prim inlines. (After testing to make sure it works w/ them. However, cannot really benefit since probably only used at or near the toplevel. And usually interactively at that.)

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