source: project/release/5/apropos/trunk/apropos-api.scm @ 38628

Last change on this file since 38628 was 38628, checked in by Kon Lovett, 6 months ago

add test groups, add imported test, remove redundant -local, add strict-types

File size: 26.8 KB
Line 
1;;;; apropos-api.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Oct '17
4;;;; Kon Lovett, Mar '09
5;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
6
7;; Issues
8;;;
9;; - Use of 'global-symbol' routines is just wrong when an
10;; evaluation-environment (##sys#environment?) is not the
11;; interaction-environment.
12;;
13;; - Doesn't show something similar to procedure-information for macros. And
14;; how could it.
15;;
16;; - Could be re-written to use the "environments" extension. Which in turn would
17;; need to support syntactic environments, at least for lookup opertations.
18;;
19;; - The Chicken 'environment' object does not hold the (syntactic) bindings
20;; for any syntactic keywords from the R5RS. The public API of 'apropos'
21;; attempts to hide this fact.
22
23(module apropos-api
24
25(;export
26  check-apropos-number-base
27  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
28  apropos-default-base apropos-interning apropos-default-options
29  ;
30  apropos apropos-list apropos-information-list)
31
32(import scheme)
33(import (chicken base))
34(import (chicken foreign))
35(import (chicken syntax))
36(import (chicken keyword))
37(import (chicken sort))
38(import (chicken type))
39(import (only (srfi 1) any reverse! append! last-pair))
40(import (only (srfi 13)
41  string-index string-join string-trim-both
42  string-contains string-contains-ci))
43(import (only (chicken irregex)
44  sre->irregex irregex irregex?
45  irregex-num-submatches irregex-search irregex-match irregex-match-data?
46  irregex-match-num-submatches irregex-replace))
47(import (only memoized-string make-string+))
48(import (only symbol-name-utils
49  symbol->keyword symbol-printname=?
50  symbol-printname<? symbol-printname-length max-symbol-printname-length))
51(import (only type-checks check-fixnum define-check+error-type))
52(import (only type-errors define-error-type error-argument-type))
53(import symbol-environment-access)
54(import symbol-access)
55
56;;;
57
58;;
59
60;FIXME invalid compile-time value for named constant `KRL-OPTIONS'
61(define KRL-OPTIONS '(#:sort #:module #:case-insensitive? #t #:macros? #t))
62
63(define *tab-width* 2)
64
65;for our purposes
66(define-constant CHICKEN-MAXIMUM-BASE 16)
67
68;; irregex extensions
69
70(define (irregex-submatches? mt #!optional ire)
71  (and
72    (irregex-match-data? mt)
73    (or
74      (not ire)
75      (=
76        (irregex-match-num-submatches mt)
77        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
78
79;; String
80
81(define (string-match? str patt)
82  (irregex-search patt str) )
83
84(define (string-exact-match? str patt)
85  (string-contains str patt) )
86
87(define (string-ci-match? str patt)
88  (string-contains-ci str patt) )
89
90;; Symbols
91
92#; ;UNUSED
93(define (symbol-match? sym patt)
94  (string-match? (symbol->string sym) patt) )
95
96#; ;UNUSED
97(define (symbol-exact-match? sym patt)
98  (string-exact-match? (symbol->string sym) patt) )
99
100#; ;UNUSED
101(define (symbol-ci-match? sym patt)
102  (string-ci-match? (symbol->string sym) patt) )
103
104;; Types
105
106;;
107
108(define (search-pattern? obj)
109  (or
110    (keyword? obj)
111    (symbol? obj)
112    (string? obj)
113    (irregex? obj)
114    (pair? obj)) )
115
116;;
117
118(define (apropos-sort-key? obj)
119  (or
120    (not obj)
121    (eq? #:name obj)
122    (eq? #:module obj)
123    (eq? #:type obj)) )
124
125;; Errors
126
127(define (error-argument loc arg)
128  (if (keyword? arg)
129    (error loc "unrecognized keyword argument" arg)
130    (error loc "unrecognized argument" arg) ) )
131
132;; Argument Checking
133
134(define-check+error-type search-pattern search-pattern?
135  "symbol/keyword/string/irregex/irregex-sre/quoted")
136
137(define-check+error-type apropos-sort-key apropos-sort-key? "#:name, #:module, #:type or #f")
138
139#; ;UNSUPPORTED
140(define-check+error-type environment system-environment?)
141
142;; Number Base
143
144(define (number-base? obj)
145  (and (exact? obj) (integer? obj) (<= 2 obj CHICKEN-MAXIMUM-BASE)) )
146
147(define *number-base-error-message*
148  (string-append "fixnum in 2.." (number->string CHICKEN-MAXIMUM-BASE)))
149
150(define apropos-default-base (make-parameter 10 (lambda (x)
151  (if (number-base? x)
152    x
153    (begin
154      (warning 'apropos-default-base (string-append "not a " *number-base-error-message*) x)
155      (apropos-default-base))))))
156
157(define (check-apropos-number-base loc obj #!optional (var 'base))
158  (unless (number-base? obj)
159    (error-argument-type loc obj *number-base-error-message* var) )
160  obj )
161
162(define (check-split-component loc obj #!optional (var 'split))
163  (case obj
164    ((#f)               obj )
165    ((#:module #:name)  obj )
166    (else
167      (error-argument-type loc obj *number-base-error-message* var)) ) )
168
169;;
170
171;
172(define (system-current-symbol? sym)
173  ;must check full identifier name, so cdr
174  (not (null? (search-list-environment-symbols (cut eq? sym <>) (system-current-environment) cdr))) )
175
176;; Environment Search
177
178;;
179
180(define (delete-duplicates!/sorted ols #!optional (eql? equal?))
181  ;(assert (sorted? ols eql?))
182  (let loop ((ls ols))
183    (let ((nxt (and (not (null? ls)) (cdr ls))))
184      (if (or (not nxt) (null? nxt))
185        ols
186        (if (eql? ls nxt)
187          (begin
188            (set-cdr! ls (cdr nxt))
189            (loop ls) )
190          (loop nxt) ) ) ) ) )
191
192(define (*apropos-list/macro-environment loc match? macenv)
193  (import (only (chicken sort) sort!))
194  ;FIXME why macro symbol dups? (& they are dups - assq list w/ dups)
195  (delete-duplicates!/sorted
196    (sort! (search-macro-environment-symbols match? macenv) symbol-printname<?)
197    (lambda (a b) (eq? (car a) (car b)))) )
198
199(define (*apropos-list/environment loc match? env)
200  (search-system-environment-symbols match? env) )
201
202; => (envsyms . macenvsyms)
203(define (*apropos-list loc match/env? env match/macenv? macenv)
204  (append!
205    (*apropos-list/environment loc match/env? env)
206    (if macenv
207      (*apropos-list/macro-environment loc match/macenv? macenv)
208      '())) )
209
210;; Argument List Parsing & Matcher Generation
211
212;FIXME separate concerns
213
214(define default-environment system-current-environment)
215(define default-macro-environment system-macro-environment)
216
217(define-constant ANY-SYMBOL '_)
218
219;(define apropos-excluded (make-parameter '() (lambda (x)
220;  (if (list? x) x (apropos-excluded)))))
221
222;(apropos-excluded "chicken.internal")
223
224(define (make-apropos-matcher loc patt
225            #!optional
226            (case-insensitive? #f)
227            (split #f)
228            (force-regexp? #f)
229            (internal? #f))
230  ;
231  ;(define excluded (apropos-excluded))
232  ;
233  (define (matcher-for pred? data)
234    (define (check? str)
235      (and
236        ;(not (any (lambda (x) (string-contains? str x)) excluded))
237        (or internal? (not (internal-module-name? str)))
238        (pred? str data) ) )
239    (cond
240      ((not split)
241        (lambda (sym)
242          (check? (symbol->string sym)) ) )
243      ((eq? #:module split)
244        (lambda (sym)
245          (let-values (((mod nam) (split-prefixed-symbol sym)))
246            (check? mod) ) ) )
247      ((eq? #:name split)
248        (lambda (sym)
249          (let-values (((mod nam) (split-prefixed-symbol sym)))
250            (check? nam) ) ) )
251        (else
252          (error loc "unknown symbol split" split patt) ) ) )
253  ;
254  (define (string-matcher str)
255    (let ((pred? (if case-insensitive? string-ci-match? string-exact-match?)))
256      (matcher-for pred? str) ) )
257  ;
258  (define (irregex-options-list)
259    (if case-insensitive? '(case-insensitive) '()) )
260  ;
261  (define (matcher-irregex patt)
262    (apply irregex patt (irregex-options-list)) )
263  ;
264  (define (irregex-matcher irx)
265    (matcher-for string-match? irx) )
266  ;
267  (cond
268    ;
269    ((symbol? patt)
270      (make-apropos-matcher loc
271        (symbol->string patt)
272        case-insensitive? split force-regexp? internal?) )
273    ;
274    ((string? patt)
275      (if force-regexp?
276        (irregex-matcher (matcher-irregex patt))
277        (string-matcher patt)) )
278    ;
279    ((irregex? patt)
280      (irregex-matcher patt) )
281    ;
282    ((pair? patt)
283      (if (not (eq? 'quote (car patt)))
284        ;then assume an irregex form
285        (irregex-matcher (matcher-irregex patt))
286        ;else some form of pattern
287        (let ((quoted (cadr patt)))
288          ;'(___ . <atom>)
289          (if (pair? quoted)
290            ;then could be a split (name|module) pattern
291            (cond
292              ;elaborate match any
293              ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
294                (make-apropos-matcher loc '(: (* any)) #f #f #t internal?) )
295              ;name split?
296              ((eq? ANY-SYMBOL (car quoted))
297                (make-apropos-matcher loc
298                  (cdr quoted)
299                  case-insensitive? #:name force-regexp? internal?) )
300              ;module split?
301              ((eq? ANY-SYMBOL (cdr quoted))
302                (make-apropos-matcher loc
303                  (car quoted)
304                  case-insensitive? #:module force-regexp? internal?) )
305              ;both name & module
306              (else
307                (let (
308                  (mod-match?
309                    (make-apropos-matcher loc
310                      (car quoted)
311                      case-insensitive? #:module force-regexp? internal?))
312                  (nam-match?
313                    (make-apropos-matcher loc
314                      (cdr quoted)
315                      case-insensitive? #:name force-regexp? internal?)) )
316                  (lambda (sym)
317                    (and (mod-match? sym) (nam-match? sym)) ) ) ) )
318            ;else interpretation of stripped
319            (make-apropos-matcher loc
320              quoted
321              case-insensitive? split #t internal?) ) ) ) )
322    ;
323    (else
324      (error loc "invalid apropos pattern form" patt) ) ) )
325
326;;
327
328; => (values val args)
329(define (keyword-argument args kwd #!optional val)
330  (let loop ((args args) (oargs '()))
331    (if (null? args)
332      (values val (reverse! oargs))
333      (let ((arg (car args)))
334        (cond
335          ((eq? kwd arg)
336            (set! val (cadr args))
337            (loop (cddr args) oargs) )
338          (else
339            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
340
341; => (values sort-key args)
342(define (parse-sort-key-argument loc args)
343  (receive (sort-key args) (keyword-argument args #:sort #:type)
344    (values (check-apropos-sort-key loc sort-key #:sort) args) ) )
345
346;;
347
348;#!optional (env (default-environment)) macenv #!key macros? internal? base (split #:all)
349;
350;macenv is #t for default macro environment or a macro-environment object.
351;
352;=> (values apropos-ls macenv)
353
354;
355(define (parse-arguments-and-match loc patt iargs)
356  (let-values (
357    ((env macenv case-insensitive? base raw? split internal? imported?) (parse-rest-arguments loc iargs)))
358    (when (and internal? imported?) (error loc "cannot be both internal & imported"))
359    (let* (
360      (patt (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern))
361      (force-regexp? #f)
362      (match? (make-apropos-matcher loc patt case-insensitive? split force-regexp? internal?))
363      (include? (if imported? system-current-symbol? global-symbol-bound?))
364      (als (*apropos-list loc (lambda (sym) (and (include? sym) (match? sym))) env match? macenv)) )
365      (values als macenv raw?) ) ) )
366;;
367
368;=> (values env macenv base raw? split internal?)
369;
370(define (parse-rest-arguments loc iargs)
371  (let (
372    (env #f)        ;(default-environment) ;just the macros but looks ok in repl?
373    (macenv #f)
374    (internal? #f)
375    (raw? #f)
376    (case-insensitive? #f)
377    (split #f)
378    (base (apropos-default-base))
379    (imported? #f)
380    (1st-arg? #t) )
381    ;
382    (let loop ((args iargs))
383      (if (null? args)
384        ;seen 'em all
385        (values env macenv case-insensitive? base raw? split internal? imported?)
386        ;process potential arg
387        (let ((arg (car args)))
388          ;keyword argument?
389          (cond
390            ;
391            ((eq? #:imported? arg)
392              (set! imported? (cadr args))
393              (loop (cddr args)) )
394            ;
395            ((eq? #:split arg)
396              (set! split (check-split-component loc (cadr args)))
397              (loop (cddr args)) )
398            ;
399            ((eq? #:internal? arg)
400              (set! internal? (cadr args))
401              (loop (cddr args)) )
402            ;
403            ((eq? #:raw? arg)
404              (set! raw? (cadr args))
405              (loop (cddr args)) )
406            ;
407            ((eq? #:base arg)
408              (when (cadr args) (set! base (check-apropos-number-base loc (cadr args))))
409              (loop (cddr args)) )
410            ;
411            ((eq? #:macros? arg)
412              ;only flag supported
413              (when (cadr args) (set! macenv (default-macro-environment)))
414              (loop (cddr args)) )
415            ;
416            ((eq? #:case-insensitive? arg)
417              (set! case-insensitive? (cadr args))
418              (loop (cddr args)) )
419            ;environment argument?
420            ;FIXME need real 'environment?' predicate
421            ((and 1st-arg? (list? arg))
422              (set! 1st-arg? #f)
423              (set! env arg)
424              (loop (cdr args)) )
425            ;unkown argument
426            (else
427              (error-argument loc arg) ) ) ) ) ) ) )
428
429;;
430
431(define (fixup-pattern-argument patt #!optional (base (apropos-default-base)))
432  (cond
433    ((boolean? patt)
434      (if patt "#t" "#f") )
435    ((char? patt)
436      (string patt) )
437    ((number? patt)
438      (number->string patt base) )
439    ;? pair vector ... ->string , struct use tag as patt ?
440    (else
441      patt ) ) )
442
443#| ;UNSUPPORTED ;FIXME case-insensitive support
444;;
445
446(define (macro-environment obj)
447  (and
448    (sys::macro-environment? obj)
449    obj) )
450
451;;
452
453; => (values envsyms macenv)
454
455(define (parse-arguments/environment loc patt env)
456  (check-search-pattern loc patt 'pattern)
457  (let ((macenv (macro-environment (check-environment loc env 'environment))))
458    (values
459      (*apropos-list/environment loc (make-apropos-matcher loc patt) env macenv)
460      macenv) ) )
461
462;;
463
464; #!key internal?
465;
466; => (... (macenv . syms) ...)
467
468(define (parse-arguments/environments loc patt args)
469  ;
470  (define (parse-rest-arguments)
471    (let ((internal? #f))
472      (let loop ((args args) (envs '()))
473        (if (null? args)
474          (values (reverse! envs) internal?)
475          (let ((arg (car args)))
476            ;keyword argument?
477            (cond
478              ((eq? #:internal? arg)
479                (when (cadr args) (set! internal? #t))
480                (loop (cddr args) envs) )
481              ;environment argument?
482              (else
483                (unless (##sys#environment? arg)
484                  (error-argument loc arg) )
485                (loop (cdr args) (cons arg envs)) ) ) ) ) ) ) )
486  ;
487  (let ((patt (fixup-pattern-argument patt)))
488    (check-search-pattern loc patt 'pattern)
489    (receive (envs internal?) (parse-rest-arguments)
490      (let ((regexp (make-apropos-matcher loc patt)))
491        (let loop ((envs envs) (envsyms '()))
492          (if (null? envs)
493            (reverse! envsyms)
494            (let* ((env (car envs))
495                   (macenv (macro-environment (check-environment loc env 'environment)))
496                   (make-envsyms
497                     (lambda ()
498                       (cons
499                         macenv
500                         (*apropos-list/environment loc regexp env macenv)) ) ) )
501              (loop (cdr envs) (cons (make-envsyms) envsyms)) ) ) ) ) ) ) )
502|#
503
504;;; Display
505
506;;
507
508(define apropos-interning (make-parameter #t (lambda (x)
509  (if (boolean? x)
510    x
511    (begin
512      (warning 'apropos-interning "not a boolean: " x)
513      (apropos-interning))))))
514
515(define (string->display-symbol str)
516  (let (
517    (str2sym (if (apropos-interning) string->symbol string->uninterned-symbol)) )
518    (str2sym str) ) )
519
520;;
521
522#| ;A Work In Progress
523
524; UNDECIDEDABLE - given the data available from `procedure-information',
525; serial nature of `gensym', and serial nature of argument coloring by
526; compiler.
527
528; `pointer+' is an example of a `foreign-lambda*', here all info is lost & the
529; gensym identifiers can just be colored using a base of 1.
530
531;best guess:
532;
533;here `(cs1806 cs2807 . csets808)'        `(cs1 cs2 . csets)'
534;here `(foo a1 b2)'                       `(foo a1 b2)'
535;here `(a380384 a379385)'                 `(arg1 arg2)'
536;here `(=1133 lis11134 . lists1135)'      `(= lis1 . lists)'
537
538(define apropos-gensym-suffix-limit 1)
539
540;When > limit need to keep leading digit
541
542(define (scrub-gensym-taste sym #!optional (limit apropos-gensym-suffix-limit))
543  (let* (
544    (str (symbol->string sym))
545    (idx (string-skip-right str char-set:digit))
546    (idx (and idx (+ 1 idx))) )
547    ;
548    (cond
549      ((not idx)
550        sym )
551      ((< (- (string-length str) idx) limit)
552        sym )
553      (else
554        (string->display-symbol (substring str 0 idx)) ) ) ) )
555
556; arg-lst-template is-a pair!
557(define (scrub-gensym-effect arg-lst-template)
558  (let (
559    (heads (butlast arg-lst-template))
560    (tailing (last-pair arg-lst-template)) )
561    ;
562    (append!
563      (map scrub-gensym-taste heads)
564      (if (null? (cdr tailing))
565        (list (scrub-gensym-taste (car tailing)))
566        (cons
567          (scrub-gensym-taste (car tailing))
568          (scrub-gensym-taste (cdr tailing)))) ) ) )
569|#
570
571(define (identifier-components sym raw?)
572  (cond
573    (raw?
574      (cons (toplevel-module-symbol) sym) )
575    (else
576      (let-values (
577        ((mod nam) (split-prefixed-symbol sym)) )
578        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
579
580;FIXME make patt a param ?
581(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
582(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
583
584(define (canonical-identifier-name id raw?)
585  (if raw?
586    id
587    (let* (
588      (pname (symbol->string id) )
589      (mt (irregex-match *GENSYM_SRE* pname) ) )
590      ;
591      (if (irregex-submatches? mt *GENSYM_SRE*)
592        (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
593        id ) ) ) )
594
595(define (canonicalize-identifier-names form raw?)
596  (cond
597    (raw?
598      form )
599    ((symbol? form)
600      (canonical-identifier-name form raw?) )
601    ((pair? form)
602      (cons
603        (canonicalize-identifier-names (car form) raw?)
604        (canonicalize-identifier-names (cdr form) raw?)) )
605    (else
606      form ) ) )
607
608; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
609;
610(define (procedure-details proc raw?)
611  (let ((info (procedure-information proc)))
612    (cond
613      ((not info)
614        'procedure )
615      ((pair? info)
616        `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
617      (else
618        ;was ,(symbol->string info) (? why)
619        `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
620
621; => 'macro | 'keyword | 'variable | <procedure-details>
622;
623(define (identifier-type-details sym #!optional macenv raw?)
624  (cond
625    ((and sym macenv (macro-symbol-in-environment? sym macenv))
626      'macro )
627    ((keyword? sym)
628      'keyword )
629    (else
630      (let ((val (global-symbol-ref sym)))
631        (if (procedure? val)
632          (procedure-details val raw?)
633          'variable ) ) ) ) )
634
635;;
636
637(define (make-information sym macenv raw?)
638  (cons
639    (identifier-components sym raw?)
640    (identifier-type-details sym macenv raw?)) )
641
642(define (*make-information-list syms macenv raw?)
643  (map (cut make-information <> macenv raw?) syms) )
644
645(define (identifier-information-module ident-info)
646  (car ident-info) )
647
648(define (identifier-information-name ident-info)
649  (cdr ident-info) )
650
651(define (detail-information-kind dets-info)
652  (car dets-info) )
653
654(define (detail-information-arguments dets-info)
655  (cdr dets-info) )
656
657(define (information-identifiers info)
658  (car info) )
659
660(define (information-module info)
661  (identifier-information-module (information-identifiers info)) )
662
663(define (information-name info)
664  (identifier-information-name (information-identifiers info)) )
665
666(define (information-details info)
667  (cdr info) )
668
669(define (information-identifier<? info1 info2 #!optional (sort-key #:name))
670  (receive
671    (field-1-ref field-2-ref)
672      (if (eq? #:name sort-key)
673        (values information-name information-module)
674        (values information-module information-name) )
675    (let (
676      (sym-1-1 (field-1-ref info1) )
677      (sym-1-2 (field-1-ref info2) ) )
678      (if (not (symbol-printname=? sym-1-1 sym-1-2))
679        (symbol-printname<? sym-1-1 sym-1-2)
680        (symbol-printname<? (field-2-ref info1) (field-2-ref info2)) ) ) ) )
681
682(define (information-kind info)
683  (let ((d (information-details info)))
684    (if (symbol? d) d (car d)) ) )
685
686(define (information-kind=? info1 info2)
687  (symbol-printname=? (information-kind info1) (information-kind info2)) )
688
689(define (information-kind<? info1 info2)
690  (symbol-printname<? (information-kind info1) (information-kind info2)) )
691
692(define (information<? info1 info2 #!optional (sort-key #:name))
693  (if (information-kind=? info1 info2)
694    (information-identifier<? info1 info2 sort-key)
695    (information-kind<? info1 info2) ) )
696
697;;
698
699(define (make-sorted-information-list syms macenv sort-key raw?)
700  (let (
701    (lessp
702      (case sort-key
703        ((#:name #:module)  (cut information-identifier<? <> <> sort-key))
704        ((#:type)           information<?)
705        (else               #f ) ) )
706    (ails
707      (*make-information-list syms macenv raw?) ) )
708    ;
709    (if lessp
710      (sort! ails lessp)
711      ails ) ) )
712
713(define (symbol-pad-length sym maxsymlen #!optional (bias 0))
714  (let* (
715    (len (symbol-printname-length sym) )
716    (maxlen (min maxsymlen len) ) )
717    (+ bias (- maxsymlen maxlen)) ) )
718
719;FIXME need to know if ANY mods, then no mod pad needed (has +2)
720(define (display-apropos isyms macenv sort-key raw?)
721  ;
722  (let* (
723    (ails (make-sorted-information-list isyms macenv sort-key raw?) )
724    (mods (map information-module ails) )
725    (syms (map information-name ails) )
726    (maxmodlen (max-symbol-printname-length mods) )
727    (maxsymlen (max-symbol-printname-length syms) ) )
728    ;
729    (define (display-symbol-information info)
730      ;<sym><tab>
731      (let* (
732        (dets (information-details info))
733        (kwd? (eq? 'keyword dets))
734        (sym (information-name info) )
735        (sym-padlen (symbol-pad-length sym maxsymlen (if kwd? -1 0)) ) )
736        (display (if kwd? (symbol->keyword sym) sym))
737        (display (make-string+ (+ *tab-width* sym-padlen))) )
738      ;<mod><tab>
739      (let* (
740        (mod (information-module info) )
741        (mod-padlen (symbol-pad-length mod maxmodlen) ) )
742        ;
743        (if (eq? (toplevel-module-symbol) mod)
744          (display (make-string+ (+ *tab-width* mod-padlen)))
745          (begin
746            (display mod)
747            (display (make-string+ (+ *tab-width* mod-padlen))) ) ) )
748      ;<details>
749      (let ((dets (information-details info)))
750        (cond
751          ((symbol? dets)
752            (display dets) )
753          (else
754            (display (detail-information-kind dets))
755            (display #\space)
756            (write (detail-information-arguments dets)) ) ) )
757      ;d'oy
758      (newline) )
759    ;
760    (for-each display-symbol-information ails) ) )
761
762;;; API
763
764(define apropos-default-options (make-parameter '() (lambda (x)
765  (cond
766    ((boolean? x)
767      (or
768        (and x KRL-OPTIONS)
769        '() ) )
770    ;FIXME actually check for proper options
771    ((list? x)
772      x )
773    (else
774      (warning 'apropos-default-options "not a list of options" x)
775      (apropos-default-options))))))
776
777;; Original
778
779(define (apropos patt . args)
780  (let (
781    (args (if (null? args) (apropos-default-options) args)) )
782    (let*-values (
783      ((sort-key args) (parse-sort-key-argument 'apropos args) )
784      ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
785      ;
786      (display-apropos syms macenv sort-key raw?) ) ) )
787
788(define (apropos-list patt . args)
789  (let (
790    (args (if (null? args) (apropos-default-options) args)) )
791    (let*-values (
792      ((sort-key args) (parse-sort-key-argument 'apropos-list args) )
793      ((syms macenv raw?) (parse-arguments-and-match 'apropos-list patt args) ) )
794      ;
795      syms ) ) )
796
797(define (apropos-information-list patt . args)
798  (let (
799    (args (if (null? args) (apropos-default-options) args)) )
800    (let*-values (
801      ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
802      ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
803      ;
804      (make-sorted-information-list syms macenv sort-key raw?) ) ) )
805
806) ;module apropos-api
807
808#| ;UNSUPPORTED ;FIXME case-insensitive support
809(export
810  ;Crispy
811  apropos/environment apropos-list/environment apropos-information-list/environment
812  ;Extra Crispy
813  apropos/environments apropos-list/environments apropos-information-list/environments)
814
815;; Crispy
816
817==== apropos/environment
818
819<procedure>(apropos/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?) (#:sort SORT))</procedure>
820
821Displays information about identifiers matching {{PATTERN}} in the
822{{ENVIRONMENT}}.
823
824Like {{apropos}}.
825
826; {{ENVIRONMENT}} : An {{environment}} or a {{macro-environment}}.
827
828==== apropos-list/environment
829
830<procedure>(apropos-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
831
832Like {{apropos-list}}.
833
834==== apropos-information-list/environment
835
836<procedure>(apropos-information-list/environment PATTERN ENVIRONMENT (#:internal? INTERNAL?))</procedure>
837
838Like {{apropos-information-list}}.
839
840(define (apropos/environment patt env #!key internal? (sort #:name))
841  (check-sort-key 'apropos/environment sort #:sort)
842  (receive
843    (syms macenv)
844      (parse-arguments/environment 'apropos/environment patt env internal?)
845    ;
846    (newline)
847    (display-apropos syms macenv sort-key) ) )
848
849(define (apropos-list/environment patt env #!key internal?)
850  (receive
851    (syms macenv)
852      (parse-arguments/environment 'apropos/environment patt env internal?)
853    ;
854    syms ) )
855
856(define (apropos-information-list/environment patt env #!key internal?)
857  (receive
858    (syms macenv)
859      (parse-arguments/environment 'apropos/environment patt env internal?)
860    ;
861    (*make-information-list syms macenv) ) )
862
863;; Extra Crispy
864
865==== apropos/environments
866
867<procedure>(apropos/environments PATTERN (#:internal? INTERNAL?) (#:sort SORT) ENVIRONMENT...)</procedure>
868
869Displays information about identifiers matching {{PATTERN}} in each
870{{ENVIRONMENT}}.
871
872Like {{apropos}}.
873
874; {{PATTERN}} : A {{symbol}}, {{string}} or {{regexp}}. When symbol or string substring matching is performed.
875
876==== apropos-list/environments
877
878<procedure>(apropos-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
879
880Like {{apropos-list}}.
881
882==== apropos-information-list/environments
883
884<procedure>(apropos-information-list/environments PATTERN (#:internal? INTERNAL?) ENVIRONMENT...)</procedure>
885
886Like {{apropos-information-list}}.
887
888(define (apropos/environments patt . args)
889  (let-values (((sort-key args) (parse-sort-key-argument 'apropos/environments args)))
890    (let ((i 0))
891      (for-each
892        (lambda (macenv+syms)
893          (set! i (add1 i))
894          (newline) (display "** Environment " i " **") (newline) (newline)
895          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
896        (parse-arguments/environments 'apropos/environments patt args)) ) ) )
897
898(define (apropos-list/environments patt . args)
899  (map cdr (parse-arguments/environments 'apropos-list/environments patt args)) )
900
901(define (apropos-information-list/environments patt . args)
902  (map
903    (lambda (macenv+syms) (*make-information-list (cdr macenv+syms) (car macenv+syms)))
904    (parse-arguments/environments 'apropos-information-list/environments patt args)) )
905|#
Note: See TracBrowser for help on using the repository browser.