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

Last change on this file since 35739 was 35739, checked in by Kon Lovett, 15 months ago

add csi cmd supp

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