subscripts.rkt (6123B)
1 #lang racket/base 2 3 (provide subscript-equal? 4 extract-subscripts 5 drop-subscripts 6 find-subscript-binders) 7 8 (require (for-template stxparse-info/current-pvars) 9 racket/private/sc 10 racket/function 11 racket/list 12 phc-toolkit/untyped 13 "optcontract.rkt" 14 racket/string 15 racket/syntax) 16 17 (define/contract (extract-subscripts id) 18 (-> identifier? string?) 19 (let ([match (regexp-match #px".(_.+|[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*)$" 20 (symbol->string (syntax-e id)))]) 21 (if (>= (length match) 2) 22 (cadr match) 23 ""))) 24 25 (define/contract (string-replace* str from* to*) 26 (->i ([str string?] 27 [from* (listof string?)] 28 [to* (from*) 29 (and/c (listof string?) 30 (λ (to*) (= (length from*) (length to*))))]) 31 [range string?]) 32 (if (null? from*) 33 str 34 (string-replace* (string-replace str (car from*) (car to*)) 35 (cdr from*) 36 (cdr to*)))) 37 38 39 (define/contract (normalize-subscripts sub) 40 (-> string? string?) 41 (if (or (string=? sub "") 42 (equal? (string-ref sub 0) #\_)) 43 sub 44 (string-append 45 "_" 46 (string-replace* sub 47 (map symbol->string 48 '(ₐ ₑ ₕ ᵢ ⱼ ₖ ₗ ₘ ₙ ₒ ₚ ᵣ ₛ ₜ ᵤ ᵥ ₓ ᵦ ᵧ ᵨ ᵩ ᵪ)) 49 (map symbol->string 50 '(A E H I J K L M N O P R S T U V X β γ ρ ϕ χ)))))) 51 52 (define/contract (subscript-equal? bound binder) 53 (-> identifier? identifier? (or/c #f string?)) 54 (let* ([binder-subscripts (normalize-subscripts (extract-subscripts binder))] 55 [bound-subscripts (normalize-subscripts (extract-subscripts bound))]) 56 (and (string=? binder-subscripts bound-subscripts) 57 (not (string=? binder-subscripts "")) 58 binder-subscripts))) 59 60 (define/contract (drop-subscripts id) 61 (-> identifier? identifier?) 62 (let* ([str (symbol->string (syntax-e id))] 63 [sub (extract-subscripts id)] 64 [new-str (substring str 0 (- (string-length str) 65 (string-length sub)))]) 66 (datum->syntax id (string->symbol new-str) id id))) 67 68 (define (filter-current-pvars bound) 69 (remove-duplicates 70 (map (λ (pv+u) (cons (syntax-local-get-shadower (car pv+u)) 71 (cdr pv+u))) 72 (filter (compose (conjoin identifier? 73 (λ~> (syntax-local-value _ (thunk #f)) 74 syntax-pattern-variable?) 75 ;; force call syntax-local-value to prevent 76 ;; ambiguous bindings, as syntax-local-value 77 ;; triggers an error for those. 78 ;; Must be done before the free-identifier=? 79 ;; which just returns #false 80 (λ~> (datum->syntax _ (syntax-e bound)) 81 (syntax-local-value _ (thunk #f)) 82 (thunk* #t)) ;; ok if no error. 83 (λ~> (datum->syntax _ (syntax-e bound)) 84 (free-identifier=? _ bound)) 85 (λ~> (subscript-equal? bound _))) 86 car) 87 (current-pvars+unique))) 88 bound-identifier=? 89 #:key car)) 90 91 ;; Or write it as: 92 #;(define (filter-current-pvars bound) 93 (for/list ([binder (current-pvars+unique)] 94 #:when (identifier? (car binder)) 95 #:when (syntax-pattern-variable? 96 (syntax-local-value (car binder) (thunk #f))) 97 ;; force call syntax-local-value to prevent ambiguous 98 ;; bindings, as syntax-local-value triggers an error for 99 ;; those. 100 ;; Must be done before the free-identifier=? which just 101 ;; returns #false 102 #:when (begin 103 (syntax-local-value 104 (datum->syntax _ (syntax-e bound)) 105 (thunk #f)) 106 #t) ;; ok if no error. 107 #:when (free-identifier=? (datum->syntax (car binder) 108 (syntax-e bound)) 109 bound) 110 #:when (subscript-equal? bound (car binder))) 111 binder)) 112 113 (define/contract (find-subscript-binders bound) 114 (-> identifier? 115 (or/c #f (list/c identifier? ; bound 116 (syntax/c (listof identifier?)) ; binders 117 (syntax/c (listof identifier?)) ; unique-at-runtime ids 118 exact-nonnegative-integer?))) ; ellipsis-depth 119 (let/cc return 120 ;; EARLY RETURN (already a pattern variable) 121 (when (syntax-pattern-variable? 122 (syntax-local-value bound (thunk #f))) 123 (return #f)) 124 125 (define/with-syntax ([binder . unique-at-runtime-id] …) 126 (filter-current-pvars bound)) 127 128 ;; EARLY RETURN (no candidate binders found) 129 (when (stx-null? #'(binder …)) 130 (return #f)) 131 132 (define depths 133 (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …))) 134 135 ;; EARLY ERROR (inconsistent depths) 136 (unless (or (< (length depths) 2) (apply = depths)) 137 (car depths) 138 (raise-syntax-error 'subtemplate 139 (format "inconsistent depths: ~a" 140 (map cons 141 (syntax->datum #'(binder …)) 142 depths)) 143 bound 144 (syntax->list #'(binder …)))) 145 146 ;; FINAL RETURN (list of same-depth binders + their depth) 147 (return (list bound 148 #'(binder …) 149 #'(unique-at-runtime-id …) 150 (car depths)))))