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

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

remove fx use, export procs & not vars

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