Changeset 35757 in project


Ignore:
Timestamp:
07/05/18 07:11:53 (3 months ago)
Author:
kon
Message:

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

Location:
release/4/apropos/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/trunk/apropos-srfi-csi.scm

    r35744 r35757  
    1414  (only ports with-input-from-string)
    1515  (only utf8-srfi-13 string-trim-both)
     16  (only memoized-string make-string+)
    1617  (only feature-utils sorted-feature-srfis)
    17   (only apropos-srfi srfi-info srfi-srfis))
     18  (only apropos-srfi srfi-info srfi-srfis)
     19  (only type-checks check-char check-string check-fixnum))
    1820
    1921;;; String Utilities
    2022
    21 (define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
    22   (let ((rem (fx- n (string-length x))))
     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)))) )
    2331    (if (positive? rem)
    24       (string-append x (make-string rem pad))
    25       (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
     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 ) ) ) ) )
    2638
    2739;;; ,csi Extras
     
    2941(define-constant CSI-HELP-HEAD-WIDTH 18)
    3042
    31 (define (csi-help-command-pad x)
    32   (string-fixed-length x CSI-HELP-HEAD-WIDTH) )
     43(define (csi-help-command-pad s)
     44  (string-fixed-length s CSI-HELP-HEAD-WIDTH) )
    3345
    3446;;;
    3547
    36 (define CSI-SRFI-HELP-HEAD (csi-help-command-pad ",srfi #|#t|#f"))
    37 
    38 (define CSI-SRFI-HELP-BODY "Apropos of SRFI # or all SRFIs or \"featured\" SRFIs")
    39 
    40 (define CSI-SRFI-HELP (string-append CSI-SRFI-HELP-HEAD CSI-SRFI-HELP-BODY))
     48(define CSI-HELP
     49  (string-append
     50    (csi-help-command-pad ",srfi SRFI")
     51    "SRFI # or #t (all) or #f (\"featured\")"))
    4152
    4253;;
     
    5566      (alist-ref 'SRFI xs eq?) (alist-ref 'title xs eq?)) ) )
    5667
    57 (define (csi-srfi-apropos-command)
     68(define (csi-apropos-command)
    5869  ;FIXME could be empty of args
    5970  (let* (
     
    7182        (for-each srfi-info-present (srfi-srfis)) ) ) ) )
    7283
    73 (toplevel-command 'srfi csi-srfi-apropos-command CSI-SRFI-HELP)
     84(toplevel-command 'srfi csi-apropos-command CSI-HELP)
    7485
    7586) ;module apropos-srfi-csi
  • release/4/apropos/trunk/apropos.scm

    r35745 r35757  
    4848(use
    4949  (only data-structures
     50    atom?
    5051    sort! any?
    5152    alist-ref alist-update!
    5253    butlast
    5354    string-split)
    54   (only ports
    55     with-input-from-string)
    56   (only extras
    57     read-file read-line)
    58   (only srfi-1
    59     cons*
    60     reverse! append!
    61     last-pair)
     55  (only ports with-input-from-string)
     56  (only extras read-file read-line)
     57  (only srfi-1 cons* reverse! append! last-pair)
    6258  (only srfi-13
    6359    string-join
     
    7369    irregex-replace)
    7470  miscmacros
    75   (only memoized-string
    76     make-string*)
     71  (only memoized-string make-string+)
    7772  (only symbol-name-utils
    7873    symbol->keyword
    7974    symbol-printname=? symbol-printname<?
    8075    symbol-printname-length max-symbol-printname-length)
    81   (only symbol-qualified-utils
    82     qualified-symbol?)
    83   (only type-checks
    84     check-fixnum define-check+error-type)
    85   (only type-errors
    86     define-error-type error-argument-type))
     76  (only symbol-qualified-utils qualified-symbol?)
     77  (only type-checks check-fixnum define-check+error-type)
     78  (only type-errors define-error-type error-argument-type))
    8779
    8880;;; Support
     
    151143Pattern:
    152144
    153  The Pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
    154  strings are interpreted as a substring match. The quoted object is described
    155  below.
    156 
    157  Use "?" to list symbols containing a `?`.
    158 
    159  The form '(PATT . _) is a synonym for `PATT split module`; '(_ . PATT) is
    160  `PATT split name`.
    161 
    162  Otherwise use the form '... to force interpretation of `...` as an irregex.
     145 The pattern PATT is a symbol, string, sre (see irregex), or quoted. Symbols &
     146 strings are interpreted as a substring match.
     147
     148 The quoted PATT:
     149
     150   '(PATT . PATT):
     151
     152      '(PATT . _) is a synonym for `PATT split module`.
     153
     154      '(_ . PATT) is a synonym for `PATT split name`.
     155
     156      '(_ . _) is a synonym for `(: (* any))` or match any.
     157
     158      '(PATT . PATT) performs as if `PATT+PATT split module+name` worked.
     159
     160  '<atom>
     161
     162    interpret `<atom>` as an irregex.
     163
     164 Use "?" as a PATT to list symbols containing a `?`.
    163165
    164166Arguments:
     
    512514(define default-macro-environment system-macro-environment)
    513515
     516(define-constant ANY-SYMBOL '_)
     517
    514518(define (make-apropos-matcher loc patt
    515             #!optional (case-insensitive? #f) (split #f) (force-regexp? #f))
     519            #!optional
     520              (case-insensitive? #f)
     521              (split #f)
     522              (force-regexp? #f))
    516523  ;
    517524  (define (gen-irregex-options-list)
     
    571578        (gen-irregex-matcher (gen-irregex patt))
    572579        ;else some form of pattern
    573         (let (
    574           (quoted (cadr patt)) )
     580        (let ((quoted (cadr patt)))
     581          ;'(___ . <atom>)
    575582          (if (pair? quoted)
    576583            ;then could be a split (name|module) pattern
    577584            (cond
     585              ;elaborate match any
     586              ((and (eq? ANY-SYMBOL (car quoted)) (eq? ANY-SYMBOL (cdr quoted)))
     587                (make-apropos-matcher loc '(: (* any)) #f #f #t) )
    578588              ;name split?
    579               ((eq? '_ (car quoted))
     589              ((eq? ANY-SYMBOL (car quoted))
    580590                (make-apropos-matcher loc
    581591                  (cdr quoted)
    582592                  case-insensitive? #:name force-regexp?) )
    583593              ;module split?
    584               ((eq? '_ (cdr quoted))
     594              ((eq? ANY-SYMBOL (cdr quoted))
    585595                (make-apropos-matcher loc
    586596                  (car quoted)
    587597                  case-insensitive? #:module force-regexp?) )
    588               ;else force interpretation as irregex
     598              ;both name & module
    589599              (else
    590                 (make-apropos-matcher loc
    591                   quoted
    592                   case-insensitive? split #t) ) )
    593             ;else force interpretation as irregex
     600                (let (
     601                  (modr
     602                    (make-apropos-matcher loc
     603                      (car quoted)
     604                      case-insensitive? #:module force-regexp?))
     605                  (namr
     606                    (make-apropos-matcher loc
     607                      (cdr quoted)
     608                      case-insensitive? #:name force-regexp?)) )
     609                  (lambda (sym)
     610                    (and (modr sym) (namr sym)) ) ) ) )
     611            ;else interpretation of stripped
    594612            (make-apropos-matcher loc
    595613              quoted
     
    10151033        ;
    10161034        (display sym)
    1017         (display (make-string* (fx+ 2 sym-padlen))) )
     1035        (display (make-string+ (fx+ 2 sym-padlen))) )
    10181036      ;<mod><tab>
    10191037      (let* (
     
    10221040        ;
    10231041        (if (eq? *TOPLEVEL-MODULE-SYMBOL* mod)
    1024           (display (make-string* mod-padlen))
     1042          (display (make-string+ mod-padlen))
    10251043          (begin
    10261044            (display mod)
    1027             (display (make-string* (fx+ 2 mod-padlen))) ) ) )
     1045            (display (make-string+ (fx+ 2 mod-padlen))) ) ) )
    10281046      ;<details>
    10291047      (let ((dets (information-details info)))
Note: See TracChangeset for help on using the changeset viewer.