Changeset 34989 in project


Ignore:
Timestamp:
01/07/18 20:24:58 (6 months ago)
Author:
kon
Message:

raw is in , hndl '# in id better

File:
1 edited

Legend:

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

    r34947 r34989  
    3737)
    3838
    39 (import scheme)
    40 
    41 (import chicken foreign (only csi toplevel-command))
    42 
    4339(import
     40  scheme
     41  chicken
     42  foreign
     43  (only csi toplevel-command))
     44
     45(use
    4446  (only data-structures
    4547    sort! any?
     
    5052    with-input-from-string)
    5153  (only extras
    52     read-file read-line))
    53 (require-library
    54   data-structures
    55   ports
    56   extras)
    57 
    58 (import
     54    read-file read-line)
    5955  (only srfi-1
    6056    cons*
     
    6359    last-pair)
    6460  (only srfi-13
    65     string-trim-both string-contains string-contains-ci)
     61    string-join
     62    string-trim-both
     63    string-contains string-contains-ci)
    6664  (only irregex
    6765    sre->irregex
     
    7068    irregex-search irregex-match
    7169    irregex-match-data? irregex-match-num-submatches
    72     irregex-replace))
    73 (require-library
    74   srfi-1
    75   srfi-13
    76   irregex)
    77 
    78 (import
     70    irregex-replace)
    7971  (only memoized-string
    8072    make-string*)
     
    8678    check-fixnum define-check+error-type)
    8779  (only type-errors
    88     define-error-type error-argument-type))
    89 (require-library
    90   memoized-string
    91   symbol-utils
    92   type-checks
    93   type-errors)
    94 
    95 (require-extension miscmacros)
     80    define-error-type error-argument-type)
     81  miscmacros)
    9682
    9783(declare  ;yes, i know not module-minded
     
    10490
    10591;;; Support
     92
     93;; irregex extensions
     94
     95(define (irregex-submatches? mt #!optional ire)
     96  (and
     97    (irregex-match-data? mt)
     98    (or
     99      (not ire)
     100      (fx=
     101        (irregex-match-num-submatches mt)
     102        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
    106103
    107104;; raw access renames
     
    435432;
    436433;=> (values apropos-ls macenv)
    437 (define (parse-arguments loc patt iargs)
    438   (receive
    439     (env macenv qualified? case-insensitive? base) (parse-rest-arguments loc iargs)
     434(define (parse-arguments-and-match loc patt iargs)
     435  (let-values (
     436    ((env macenv qualified? case-insensitive? base raw?)
     437      (parse-rest-arguments loc iargs)))
    440438    ;
    441439    (let* (
     
    447445        (*apropos-list loc matcher env macenv qualified?) ) )
    448446      ;
    449       (values als macenv) ) ) )
     447      (values als macenv raw?) ) ) )
    450448;;
    451449
    452450;=> (values env macenv qualified? base)
    453451(define (parse-rest-arguments loc iargs)
    454   (let ((env #f)        ;(default-environment)
    455         (macenv #f)
    456         (qualified? #f)
    457         (case-insensitive? #f)
    458         (base *APROPOS-DEFAULT-BASE*)
    459         (1st-arg? #t))
     452  (let (
     453    (env #f)        ;(default-environment)
     454    (macenv #f)
     455    (qualified? #f)
     456    (raw? #f)
     457    (case-insensitive? #f)
     458    (base *APROPOS-DEFAULT-BASE*)
     459    (1st-arg? #t) )
     460    ;
    460461    (let loop ((args iargs))
    461462      (if (null? args)
    462463        ;seen 'em all
    463         (values env macenv qualified? case-insensitive? base)
     464        (values env macenv qualified? case-insensitive? base raw?)
    464465        ;process potential arg
    465466        (let ((arg (car args)))
    466467          ;keyword argument?
    467468          (cond
     469            ;
     470            ((eq? #:raw? arg)
     471              (set! raw? (cadr args))
     472              (loop (cddr args)) )
    468473            ;
    469474            ((eq? #:base arg)
     
    479484            ;
    480485            ((eq? #:qualified? arg)
    481               (when (cadr args)
    482                 (set! qualified? #t) )
     486              (set! qualified? (cadr args))
    483487              (loop (cddr args)) )
    484488            ;
    485489            ((eq? #:case-insensitive? arg)
    486               (when (cadr args)
    487                 (set! case-insensitive? #t) )
     490              (set! case-insensitive? (cadr args))
    488491              (loop (cddr args)) )
    489492            ;environment argument?
     
    592595
    593596(define *TOPLEVEL-MODULE-SYMBOL* '||)
    594 (define *TOPLEVEL-MODULE-STRING* (symbol->string *TOPLEVEL-MODULE-SYMBOL*))
     597(define *TOPLEVEL-MODULE-STRING* "" #;(symbol->string *TOPLEVEL-MODULE-SYMBOL*))
    595598
    596599;;
     
    646649|#
    647650
    648 (define (identifier-components sym)
     651(define (identifier-components sym raw?)
    649652  (if (qualified-symbol? sym)
    650653    (cons *TOPLEVEL-MODULE-SYMBOL* sym)
    651654    (let* (
    652655      (nams
    653         (string-split (symbol->string sym) "#" #t) )
     656        (if raw?
     657          (list (symbol->string sym))
     658          (string-split (symbol->string sym) "#" #t) ) )
    654659      (nams
    655660        (if (null? (cdr nams))
     
    657662          nams ) ) )
    658663      ;
    659       (cons (string->display-symbol (car nams)) (string->display-symbol (cadr nams))) ) ) )
     664      (let (
     665        (mod
     666          (string->display-symbol (car nams)) )
     667        (nam
     668          (string->display-symbol (string-join (cdr nams) "#")) ) )
     669        ;
     670        (cons mod nam) ) ) ) )
    660671
    661672;FIXME make patt a param ?
    662 (define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast 'small))
    663 (define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast 'small))
    664 
    665 (define (irregex-submatches? mt #!optional ire)
    666   (and
    667     (irregex-match-data? mt)
    668     (or
    669       (not ire)
    670       (fx=
    671         (irregex-match-num-submatches mt)
    672         (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
    673 
    674 (define (canonical-identifier-name id)
    675   (let* (
    676     (pname (symbol->string id) )
    677     (mt (irregex-match *GENSYM_SRE* pname) ) )
    678     ;
    679     (if (irregex-submatches? mt *GENSYM_SRE*)
    680       (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
    681       id ) ) )
    682 
    683 (define (canonicalize-identifier-names form)
     673(define *GENSYM_SRE* (sre->irregex '(: bos (>= 2 any) (>= 2 num) eos) 'utf8 'fast))
     674(define *GENSYM_DEL_SRE* (sre->irregex '(: (* num) eos) 'utf8 'fast))
     675
     676(define (canonical-identifier-name id raw?)
     677  (if raw?
     678    id
     679    (let* (
     680      (pname (symbol->string id) )
     681      (mt (irregex-match *GENSYM_SRE* pname) ) )
     682      ;
     683      (if (irregex-submatches? mt *GENSYM_SRE*)
     684        (string->display-symbol (irregex-replace *GENSYM_DEL_SRE* pname ""))
     685        id ) ) ) )
     686
     687(define (canonicalize-identifier-names form raw?)
    684688  (cond
     689    (raw?
     690      form )
    685691    ((symbol? form)
    686       (canonical-identifier-name form) )
     692      (canonical-identifier-name form raw?) )
    687693    ((pair? form)
    688694      (cons
    689         (canonicalize-identifier-names (car form))
    690         (canonicalize-identifier-names (cdr form))) )
     695        (canonicalize-identifier-names (car form) raw?)
     696        (canonicalize-identifier-names (cdr form) raw?)) )
    691697    (else
    692698      form ) ) )
    693699
    694700; => 'procedure | (procedure . <symbol>) | (procedure . <list>) | (procedure . <string>)
    695 (define (procedure-details proc)
     701(define (procedure-details proc raw?)
    696702  (let ((info (procedure-information proc)))
    697703    (cond
     
    699705        'procedure )
    700706      ((pair? info)
    701         `(procedure . ,(canonicalize-identifier-names (cdr info))) )
     707        `(procedure . ,(canonicalize-identifier-names (cdr info) raw?)) )
    702708      (else
    703709        ;was ,(symbol->string info) (? why)
    704         `(procedure . ,(canonical-identifier-name info)) ) ) ) )
     710        `(procedure . ,(canonical-identifier-name info raw?)) ) ) ) )
    705711
    706712; => 'macro | 'keyword | 'variable | <procedure-details>
    707 (define (identifier-type-details sym #!optional macenv)
     713(define (identifier-type-details sym #!optional macenv raw?)
    708714  (cond
    709715    ((symbol-macro-in-environment? sym macenv)
     
    714720      (let ((val (global-symbol-ref sym)))
    715721        (if (procedure? val)
    716           (procedure-details val)
     722          (procedure-details val raw?)
    717723          'variable ) ) ) ) )
    718724
    719725;;
    720726
    721 (define (make-information sym macenv)
    722   (cons (identifier-components sym) (identifier-type-details sym macenv)) )
    723 
    724 (define (*make-information-list syms macenv)
    725   (map (cut make-information <> macenv) syms) )
     727(define (make-information sym macenv raw?)
     728  (cons
     729    (identifier-components sym raw?)
     730    (identifier-type-details sym macenv raw?)) )
     731
     732(define (*make-information-list syms macenv raw?)
     733  (map (cut make-information <> macenv raw?) syms) )
    726734
    727735(define (identifier-information-module ident-info)
     
    789797;;
    790798
    791 (define (make-sorted-information-list syms macenv sort-key)
     799(define (make-sorted-information-list syms macenv sort-key raw?)
    792800  (let (
    793801    (lessp
     
    802810          #f ) ) )
    803811    (ails
    804       (*make-information-list syms macenv) ) )
     812      (*make-information-list syms macenv raw?) ) )
    805813    ;
    806814    (if lessp
     
    815823    (fx- maxsymlen maxlen) ) )
    816824
    817 (define (display-apropos isyms macenv sort-key)
     825(define (display-apropos isyms macenv sort-key raw?)
    818826  ;
    819827  (let* (
    820     (ails (make-sorted-information-list isyms macenv sort-key) )
     828    (ails (make-sorted-information-list isyms macenv sort-key raw?) )
    821829    (mods (map information-module ails) )
    822830    (syms (map information-name ails) )
     
    863871  (let*-values (
    864872    ((sort-key args) (parse-sort-key-argument 'apropos args) )
    865     ((syms macenv) (parse-arguments 'apropos patt args) ) )
    866     ;
    867     (display-apropos syms macenv sort-key) ) )
     873    ((syms macenv raw?) (parse-arguments-and-match 'apropos patt args) ) )
     874    ;
     875    (display-apropos syms macenv sort-key raw?) ) )
    868876
    869877(define (apropos-list patt . args)
     878  (parse-arguments-and-match 'apropos-list patt args)
     879  #;
    870880  (receive
    871     (syms _) (parse-arguments 'apropos-list patt args)
     881    (syms _ _) (parse-arguments-and-match 'apropos-list patt args)
    872882    ;
    873883    syms ) )
     
    876886  (let*-values (
    877887    ((sort-key args) (parse-sort-key-argument 'apropos-information-list args) )
    878     ((syms macenv) (parse-arguments 'apropos-information-list patt args) ) )
    879     ;
    880     (make-sorted-information-list syms macenv sort-key) ) )
     888    ((syms macenv raw?) (parse-arguments-and-match 'apropos-information-list patt args) ) )
     889    ;
     890    (make-sorted-information-list syms macenv sort-key raw?) ) )
    881891
    882892#| ;UNSUPPORTED ;FIXME case-insensitive support
     
    977987;;; REPL Integeration
    978988;;;
     989
     990;rmvd ", raw, base [#]"
     991(define *csi-apropos-help*
     992  ",a PATT ARG...    Apropos of PATT with ARG from mac[ros], qual[ified], ci|c13e, all, sort [name|mod[ule]|type|#f]")
    979993
    980994(define (parse-csi-apropos-arguments iargs)
     
    10311045            (addarg #:case-insensitive? #t) )
    10321046          ;
     1047          ((raw)
     1048            (addarg #:raw? #t) )
     1049          ;
    10331050          ((base)
    10341051            (addarg #:base *APROPOS-DEFAULT-BASE* (cut check-number-base ',a <>)) )
     
    10521069        (unless (null? args)
    10531070          (apply apropos args) ) ) )
    1054     ",a PATT ARG...    Apropos of PATT with ARG from mac[ros], qual[ified], ci|c13e, all, sort [name|mod[ule]|type|#f], base [#]") )
     1071    *csi-apropos-help*) )
    10551072
    10561073) ;module apropos
Note: See TracChangeset for help on using the changeset viewer.