source: project/release/4/apropos/trunk/apropos.scm @ 34862

Last change on this file since 34862 was 34862, checked in by Kon Lovett, 4 years ago

strip idents of gensym contrib

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