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

Last change on this file since 38877 was 38877, checked in by Kon Lovett, 2 months ago

make help an arg

File size: 6.2 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) first 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 help, 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
78Arguments:
79
80 help              This message
81 macros            Include macro bound symbols
82 ci | case-insensitive
83                   Pattern has no capitals
84 sort name | module | type | #f
85                   Order items; optional when last argument
86 split name | module | #f
87                   Pattern match component; optional when last argument
88                   (also see the '(_ . _) pattern)
89 imp | imported    Only imported identifiers, otherwise global symbols
90 all               Means `ci mac`
91 krl               Means `all sort mod`
92 base              For number valued pattern
93 raw               No listing symbol interpretation (i.e. x123 ~> x)
94 internal          Include internal "modules"
95EOS
96)
97
98;;;
99;;; REPL Integeration
100;;;
101
102(define (interp-split-arg loc arg)
103  (case arg
104    ((n nam name)     #:name)
105    ((m mod module)   #:module)
106    (else
107      (if (not arg)
108        #f
109        (error-apropos-sort-key loc "unknown split key" arg) ) ) ) )
110
111(define (interp-sort-arg loc arg)
112  (case arg
113    ((n nam name)     #:name)
114    ((m mod module)   #:module)
115    ((t typ type)     #:type)
116    (else
117      (if (not arg)
118        #f
119        (error-apropos-sort-key loc "unknown sort key" arg) ) ) ) )
120
121(define (display-apropos-help)
122  (print CSI-HELP)
123  (print)
124  (print HELP-TEXT) )
125
126(define (parse-csi-apropos-arguments iargs)
127  (let* (
128    (1st (and (not (zero? (length iargs))) (first iargs)))
129    (rest (if 1st (cdr iargs) '())) )
130    (let loop ((args rest) (oargs `(,1st)))
131      ;
132      (define (restargs next optarg?)
133        (cond
134          ((null? next)
135            '() )
136          (optarg?
137            (cdr next))
138          (else
139            next ) ) )
140      ;
141      (define (arg-next kwd init #!optional optarg?)
142        ;
143        (define (thisargs next kwd init optarg?)
144          (cond
145            ((null? next)
146              (cons* init kwd oargs))
147            (optarg?
148              (cons* (optarg? (car next)) kwd oargs))
149            (else
150              (cons* init kwd oargs) ) ) )
151        ;
152        (let* (
153          (next (cdr args))
154          (args (restargs next optarg?))
155          (oargs (thisargs next kwd init optarg?) ) )
156          ;
157          (loop args oargs) ) )
158      ;
159      (if (null? args)
160        ; original ordering
161        (reverse! oargs)
162        ;csi-apropos-syntax => keyword-apropos-syntax
163        (let ((arg (car args)))
164          (case arg
165            ;
166            ((krl)
167              (loop
168                (restargs (cons* 'all (cdr args)) #f)
169                (cons* #:module #:sort oargs)))
170            ;
171            ((all)
172              (loop
173                (restargs (cdr args) #f)
174                (cons* #t #:case-insensitive? #t #:macros? oargs)))
175            ;
176            ((imp imported)
177              (arg-next #:imported? #t))
178            ;
179            ((mac macros)
180              (arg-next #:macros? #t))
181            ;
182            ((ci case-insensitive)
183              (arg-next #:case-insensitive? #t))
184            ;
185            ((internal)
186              (arg-next #:internal? #t))
187            ;
188            ((raw)
189              (arg-next #:raw? #t))
190            ;
191            ((base)
192              (arg-next #:base (apropos-default-base) (cut check-apropos-number-base ',a <>)))
193            ;
194            ((sort)
195              (arg-next #:sort #:type (cut interp-sort-arg ',a <>)))
196            ;
197            ((split)
198              (arg-next #:split #f (cut interp-split-arg ',a <>)))
199            ;
200            ((help)
201              (loop '() '()))
202            ;
203            (else
204              (loop (cdr args) (cons arg oargs)) ) ) ) )  ) ) )
205
206(define (csi-apropos-command)
207  ;FIXME could be empty of args
208  (let* (
209    (cmdlin (read-line))
210    (args (with-input-from-string cmdlin read-list))
211    (apropos-args (parse-csi-apropos-arguments args)) )
212    ;NOTE will not dump the symbol-table unless explicit - use '(: (* any))
213    (cond
214      ((null? apropos-args)
215        (display-apropos-help) )
216      ((null? (cdr apropos-args))
217        (apply apropos (car apropos-args) (apropos-default-options)) )
218      (else
219        (apply apropos apropos-args) ) ) ) )
220
221;;; Main
222
223(when (feature? csi:)
224  (apropos-toplevel-command 'a csi-apropos-command CSI-HELP) )
225
226) ;module apropos-csi
Note: See TracBrowser for help on using the repository browser.