source: project/release/5/apropos/tags/3.3.2/apropos-api.scm @ 37127

Last change on this file since 37127 was 37127, checked in by Kon Lovett, 7 months ago

rel 3.3.2

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