source: project/release/4/apropos/trunk/apropos-srfi-csi.scm @ 35757

Last change on this file since 35757 was 35757, checked in by Kon Lovett, 2 years ago

better (_ . _), better names, better docu, better life

File size: 2.2 KB
Line 
1;;;; apropos-srfi-csi.scm
2;;;; Kon Lovett, Jul '18
3
4(module apropos-srfi-csi
5
6(;export
7  srfi-features)
8
9(import scheme chicken)
10(import (only csi toplevel-command))  ;wtf?
11(use
12  (only data-structures alist-ref)
13  (only extras read-line read-file format)
14  (only ports with-input-from-string)
15  (only utf8-srfi-13 string-trim-both)
16  (only memoized-string make-string+)
17  (only feature-utils sorted-feature-srfis)
18  (only apropos-srfi srfi-info srfi-srfis)
19  (only type-checks check-char check-string check-fixnum))
20
21;;; String Utilities
22
23(: string-fixed-length (string fixnum #!rest --> string))
24;
25(define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
26  (let (
27    (rem
28      (fx-
29        (check-fixnum 'string-fixed-length n)
30        (string-length (check-string 'string-fixed-length s)))) )
31    (if (positive? rem)
32      (string-append s (make-string+ rem (check-char 'string-fixed-length pad-char)))
33      (let (
34        (lim (fx- n (string-length (check-string 'string-fixed-length trailing)))) )
35        (if (positive? lim)
36          (string-append (substring s 0 lim) trailing)
37          trailing ) ) ) ) )
38
39;;; ,csi Extras
40
41(define-constant CSI-HELP-HEAD-WIDTH 18)
42
43(define (csi-help-command-pad s)
44  (string-fixed-length s CSI-HELP-HEAD-WIDTH) )
45
46;;;
47
48(define CSI-HELP
49  (string-append
50    (csi-help-command-pad ",srfi SRFI")
51    "SRFI # or #t (all) or #f (\"featured\")"))
52
53;;
54
55(define srfi-features (make-parameter (sorted-feature-srfis)
56  (lambda (x)
57    (if (list? x)
58      x
59      (begin
60        (warning 'srfi-features "not list of #" x)
61        (srfi-features))))))
62
63(define (srfi-info-present n)
64  (let ((xs (srfi-info n)))
65    (format #t "~A\t~A~%"
66      (alist-ref 'SRFI xs eq?) (alist-ref 'title xs eq?)) ) )
67
68(define (csi-apropos-command)
69  ;FIXME could be empty of args
70  (let* (
71    (cmdlin (read-line))
72    (istr (string-trim-both cmdlin))
73    (iargs (with-input-from-string istr read-file))
74    (x (and (not (null? iargs)) (car iargs))) )
75    ;
76    (cond
77      ((not x)
78        (for-each srfi-info-present (srfi-features) ) )
79      ((number? x)
80        (srfi-info-present x) )
81      (else
82        (for-each srfi-info-present (srfi-srfis)) ) ) ) )
83
84(toplevel-command 'srfi csi-apropos-command CSI-HELP)
85
86) ;module apropos-srfi-csi
Note: See TracBrowser for help on using the repository browser.