source: project/release/5/apropos/trunk/apropos-csi.scm @ 38625

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

add imported (visible) vs oblist (defined), sort then uniq macro syms

File size: 6.0 KB
Line 
1;;;; apropos-csi.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Oct '17
4;;;; Kon Lovett, Mar '09
5;;;; From the Chicken 4 core, Version 4.0.0x5 - SVN rev. 13662
6
7;; Issues
8;;
9;; - old csi option
10;; ; {{search|mode pre[fix]|suff[ix]|#t}} : {{#:search-mode #:prefix|#:suffix|#t}}
11;; ; {{SEARCH-MODE}} : Either {{#:prefix}}, {{#:suffix}}, or {{#t}} for contains. The default is {{#t}}.
12;;
13;; - cannot use ',?' since ',' read by read
14
15(module apropos-csi ()
16
17(import scheme)
18(import (chicken base))
19(import (chicken platform))
20(import (chicken io))
21(import (chicken port))
22(import (only (srfi 1) cons* reverse!))
23;Warning: the following extensions are not currently installed: chicken.csi
24(import (only (chicken csi) toplevel-command))
25(import apropos-api)
26
27;;; Bug Support
28
29(define-syntax apropos-toplevel-command
30  (syntax-rules ()
31    ((apropos-toplevel-command arg0 ...)
32      (chicken.csi#toplevel-command arg0 ...) ) ) )
33
34;;; Support
35
36;; string extensions
37
38(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
39  (let* (
40    (rem (- n (string-length x)))
41    (shorter? (positive? rem)) )
42    (if shorter?
43      (string-append x (make-string rem pad))
44      (string-append (substring x 0 (- n (string-length tag))) tag) ) ) )
45
46;; Constants
47
48(define-constant CSI-HELP-HEAD-WIDTH 18)
49
50(define (csi-help-command-pad x)
51  (string-fixed-length x CSI-HELP-HEAD-WIDTH) )
52
53(define (csi-help cmd arg)
54  (string-append (string-fixed-length cmd CSI-HELP-HEAD-WIDTH) arg) )
55
56;rmvd ", raw, base [#]"
57(define CSI-HELP
58  (csi-help
59    ",a PATT ARG..."
60    "Apropos of PATT with ARG from ?, mac, ci, sort nam|mod|typ|#f, split nam|mod|#f"))
61
62(define-constant HELP-TEXT
63#<<EOS
64Pattern:
65
66 The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
67 strings are interpreted as a substring match.
68
69 The quoted PATT:
70
71  '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
72  '(PATT . _)     synonym for `PATT split module`.
73  '(_ . PATT)     synonym for `PATT split name`.
74  '(_ . _)        synonym for `(: (* any))` or match any.
75
76  '<atom>         interpret `<atom>` as an irregex.
77
78 Use "?" as a PATT to list symbols containing a `?`.
79
80Arguments:
81
82 macros            Include macro bound symbols
83 ci | case-insensitive
84                   Pattern has no capitals
85 sort name | module | type | #f
86                   Order items; optional when last argument
87 split name | module | #f
88                   Pattern match component; optional when last argument
89                   (also see the '(_ . _) pattern)
90 imp | imported    Only imported identifiers, otherwise global symbols
91 all               Means `ci mac`
92 krl               Means `all sort mod`
93 base              For number valued pattern
94 raw               No listing symbol interpretation (i.e. x123 ~> x)
95 internal          Include internal "modules"
96EOS
97)
98
99;;;
100;;; REPL Integeration
101;;;
102
103(define (interp-split-arg loc arg)
104  (case arg
105    ((n nam name)     #:name)
106    ((m mod module)   #:module)
107    (else
108      (if (not arg)
109        #f
110        (error-apropos-sort-key loc "unknown split key" arg) ) ) ) )
111
112(define (interp-sort-arg loc arg)
113  (case arg
114    ((n nam name)     #:name)
115    ((m mod module)   #:module)
116    ((t typ type)     #:type)
117    (else
118      (if (not arg)
119        #f
120        (error-apropos-sort-key loc "unknown sort key" arg) ) ) ) )
121
122(define (display-apropos-help)
123  (print CSI-HELP)
124  (print)
125  (print HELP-TEXT) )
126
127(define (parse-csi-apropos-arguments iargs)
128  ;look at every argument
129  (let loop ((args iargs) (oargs '()))
130    ;
131    (define (restargs next optarg?)
132      (cond
133        ((null? next)
134          '() )
135        (optarg?
136          (cdr next))
137        (else
138          next ) ) )
139    ;
140    (define (arg-next kwd init #!optional optarg?)
141      ;
142      (define (thisargs next kwd init optarg?)
143        (cond
144          ((null? next)
145            (cons* init kwd oargs))
146          (optarg?
147            (cons* (optarg? (car next)) kwd oargs))
148          (else
149            (cons* init kwd oargs) ) ) )
150      ;
151      (let* (
152        (next (cdr args))
153        (args (restargs next optarg?))
154        (oargs (thisargs next kwd init optarg?) ) )
155        ;
156        (loop args oargs) ) )
157    ;
158    (if (null? args)
159      ; original ordering
160      (reverse! oargs)
161      ;csi-apropos-syntax => keyword-apropos-syntax
162      (let ((arg (car args)))
163        (case arg
164          ;
165          ((krl)
166            (loop
167              (restargs (cons* 'all (cdr args)) #f)
168              (cons* #:module #:sort oargs)))
169          ;
170          ((all)
171            (loop
172              (restargs (cdr args) #f)
173              (cons* #t #:case-insensitive? #t #:macros? oargs)))
174          ;
175          ((imp imported)
176            (arg-next #:imported? #t))
177          ;
178          ((mac macros)
179            (arg-next #:macros? #t))
180          ;
181          ((ci case-insensitive)
182            (arg-next #:case-insensitive? #t))
183          ;
184          ((internal)
185            (arg-next #:internal? #t))
186          ;
187          ((raw)
188            (arg-next #:raw? #t))
189          ;
190          ((base)
191            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)))
192          ;
193          ((sort)
194            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)))
195          ;
196          ((split)
197            (arg-next #:split #f (cut interp-split-arg ',a <>)))
198          ;
199          ((?)
200            (loop '() '()))
201          ;
202          (else
203            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
204
205(define (csi-apropos-command)
206  ;FIXME could be empty of args
207  (let* (
208    (cmdlin (read-line))
209    (args (with-input-from-string cmdlin read-list))
210    (apropos-args (parse-csi-apropos-arguments args)) )
211    ;NOTE will not dump the symbol-table unless explicit - use '(: (* any))
212    (cond
213      ((null? apropos-args)
214        (display-apropos-help) )
215      ((null? (cdr apropos-args))
216        (apply apropos (car apropos-args) (apropos-default-options)) )
217      (else
218        (apply apropos apropos-args) ) ) ) )
219
220;;; Main
221
222(when (feature? csi:)
223  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )
224
225) ;module apropos-csi
Note: See TracBrowser for help on using the repository browser.