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

Last change on this file since 36816 was 36816, checked in by Kon Lovett, 10 months ago

comments

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