source: project/release/4/apropos/tags/2.7.2/apropos.scm @ 35437

Last change on this file since 35437 was 35437, checked in by kon, 7 months ago

rel 2.7.2

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