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

Last change on this file since 36031 was 36031, checked in by Kon Lovett, 19 months ago

split into csi & api modules

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