superscripts.rkt (6184B)
1 #lang racket 2 3 (require racket/syntax 4 racket/struct 5 racket/string 6 racket/format 7 pretty-format 8 debug-scopes/named-scopes-sli-parameter) 9 10 (provide +scopes print-full-scopes) 11 12 (define max-seen-scopes 0) 13 (define seen-scopes (make-hash)) 14 15 (define (print-full-scopes [reset? #t]) 16 (define scopes (sort (hash->list seen-scopes) < #:key cadr)) 17 (define l 18 (map (λ (s) 19 (format "~a ~a" 20 (cadr s) 21 (string-join (map ~a (cdr (vector->list (cddr s)))) 22 " "))) 23 scopes)) 24 (define max-len (apply max 0 (map string-length l))) 25 (define (pad str) 26 (string-append 27 str 28 (make-string (- max-len (string-length str)) (string-ref " " 0)))) 29 (for-each (λ (s str) 30 (printf "~a ~a\n" 31 (pad str) 32 (vector-ref (cddr s) 0))) 33 scopes 34 l) 35 (when reset? 36 (hash-clear! seen-scopes) 37 (set! max-seen-scopes 0))) 38 39 (define (string-replace* str replacements) 40 (if (null? replacements) 41 str 42 (string-replace* (string-replace str 43 (caar replacements) 44 (cadar replacements)) 45 (cdr replacements)))) 46 47 (define (digits->superscripts str) 48 (string-replace* str '(["0" "⁰"] 49 ["1" "¹"] 50 ["2" "²"] 51 ["3" "³"] 52 ["4" "⁴"] 53 ["5" "⁵"] 54 ["6" "⁶"] 55 ["7" "⁷"] 56 ["8" "⁸"] 57 ["9" "⁹"]))) 58 59 (define (digits->subscripts str) 60 (string-replace* str '(["0" "₀"] 61 ["1" "₁"] 62 ["2" "₂"] 63 ["3" "₃"] 64 ["4" "₄"] 65 ["5" "₅"] 66 ["6" "₆"] 67 ["7" "₇"] 68 ["8" "₈"] 69 ["9" "₉"]))) 70 71 (define (change-digits1 l [mode #t]) 72 (if (null? l) 73 '() 74 (cons ((if mode digits->superscripts digits->subscripts) (car l)) 75 (change-digits1 (cdr l) (not mode))))) 76 77 (define (change-digits2 l) 78 (let ([min-id (apply min l)] 79 [max-id (apply max l)]) 80 (format "~a˙˙~a~a" 81 (digits->superscripts (~a min-id)) 82 (digits->superscripts (~a max-id)) 83 (string-join (map (λ (x) 84 (format "⁻~a" (digits->superscripts (~a x)))) 85 (filter-not (λ (x) (member x l)) 86 (range min-id (add1 max-id)))) 87 "")))) 88 89 (define (change-digits l) 90 (let ([a (string-join (change-digits1 (map ~a l)) "")]) 91 (if (null? l) 92 a 93 (let ([b (change-digits2 l)]) 94 (if (or (and (< (string-length a) (string-length b)) 95 (> (string-length a) 4)) 96 (= (length l) 1)) 97 a 98 b))))) 99 100 (define (extract-scope-ids e) 101 (map (λ (c) 102 (car (hash-ref! seen-scopes (vector-ref c 0) 103 (λ () 104 (begin0 (cons max-seen-scopes c) 105 (set! max-seen-scopes 106 (add1 max-seen-scopes))))))) 107 (hash-ref (syntax-debug-info e) 'context))) 108 109 (define (add-scopes e) 110 (cond 111 [(identifier? e) 112 (let ([ids (extract-scope-ids e)]) 113 ;(format-id e "~a⁽~a⁾" e (string-join (map digits->superscripts 114 ; (map ~a ids)) " "))) 115 (format-id e "~a~a" e (change-digits ids)))] 116 [(syntax? e) (datum->syntax e (add-scopes (syntax-e e)) e e)] 117 [(pair? e) (cons (add-scopes (car e)) 118 (add-scopes (cdr e)))] 119 [(box? e) 120 (box-immutable (add-scopes (unbox e)))] 121 [(vector? e) 122 (apply vector-immutable (map add-scopes (vector->list e)))] 123 [(hash? e) 124 (for/fold ([e e]) ([k (in-hash-keys e)]) 125 (hash-update e k add-scopes))] 126 [(prefab-struct-key e) 127 (define key (prefab-struct-key e)) 128 (apply make-prefab-struct key (map add-scopes (struct->list e)))] 129 [else e])) 130 131 (define (sli/use whole-stx) 132 ;(…)ˢˡⁱ⁼ ᵘˢᵉ⁼ 133 ;(…)ₛₗᵢ₌ ᵤₛₑ₌ 134 (if (syntax-transforming?) 135 (let* ([stx (datum->syntax whole-stx 'to-id)] 136 [sli (syntax-local-introduce stx)] 137 [stx-ids (extract-scope-ids stx)] 138 [sli-ids (extract-scope-ids sli)] 139 [stx-slb (syntax-local-identifier-as-binding stx)] 140 [sli-slb (syntax-local-identifier-as-binding sli)] 141 [stx-binding (extract-scope-ids stx-slb)] 142 [sli-binding (extract-scope-ids sli-slb)] 143 [use (append (set-symmetric-difference stx-ids stx-binding) 144 (set-symmetric-difference sli-ids sli-binding))] 145 [stx/sli-use (set-subtract (set-symmetric-difference stx-ids 146 sli-ids) 147 use)]) 148 (format "ˢˡⁱ⁼~a⁺ᵘˢᵉ⁼~a~a" 149 (string-join (map digits->superscripts (map ~a stx/sli-use)) 150 " ") 151 (string-join (map digits->superscripts (map ~a use)) 152 " ") 153 (if (sli-scopes) 154 (let* ([named ((sli-scopes) (datum->syntax #f 'zero))] 155 [named-scope-id (extract-scope-ids named)]) 156 (format "⁽ⁿᵃᵐᵉᵈ⁼~a⁾" 157 (string-join (map digits->superscripts 158 (map ~a named-scope-id)) 159 " "))) 160 ""))) 161 "")) 162 163 (define (+scopes stx) 164 (pretty-format "~a~a" 165 (syntax->datum (add-scopes stx)) 166 (sli/use stx))) 167 168 #;(define-syntax (foo stx) 169 (displayln (+scopes stx)) 170 #'(void)) 171 172 #;(foo a)