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

Last change on this file since 37095 was 37095, checked in by Kon Lovett, 9 months ago

fix #1578, add internal kwd arg, add split test

File size: 5.8 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  (chicken base)
19  (chicken fixnum)
20  (chicken platform)
21  (chicken io)
22  (chicken port)
23  (only (srfi 1) cons* reverse!)
24  #; ;Warning: the following extensions are not currently installed: chicken.csi
25  (only (chicken csi) toplevel-command)
26  apropos-api)
27
28(define-syntax apropos-toplevel-command
29  (syntax-rules ()
30    ((_ arg0 ...)
31      (chicken.csi#toplevel-command arg0 ...) ) ) )
32
33;;; Support
34
35;; string extensions
36
37(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
38  (let* (
39    (rem (fx- n (string-length x)))
40    (shorter? (positive? rem)) )
41    (if shorter?
42      (string-append x (make-string rem pad))
43      (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
44
45;; Constants
46
47(define-constant CSI-HELP-HEAD-WIDTH 18)
48
49(define (csi-help-command-pad x)
50  (string-fixed-length x CSI-HELP-HEAD-WIDTH) )
51
52(define (csi-help cmd arg)
53  (string-append (string-fixed-length cmd CSI-HELP-HEAD-WIDTH) arg) )
54
55;rmvd ", raw, base [#]"
56(define CSI-HELP
57  (csi-help
58    ",a PATT ARG..."
59    "Apropos of PATT with ARG from ?, mac, ci, sort nam|mod|typ|#f, split nam|mod|#f"))
60
61(define-constant HELP-TEXT
62#<<EOS
63Pattern:
64
65 The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
66 strings are interpreted as a substring match.
67
68 The quoted PATT:
69
70    '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
71    '(PATT . _)     synonym for `PATT split module`.
72    '(_ . PATT)     synonym for `PATT split name`.
73    '(_ . _)        synonym for `(: (* any))` or match any.
74
75  '<atom>
76
77    interpret `<atom>` as an irregex.
78
79 Use "?" as a PATT to list symbols containing a `?`.
80
81Arguments:
82
83 macros            Include macro bound symbols
84 ci | case-insensitive
85                   Pattern has no capitals
86 sort name | module | type | #f
87                   Order items; optional when last argument
88 split name | module | #f
89                   Pattern match component; optional when last argument
90                   (also see the '(_ . _) pattern)
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          ((mac macros)
176            (arg-next #:macros? #t))
177          ;
178          ((ci case-insensitive)
179            (arg-next #:case-insensitive? #t))
180          ;
181          ((internal)
182            (arg-next #:internal? #t))
183          ;
184          ((raw)
185            (arg-next #:raw? #t))
186          ;
187          ((base)
188            (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)))
189          ;
190          ((sort)
191            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)))
192          ;
193          ((split)
194            (arg-next #:split #f (cut interp-split-arg ',a <>)))
195          ;
196          ((?)
197            (loop '() '()))
198          ;
199          (else
200            (loop (cdr args) (cons arg oargs)) ) ) ) ) ) )
201
202(define (csi-apropos-command)
203  ;FIXME could be empty of args
204  (let* (
205    (cmdlin (read-line))
206    (args (with-input-from-string cmdlin read-list))
207    (apropos-args (parse-csi-apropos-arguments args)) )
208    ;NOTE will not dump the symbol-table unless explicit - use '(: (* any))
209    (cond
210      ((null? apropos-args)
211        (display-apropos-help) )
212      ((null? (cdr apropos-args))
213        (apply apropos (car apropos-args) (apropos-default-options)) )
214      (else
215        (apply apropos apropos-args) ) ) ) )
216
217;;; Main
218
219(when (feature? csi:)
220  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )
221
222) ;module apropos-csi
Note: See TracBrowser for help on using the repository browser.