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

Last change on this file since 37095 was 37095, checked in by Kon Lovett, 9 months ago

fix #1578, add internal kwd arg, add split test

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