Moved in the debug-scopes.rkt from type-expander/debug-scopes
This commit is contained in:
Georges Dupéron
parent
61d4a48d38
commit
85ff1f085e
170
main.rkt
170
main.rkt
|
|
@ -1,35 +1,145 @@
|
|||
#lang racket/base
|
||||
#lang racket
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
(require racket/syntax
|
||||
racket/string
|
||||
racket/format)
|
||||
|
||||
;; Notice
|
||||
;; To install (from within the package directory):
|
||||
;; $ raco pkg install
|
||||
;; To install (once uploaded to pkgs.racket-lang.org):
|
||||
;; $ raco pkg install <<name>>
|
||||
;; To uninstall:
|
||||
;; $ raco pkg remove <<name>>
|
||||
;; To view documentation:
|
||||
;; $ raco docs <<name>>
|
||||
;;
|
||||
;; For your convenience, we have included a LICENSE.txt file, which links to
|
||||
;; the GNU Lesser General Public License.
|
||||
;; If you would prefer to use a different license, replace LICENSE.txt with the
|
||||
;; desired license.
|
||||
;;
|
||||
;; Some users like to add a `private/` directory, place auxiliary files there,
|
||||
;; and require them in `main.rkt`.
|
||||
;;
|
||||
;; See the current version of the racket style guide here:
|
||||
;; http://docs.racket-lang.org/style/index.html
|
||||
(provide +scopes print-full-scopes)
|
||||
|
||||
;; Code here
|
||||
(define max-seen-scopes 0)
|
||||
(define seen-scopes (make-hash))
|
||||
|
||||
(module+ test
|
||||
;; Tests to be run with raco test
|
||||
)
|
||||
(define (print-full-scopes)
|
||||
(define scopes (sort (hash->list seen-scopes) < #:key cadr))
|
||||
(define l
|
||||
(map (λ (s)
|
||||
(format "~a ~a"
|
||||
(cadr s)
|
||||
(string-join (map ~a (cdr (vector->list (cddr s))))
|
||||
" ")))
|
||||
scopes))
|
||||
(define max-len (apply max (map string-length l)))
|
||||
(define (pad str)
|
||||
(string-append
|
||||
str
|
||||
(make-string (- max-len (string-length str)) (string-ref " " 0))))
|
||||
(for-each (λ (s str)
|
||||
(printf "~a ~a\n"
|
||||
(pad str)
|
||||
(vector-ref (cddr s) 0)))
|
||||
scopes
|
||||
l)
|
||||
(hash-clear! seen-scopes)
|
||||
(set! max-seen-scopes 0))
|
||||
|
||||
(module+ main
|
||||
;; Main entry point, executed when run with the `racket` executable or DrRacket.
|
||||
)
|
||||
(define (string-replace* str replacements)
|
||||
(if (null? replacements)
|
||||
str
|
||||
(string-replace* (string-replace str
|
||||
(caar replacements)
|
||||
(cadar replacements))
|
||||
(cdr replacements))))
|
||||
|
||||
(define (digits->superscripts str)
|
||||
(string-replace* str '(["0" "⁰"]
|
||||
["1" "¹"]
|
||||
["2" "²"]
|
||||
["3" "³"]
|
||||
["4" "⁴"]
|
||||
["5" "⁵"]
|
||||
["6" "⁶"]
|
||||
["7" "⁷"]
|
||||
["8" "⁸"]
|
||||
["9" "⁹"])))
|
||||
|
||||
(define (digits->subscripts str)
|
||||
(string-replace* str '(["0" "₀"]
|
||||
["1" "₁"]
|
||||
["2" "₂"]
|
||||
["3" "₃"]
|
||||
["4" "₄"]
|
||||
["5" "₅"]
|
||||
["6" "₆"]
|
||||
["7" "₇"]
|
||||
["8" "₈"]
|
||||
["9" "₉"])))
|
||||
|
||||
(define (change-digits1 l [mode #t])
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons ((if mode digits->superscripts digits->subscripts) (car l))
|
||||
(change-digits1 (cdr l) (not mode)))))
|
||||
|
||||
(define (change-digits2 l)
|
||||
(let ([min-id (apply min l)]
|
||||
[max-id (apply max l)])
|
||||
(format "~a˙˙~a~a"
|
||||
(digits->superscripts (~a min-id))
|
||||
(digits->superscripts (~a max-id))
|
||||
(string-join (map (λ (x)
|
||||
(format "⁻~a" (digits->superscripts (~a x))))
|
||||
(filter-not (λ (x) (member x l))
|
||||
(range min-id (add1 max-id))))
|
||||
""))))
|
||||
|
||||
(define (change-digits l)
|
||||
(let ([a (string-join (change-digits1 (map ~a l)) "")])
|
||||
(if (null? l)
|
||||
a
|
||||
(let ([b (change-digits2 l)])
|
||||
(if (or (and (< (string-length a) (string-length b))
|
||||
(> (string-length a) 4))
|
||||
(= (length l) 1))
|
||||
a
|
||||
b)))))
|
||||
|
||||
(define (extract-scope-ids e)
|
||||
(map (λ (c)
|
||||
(car (hash-ref! seen-scopes (vector-ref c 0)
|
||||
(λ ()
|
||||
(begin0 (cons max-seen-scopes c)
|
||||
(set! max-seen-scopes
|
||||
(add1 max-seen-scopes)))))))
|
||||
(hash-ref (syntax-debug-info e) 'context)))
|
||||
|
||||
(define (add-scopes e)
|
||||
(cond
|
||||
[(identifier? e)
|
||||
(let ([ids (extract-scope-ids e)])
|
||||
;(format-id e "~a⁽~a⁾" e (string-join (map digits->superscripts
|
||||
; (map ~a ids)) " ")))
|
||||
(format-id e "~a~a" e (change-digits ids)))]
|
||||
[(syntax? e) (datum->syntax e (add-scopes (syntax-e e)) e e)]
|
||||
[(pair? e) (cons (add-scopes (car e))
|
||||
(add-scopes (cdr e)))]
|
||||
[else e]))
|
||||
|
||||
(define (sli/use whole-stx)
|
||||
;(…)ˢˡⁱ⁼ ᵘˢᵉ⁼
|
||||
;(…)ₛₗᵢ₌ ᵤₛₑ₌
|
||||
(let* ([stx (datum->syntax whole-stx 'to-id)]
|
||||
[sli (syntax-local-introduce stx)]
|
||||
[stx-ids (extract-scope-ids stx)]
|
||||
[sli-ids (extract-scope-ids sli)]
|
||||
[stx-slb (syntax-local-identifier-as-binding stx)]
|
||||
[sli-slb (syntax-local-identifier-as-binding sli)]
|
||||
[stx-binding (extract-scope-ids stx-slb)]
|
||||
[sli-binding (extract-scope-ids sli-slb)]
|
||||
[use (append (set-symmetric-difference stx-ids stx-binding)
|
||||
(set-symmetric-difference sli-ids sli-binding))]
|
||||
[stx/sli-use (set-subtract (set-symmetric-difference stx-ids sli-ids)
|
||||
use)])
|
||||
(format "ˢˡⁱ⁼~a⁺ᵘˢᵉ⁼~a"
|
||||
(string-join (map digits->superscripts (map ~a stx/sli-use)) " ")
|
||||
(string-join (map digits->superscripts (map ~a use)) " "))))
|
||||
|
||||
(define (+scopes stx)
|
||||
(format "~a~a"
|
||||
(syntax->datum (add-scopes stx))
|
||||
(sli/use stx)))
|
||||
|
||||
#;(define-syntax (foo stx)
|
||||
(displayln (+scopes stx))
|
||||
#'(void))
|
||||
|
||||
#;(foo a)
|
||||
Loading…
Reference in New Issue
Block a user