Changeset 35135 in project


Ignore:
Timestamp:
02/17/18 00:54:08 (10 months ago)
Author:
kon
Message:

add identifier component matching (split option seems poorly named)

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

Legend:

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

    r35134 r35135  
    6969    string-join
    7070    string-trim-both
    71     string-contains string-contains-ci)
     71    string-contains string-contains-ci
     72    string-drop string-take string-index)
    7273  (only irregex
    7374    sre->irregex
     
    9192;;; Support
    9293
     94;;
     95
     96(define-constant *CHICKEN-MAXIMUM-BASE* 16)
     97
     98;;
     99
    93100(define (->boolean obj)
    94101  (and
     
    125132  (and sym (##sys#qualified-symbol? sym)) )
    126133
    127 (define-constant *CHICKEN-MAXIMUM-BASE* 16)
    128 
    129134;; Types
    130135
     
    176181  obj )
    177182
     183(define (check-split-component loc obj #!optional (var 'split))
     184  (case obj
     185    ((#f)
     186      obj )
     187    ((#:module #:name)
     188      obj )
     189    (else
     190      (error-argument-type loc obj "invalid identifier component" var)) ) )
     191
    178192;; Symbols
    179193
     194(define (string-irregex-match? str patt)
     195  (irregex-search patt str) )
     196
     197(define (string-exact-match? str patt)
     198  (string-contains str patt) )
     199
     200(define (string-ci-match? str patt)
     201  (string-contains-ci str patt) )
     202
    180203(define (symbol-irregex-match? sym patt)
    181   (irregex-search patt (symbol->string sym)) )
     204  (string-irregex-match? (symbol->string sym) patt) )
    182205
    183206(define (symbol-exact-match? sym patt)
    184   (string-contains (symbol->string sym) patt) )
     207  (string-exact-match? (symbol->string sym) patt) )
    185208
    186209(define (symbol-ci-match? sym patt)
    187   (string-contains-ci (symbol->string sym) patt) )
     210  (string-ci-match? (symbol->string sym) patt) )
     211
     212(define *TOPLEVEL-MODULE-SYMBOL* '||)
     213(define *TOPLEVEL-MODULE-STRING* "" #;(symbol->string *TOPLEVEL-MODULE-SYMBOL*))
     214
     215(: split-prefixed-symbol (symbol --> string string))
     216(define (split-prefixed-symbol sym)
     217  (let* (
     218    (str (symbol->string sym))
     219    (idx (string-index str #\#))
     220    (mod (if idx (string-take str idx) *TOPLEVEL-MODULE-STRING*))
     221    (nam (if idx (string-drop str (fx+ 1 idx)) str)) )
     222    ;
     223    (values mod nam) ) )
    188224
    189225;; special stuff from the runtime & scheme API
     
    404440(define default-macro-environment system-macro-environment)
    405441
    406 (define (make-apropos-matcher loc patt #!optional (case-insensitive? #f) (force-regexp? #f))
     442(define (make-apropos-matcher loc patt #!optional (case-insensitive? #f) (split #f) (force-regexp? #f))
    407443  ;
    408444  (define (gen-irregex-options-list)
     
    412448    (apply irregex patt (gen-irregex-options-list)) )
    413449  ;
    414   (define (gen-irregex-matcher patt)
    415      (cut symbol-irregex-match? <> (gen-irregex patt)) )
     450  (define (gen-irregex-matcher irx)
     451    (cond
     452      ((eq? #:module split)
     453        (lambda (sym)
     454          (let-values (
     455            ((mod nam) (split-prefixed-symbol sym)) )
     456            (string-irregex-match? mod irx) ) ) )
     457      ((eq? #:name split)
     458        (lambda (sym)
     459          (let-values (
     460            ((mod nam) (split-prefixed-symbol sym)) )
     461            (string-irregex-match? nam irx) ) ) )
     462      ((not split)
     463        (cut symbol-irregex-match? <> irx) ) ) )
     464  ;
     465  (define (gen-string-matcher str)
     466    (if (not split)
     467      ;no split
     468      (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> str)
     469      ;splitting
     470      (let (
     471        (matcher (if case-insensitive? string-ci-match? string-exact-match?)) )
     472        (cond
     473          ((eq? #:module split)
     474            (lambda (sym)
     475              (let-values (
     476                ((mod nam) (split-prefixed-symbol sym)) )
     477                (matcher mod str) ) ) )
     478          ((eq? #:name split)
     479            (lambda (sym)
     480              (let-values (
     481                ((mod nam) (split-prefixed-symbol sym)) )
     482                (matcher nam str) ) ) ) ) ) ) )
    416483  ;
    417484  (cond
    418485    ((symbol? patt)
    419       (make-apropos-matcher loc (symbol->string patt) case-insensitive? force-regexp?) )
     486      (make-apropos-matcher loc (symbol->string patt) case-insensitive? split force-regexp?) )
    420487    ((string? patt)
    421488      (if force-regexp?
    422         (gen-irregex-matcher patt)
    423         (cut (if case-insensitive? symbol-ci-match? symbol-exact-match?) <> patt) ) )
     489        (gen-irregex-matcher (gen-irregex patt))
     490        (gen-string-matcher patt) ) )
    424491    ((pair? patt)
    425492      (if (eq? 'quote (car patt))
    426         (make-apropos-matcher loc (cadr patt) case-insensitive? #t)
    427         (gen-irregex-matcher patt) ) )
     493        (make-apropos-matcher loc (cadr patt) case-insensitive? split #t)
     494        (gen-irregex-matcher (gen-irregex patt)) ) )
    428495    ((irregex? patt)
    429       (cut symbol-irregex-match? <> patt) )
     496      (gen-irregex-matcher patt) )
    430497    (else
    431498      (error loc "invalid apropos pattern form" patt) ) ) )
     
    453520;;
    454521
    455 ;#!optional (env (default-environment)) macenv #!key macros? qualified? base
     522;#!optional (env (default-environment)) macenv #!key macros? qualified? base (split #:all)
    456523;
    457524;macenv is #t for default macro environment or a macro-environment object.
     
    460527(define (parse-arguments-and-match loc patt iargs)
    461528  (let-values (
    462     ((env macenv qualified? case-insensitive? base raw?)
     529    ((env macenv qualified? case-insensitive? base raw? split)
    463530      (parse-rest-arguments loc iargs)))
    464531    ;
     
    467534        (check-search-pattern loc (fixup-pattern-argument patt base) 'pattern) )
    468535      (matcher
    469         (make-apropos-matcher loc patt case-insensitive?) )
     536        (make-apropos-matcher loc patt case-insensitive? split) )
    470537      (als
    471538        (*apropos-list loc matcher env macenv qualified?) ) )
     
    482549    (raw? #f)
    483550    (case-insensitive? #f)
     551    (split #f)
    484552    (base *APROPOS-DEFAULT-BASE*)
    485553    (1st-arg? #t) )
     
    488556      (if (null? args)
    489557        ;seen 'em all
    490         (values env macenv qualified? case-insensitive? base raw?)
     558        (values env macenv qualified? case-insensitive? base raw? split)
    491559        ;process potential arg
    492560        (let ((arg (car args)))
    493561          ;keyword argument?
    494562          (cond
     563            ;
     564            ((eq? #:split arg)
     565              (set! split (check-split-component loc (cadr args)))
     566              (loop (cddr args)) )
    495567            ;
    496568            ((eq? #:raw? arg)
     
    543615
    544616#| ;UNSUPPORTED ;FIXME case-insensitive support
    545 
    546617;;
    547618
     
    620691;;
    621692
    622 (define *TOPLEVEL-MODULE-SYMBOL* '||)
    623 (define *TOPLEVEL-MODULE-STRING* "" #;(symbol->string *TOPLEVEL-MODULE-SYMBOL*))
    624 
    625693;;
    626694
     
    676744
    677745(define (identifier-components sym raw?)
    678   (if (qualified-symbol? sym)
    679     (cons *TOPLEVEL-MODULE-SYMBOL* sym)
    680     (let* (
    681       (nams
    682         (if raw?
    683           (list (symbol->string sym))
    684           (string-split (symbol->string sym) "#" #t) ) )
    685       (nams
    686         (if (null? (cdr nams))
    687           (cons *TOPLEVEL-MODULE-STRING* nams)
    688           nams ) ) )
    689       ;
    690       (let (
    691         (mod
    692           (string->display-symbol (car nams)) )
    693         (nam
    694           (string->display-symbol (string-join (cdr nams) "#")) ) )
    695         ;
    696         (cons mod nam) ) ) ) )
     746  (cond
     747    (raw?
     748      (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
     749    ((qualified-symbol? sym)
     750      (cons *TOPLEVEL-MODULE-SYMBOL* sym) )
     751    (else
     752      (let-values (
     753        ((mod nam) (split-prefixed-symbol sym)) )
     754        (cons (string->display-symbol mod) (string->display-symbol nam)) ) ) ) )
    697755
    698756;FIXME make patt a param ?
     
    928986;;;
    929987
     988(define (interp-split-arg loc arg)
     989  (case arg
     990    ((n nam name)
     991      #:name )
     992    ((m mod module)
     993      #:module )
     994    (else
     995      (if (not arg)
     996        #f
     997        (error-sort-key loc "unknown split key" arg) ) ) ) )
     998
    930999(define (interp-sort-arg loc arg)
    9311000  (case arg
    932     ;
    9331001    ((n nam name)
    9341002      #:name )
    935     ;
    9361003    ((m mod module)
    9371004      #:module )
    938     ;
    9391005    ((t typ type)
    9401006      #:type )
    941     ;
    9421007    (else
    9431008      (if (not arg)
     
    9461011
    9471012(define *csi-apropos-help*
    948   ",a PATT ARG...    Apropos of PATT with ARG from mac, qual, ci, sort [nam|mod|typ|#f] Or ?")
     1013  ",a PATT ARG...    Apropos of PATT with ARG from mac, split [nam|mod|#f], qual, ci, sort [nam|mod|typ|#f] Or ?")
    9491014
    9501015;rmvd ", raw, base [#]"
     
    9591024 sort [name | module | type | #f]
    9601025                   Order items (optional when last argument)
     1026 split [name | module | #f]
     1027                   Pattern match component (optional when last argument)
    9611028 all               Means "ci qual mac""
    9621029 krl               Means "all sort mod""
     
    10321099            (addarg #:sort #:type (cut interp-sort-arg ',a <>)) )
    10331100          ;
     1101          ((split)
     1102            (addarg #:split #f (cut interp-split-arg ',a <>)) )
     1103          ;
    10341104          ((?)
    10351105            (loop '() '()) )
  • release/4/apropos/trunk/tests/apropos-test.scm

    r35061 r35135  
    11(use apropos)
    22(use test)
     3
     4;FIXME need #:split tests
    35
    46;;
Note: See TracChangeset for help on using the changeset viewer.