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

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

add interning switch

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