Changeset 35434 in project


Ignore:
Timestamp:
04/24/18 21:01:25 (4 months ago)
Author:
kon
Message:

csi is import only (?), add '(_ . _) split pattern form (split module/name option), expanded help, better func name

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/apropos/trunk/apropos.scm

    r35298 r35434  
    3838
    3939(import scheme chicken foreign)
     40
     41(import (only csi toplevel-command))  ;wtf?
     42
    4043(use
    41   (only csi toplevel-command)
    4244  (only data-structures
    4345    sort! any?
     
    5153  (only srfi-1
    5254    cons*
    53     fold
    5455    reverse! append!
    5556    last-pair)
     
    210211
    211212(: split-prefixed-symbol (symbol --> string string))
     213;
    212214(define (split-prefixed-symbol sym)
    213215  (let* (
     
    320322(: search-list-environment-symbols (list procedure --> list))
    321323(define (search-list-environment-symbols env optarg?)
    322   (fold
    323     (lambda (cell syms)
     324  (foldl
     325    (lambda (syms cell)
    324326      (let ((sym (car cell)))
    325327        (if (optarg? sym)
     
    436438(define default-macro-environment system-macro-environment)
    437439
    438 (define (make-apropos-matcher loc patt #!optional (case-insensitive? #f) (split #f) (force-regexp? #f))
     440(define (make-apropos-matcher loc patt
     441            #!optional (case-insensitive? #f) (split #f) (force-regexp? #f))
    439442  ;
    440443  (define (gen-irregex-options-list)
     
    480483  (cond
    481484    ((symbol? patt)
    482       (make-apropos-matcher loc (symbol->string patt) case-insensitive? split force-regexp?) )
     485      (make-apropos-matcher loc
     486        (symbol->string patt)
     487        case-insensitive? split force-regexp?) )
    483488    ((string? patt)
    484489      (if force-regexp?
    485490        (gen-irregex-matcher (gen-irregex patt))
    486         (gen-string-matcher patt) ) )
    487     ((pair? patt)
    488       (if (eq? 'quote (car patt))
    489         (make-apropos-matcher loc (cadr patt) case-insensitive? split #t)
    490         (gen-irregex-matcher (gen-irregex patt)) ) )
     491        (gen-string-matcher patt)) )
    491492    ((irregex? patt)
    492493      (gen-irregex-matcher patt) )
     494    ((pair? patt)
     495      (if (not (eq? 'quote (car patt)))
     496        ;then assume an irregex
     497        (gen-irregex-matcher (gen-irregex patt))
     498        ;else some form of pattern
     499        (let (
     500          (quoted (cadr patt)) )
     501          (if (pair? quoted)
     502            ;then could be a split (name|module) pattern
     503            (cond
     504              ;name split?
     505              ((eq? '_ (car quoted))
     506                (make-apropos-matcher loc
     507                  (cdr quoted)
     508                  case-insensitive? #:name force-regexp?) )
     509              ;module split?
     510              ((eq? '_ (cdr quoted))
     511                (make-apropos-matcher loc
     512                  (car quoted)
     513                  case-insensitive? #:module force-regexp?) )
     514              ;else force interpretation as irregex
     515              (else
     516                (make-apropos-matcher loc
     517                  quoted
     518                  case-insensitive? split #t) ) )
     519            ;else force interpretation as irregex
     520            (make-apropos-matcher loc
     521              quoted
     522              case-insensitive? split #t) ) ) ) )
    493523    (else
    494524      (error loc "invalid apropos pattern form" patt) ) ) )
     
    10101040        (error-sort-key loc "unknown sort key" arg) ) ) ) )
    10111041
     1042;rmvd ", raw, base [#]"
    10121043(define *csi-apropos-help*
    10131044  ",a PATT ARG...    Apropos of PATT with ARG from mac, split [nam|mod|#f], qual, ci, sort [nam|mod|typ|#f] Or ?")
    10141045
    1015 ;rmvd ", raw, base [#]"
    1016 (define (display-apropos-help)
    1017   (print #<<EOS
    1018 Apropos arguments:
     1046(define *apropos-help* #<<EOS
     1047Pattern:
     1048
     1049 PATT is a symbol, string, or sre. Something that can be interpreted as
     1050 regular-expression.
     1051
     1052 Use a PATT of "?" to list symbols containing a #\?.
     1053
     1054 A PATT of the form '(SUB-PATT . _) is interpreted as SUB-PATT split module.
     1055
     1056 A PATT of the form '(_ . SUB-PATT) is interpreted as SUB-PATT split name.
     1057
     1058 A PATT of the form '... will be interpreted as an irregex; excepting split
     1059 pattern as above.
     1060
     1061Arguments:
    10191062
    10201063 macros            Include macro bound symbols
     
    10301073 base              For number valued pattern
    10311074 raw               No symbol interpretation
    1032 
    1033  Use a PATT of "?" to list symbols containing a #\?.
    10341075EOS
    1035   ) )
     1076)
     1077
     1078(define (display-apropos-help)
     1079  (print *csi-apropos-help*)
     1080  (print)
     1081  (print *apropos-help*) )
    10361082
    10371083(define (parse-csi-apropos-arguments iargs)
    10381084  (let loop ((args iargs) (oargs '()))
    1039     ;
    1040     (define (thisargs next kwd init optarg?)
    1041       (cond
    1042         ((null? next)
    1043           (cons* init kwd oargs) )
    1044         (optarg?
    1045           (cons* (optarg? (car next)) kwd oargs) )
    1046         (else
    1047           (cons* init kwd oargs) ) ) )
    10481085    ;
    10491086    (define (restargs next optarg?)
     
    10561093          next ) ) )
    10571094    ;
    1058     (define (addarg kwd init #!optional optarg?)
     1095    (define (arg-next kwd init #!optional optarg?)
     1096      ;
     1097      (define (thisargs next kwd init optarg?)
     1098        (cond
     1099          ((null? next)
     1100            (cons* init kwd oargs) )
     1101          (optarg?
     1102            (cons* (optarg? (car next)) kwd oargs) )
     1103          (else
     1104            (cons* init kwd oargs) ) ) )
     1105      ;
    10591106      (let* (
    10601107        (next (cdr args) )
     
    10821129          ;
    10831130          ((mac macros)
    1084             (addarg #:macros? #t) )
     1131            (arg-next #:macros? #t) )
    10851132          ;
    10861133          ((qual qualified)
    1087             (addarg #:qualified? #t) )
     1134            (arg-next #:qualified? #t) )
    10881135          ;
    10891136          ((ci case-insensitive)
    1090             (addarg #:case-insensitive? #t) )
     1137            (arg-next #:case-insensitive? #t) )
    10911138          ;
    10921139          ((raw)
    1093             (addarg #:raw? #t) )
     1140            (arg-next #:raw? #t) )
    10941141          ;
    10951142          ((base)
    1096             (addarg #:base *APROPOS-DEFAULT-BASE* (cut check-number-base ',a <>)) )
     1143            (arg-next #:base *APROPOS-DEFAULT-BASE* (cut check-number-base ',a <>)) )
    10971144          ;
    10981145          ((sort)
    1099             (addarg #:sort #:type (cut interp-sort-arg ',a <>)) )
     1146            (arg-next #:sort #:type (cut interp-sort-arg ',a <>)) )
    11001147          ;
    11011148          ((split)
    1102             (addarg #:split #f (cut interp-split-arg ',a <>)) )
     1149            (arg-next #:split #f (cut interp-split-arg ',a <>)) )
    11031150          ;
    11041151          ((?)
Note: See TracChangeset for help on using the changeset viewer.