From c8ff9f9532079fa16f5d208cfd190252a38c85a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 14 Dec 2016 19:49:33 +0100 Subject: [PATCH] Various changes & bugfixes, more documentation. --- info.rkt | 7 +- main.rkt | 147 +------------------------------ named-scopes-sli-parameter.rkt | 4 + named-scopes/exptime.rkt | 13 +-- named-scopes/override.rkt | 29 ++++++- scribblings/debug-scopes.scrbl | 134 ++++++++++++++++++++++++++-- superscripts.rkt | 154 +++++++++++++++++++++++++++++++++ 7 files changed, 323 insertions(+), 165 deletions(-) create mode 100644 named-scopes-sli-parameter.rkt create mode 100644 superscripts.rkt diff --git a/info.rkt b/info.rkt index 2ed1979..5ddd324 100644 --- a/info.rkt +++ b/info.rkt @@ -1,8 +1,11 @@ #lang info (define collection "debug-scopes") (define deps '("base" - "rackunit-lib")) -(define build-deps '("scribble-lib" "racket-doc")) + "rackunit-lib" + "reprovide-lang")) +(define build-deps '("scribble-lib" + "racket-doc" + "scribble-enhanced")) (define scribblings '(("scribblings/debug-scopes.scrbl" ()))) (define pkg-desc "Description Here") (define version "0.0") diff --git a/main.rkt b/main.rkt index b85c769..0ad4839 100644 --- a/main.rkt +++ b/main.rkt @@ -1,145 +1,2 @@ -#lang racket - -(require racket/syntax - racket/string - racket/format) - -(provide +scopes print-full-scopes) - -(define max-seen-scopes 0) -(define seen-scopes (make-hash)) - -(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)) - -(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) \ No newline at end of file +#lang reprovide +debug-scopes/superscripts \ No newline at end of file diff --git a/named-scopes-sli-parameter.rkt b/named-scopes-sli-parameter.rkt new file mode 100644 index 0000000..44f9320 --- /dev/null +++ b/named-scopes-sli-parameter.rkt @@ -0,0 +1,4 @@ +#lang racket + +(provide sli-scopes) +(define sli-scopes (make-parameter #f)) \ No newline at end of file diff --git a/named-scopes/exptime.rkt b/named-scopes/exptime.rkt index 078334b..f2e310b 100644 --- a/named-scopes/exptime.rkt +++ b/named-scopes/exptime.rkt @@ -4,11 +4,11 @@ debug-scopes racket/syntax racket/struct - debug-scopes) + debug-scopes + debug-scopes/named-scopes-sli-parameter) (provide make-named-scope - named-transformer - (rename-out [-syntax-local-introduce syntax-local-introduce])) + named-transformer) (define (make-named-scope nm) (define name (if (symbol? nm) nm (string->symbol nm))) @@ -98,10 +98,3 @@ (define-syntax-rule (named-transformer (name stx) . body) (named-transformer-wrap 'name (λ (stx) . body))) - -(define sli-scopes (make-parameter #f)) - -(define (-syntax-local-introduce stx) - (if (sli-scopes) - ((sli-scopes) stx 'flip) - (syntax-local-introduce stx))) diff --git a/named-scopes/override.rkt b/named-scopes/override.rkt index c43395e..6194110 100644 --- a/named-scopes/override.rkt +++ b/named-scopes/override.rkt @@ -1,12 +1,35 @@ #lang racket -(require (for-syntax "exptime.rkt")) +(require (for-syntax "exptime.rkt" + debug-scopes/named-scopes-sli-parameter)) -(provide (rename-out [-define-syntax define-syntax])) +(define-for-syntax (use-site-context?) + (not (bound-identifier=? (syntax-local-introduce #'here) + (syntax-local-identifier-as-binding + (syntax-local-introduce #'here))))) + +(provide (rename-out [-define-syntax define-syntax]) + (for-syntax + (rename-out [-syntax-local-introduce syntax-local-introduce]))) (define-syntax (-define-syntax stx) (syntax-case stx () [(_ (name arg) . body) #'(define-syntax name (named-transformer (name arg) . body))] - [(_ name value) #'(define-syntax name value)])) \ No newline at end of file + [(_ name value) #'(define-syntax name value)])) + +(define-for-syntax (-syntax-local-introduce stx) + (define /m (if (sli-scopes) + ((sli-scopes) stx 'flip) + (syntax-local-introduce stx))) + (if (use-site-context?) + (let* ([zero (datum->syntax #f 'zero)] + [sli (syntax-local-introduce zero)] + [sli-use (syntax-local-identifier-as-binding sli)] + [+sli (make-syntax-delta-introducer sli zero)] + [+sli-use (make-syntax-delta-introducer sli-use zero)] + [use (+sli-use sli 'remove)] + [+use (make-syntax-delta-introducer use zero)]) + (+use /m)) + /m)) diff --git a/scribblings/debug-scopes.scrbl b/scribblings/debug-scopes.scrbl index 0259660..3e1b239 100644 --- a/scribblings/debug-scopes.scrbl +++ b/scribblings/debug-scopes.scrbl @@ -1,10 +1,134 @@ #lang scribble/manual -@require[@for-label[debug-scopes - racket/base]] +@require[scribble/example + scribble-enhanced/doc + @for-label[debug-scopes + racket/base + racket/contract]] -@title{debug-scopes} -@author{georges} +@title{Debuging scope-related issues} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} @defmodule[debug-scopes] -Package Description Here +@defproc[(+scopes [stx syntax?]) string?]{The identifiers are adorned with + superscripts indicating the scopes present on them. Each scope is represented + as an ascending integer which is unique within the current expansion. At the + end of the expansion, a table showing the equivalence between the small + integers and the scopes as represented by Racket is printed. Ranges of + consecutive scopes are represented as @racket[identifier³˙˙⁹] (which would + indicate that the scopes 3, 4, 5, 6, 7, 8 and 9 are present on the + identifier). When only a few scopes are missing from the range, they are + printed as @racket[identifier³˙˙⁹⁻⁵⁻⁷] (which would indicate that the scopes + 3, 4, 6, 8 and 9 are present on the identifier). When there are too many + missing identifiers within the range, the scopes are instead displayed + alternatively as superscripts and subscripts, e.g. + @racket[identifier²₃⁵₇¹¹₁₃¹⁷₁₉] (which would indicate that only the scopes 2, + 3, 5, 7, 11, 17 and 19 are present on the identifier, and would also indicate + that a developer is playing a trick on you). Finally the current macro scope + (which can be removed using @racket[syntax-local-value]) and the current + use-site scope, if any (which can be removed using + @racket[syntax-local-identifier-as-binding]) is printed for the whole + expression, using the notation @racket[(expression …)ˢˡⁱ⁼⁴⁺ᵘˢᵉ⁼¹²] (which + would indicate that the macro scope is 4 and the use-site scope is 12). + + @examples[#:lang racket + (require (for-syntax racket/base + debug-scopes)) + (define-syntax (foo stx) + (displayln (+scopes stx)) + (displayln (+scopes (datum->syntax #f 'no-scopes))) + (displayln (+scopes (syntax-local-introduce #'here))) + (print-full-scopes) + #'(void)) + + (foo (list 123))] + + When using @racketmodname[debug-scopes/named-scopes], a named scope is often + used instead of the macro scope flipped by @racket[syntax-local-introduce]. If + @racket[+scopes] is called within that context, it also annotates the whole + expression with the named scope which acts as a replacement for the macro + scope, using the notation @racket[(expression …)ˢˡⁱ⁼⁴⁺ᵘˢᵉ⁼¹²⁽ⁿᵃᵐᵉᵈ⁼⁵⁾] (which + would indicate that the original macro scope was 4, the use-site-scope is 12, + and the named macro scope is 5). + +@examples[#:lang racket + (require (for-syntax (except-in racket/base syntax-local-introduce) + debug-scopes + debug-scopes/named-scopes)) + (define-syntax (foo stx) + (displayln (+scopes stx)) + (displayln (+scopes (datum->syntax #f 'no-scopes))) + (displayln (+scopes (syntax-local-introduce #'here))) + (print-full-scopes) + #'(void)) + + (foo (list 123))]} + +@defproc[(print-full-scopes) void?]{ Prints the long scope id and annotation + for all scopes displayed as part of preceeding calls to @racket[+scopes], as + would be shown by @racket[(hash-ref (syntax-debug-info stx) 'context)]. + + This allows to get some extended information about the scopes in a summary + table by calling @racket[print-full-scopes], while still getting short and + readable display of syntax objects with @racket[+scopes].} + +@section{Hack for named scopes} + +@defmodule[debug-scopes/named-scopes] + +Module scopes bear are annotated by Racket with the name of the module. As of +December 2016, other scopes like macro scopes@note{Both the ones implicitly + created when a macro is called, and the ones explicitly created via + @racket[make-syntax-introducer] are concerned by this} or use-site scopes lack +any form of annotation or naming. + +@defproc[(make-named-scope [name (or/c string? symbol?)]) + (->* (syntax?) ([or/c 'add 'remove 'flip]) syntax?)]{ This function + uses a hack to create named scopes on demand: it creates a dummy mododule with + the desired name, expands it and extracts the module's scope. The exact + implementation mechanism may vary in future versions, for example if later + versions of Racket directly support the creation of named scopes, + @racket[make-named-scope] would simply become an alias for the official + mechanism.} + +@define[orig:define-syntax @racket[define-syntax]] +@define[orig:syntax-local-introduce @racket[syntax-local-introduce]] + +@subsection{Automatic use of named scopes} + +@defmodule[debug-scopes/named-scopes/override] + +This module overrides @orig:define-syntax and @orig:syntax-local-introduce to +automatically use a named macro scope. The use-site scope is not affected for +now, as the original unnamed use-site scope from Racket benefits from special +cooperation from definition contexts, which would be hard to achieve with the +hack currently used to implement named scopes. + +@defform*[((define-syntax (name stx-arg) . body) + (define-syntax name value))]{ + + Like @orig:define-syntax, but the first form changes the macro scope + introduced by @racket[syntax-local-introduce] to use a named scope, bearing + the @racket[name] of the macro. + + Note that this change only affects the scopes introduced by the overriden + version of @racket[syntax-local-introduce], not the original + @|orig:syntax-local-introduce|. + + This means that if the macro calls a function defined in another file which + uses the non-overidden version of @orig:syntax-local-introduce, both the + original unnamed scope and the named scope may accidentally appear in the + result. Macros defined using the overridden @racket[syntax-local-introduce] + should therefore take special care to always use the overridden version of + @racket[syntax-local-introduce]. + + The use-site scope is not affected for now, as the original unnamed use-site + scope from Racket benefits from special cooperation from definition contexts, + which would be hard to achieve with the hack currently used to implement named + scopes.} + +@defproc[(syntax-local-introduce [stx syntax?]) syntax?]{ Like + @orig:syntax-local-introduce, but uses the named scope set up by + @racket[define-syntax] if called within the dynamic extent of a call to a + macro defined by the overridden @racket[define-syntax] (and otherwise behaves + like the original @orig:syntax-local-introduce).} \ No newline at end of file diff --git a/superscripts.rkt b/superscripts.rkt new file mode 100644 index 0000000..c6222de --- /dev/null +++ b/superscripts.rkt @@ -0,0 +1,154 @@ +#lang racket + +(require racket/syntax + racket/string + racket/format + debug-scopes/named-scopes-sli-parameter) + +(provide +scopes print-full-scopes) + +(define max-seen-scopes 0) +(define seen-scopes (make-hash)) + +(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)) + +(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~a" + (string-join (map digits->superscripts (map ~a stx/sli-use)) " ") + (string-join (map digits->superscripts (map ~a use)) " ") + (if (sli-scopes) + (let* ([named ((sli-scopes) (datum->syntax #f 'zero))] + [named-scope-id (extract-scope-ids named)]) + (format "⁽ⁿᵃᵐᵉᵈ⁼~a⁾" + (string-join (map digits->superscripts + (map ~a named-scope-id)) + " "))) + "")))) + +(define (+scopes stx) + (format "~a~a" + (syntax->datum (add-scopes stx)) + (sli/use stx))) + +#;(define-syntax (foo stx) + (displayln (+scopes stx)) + #'(void)) + +#;(foo a) \ No newline at end of file