Various changes & bugfixes, more documentation.

info.rkt

@@ -1,8 +1,11 @@
 #lang info
 (define collection "debug-scopes")
 (define deps '("base"
-               "rackunit-lib"))
+               "rackunit-lib"
-(define build-deps '("scribble-lib" "racket-doc"))
+               "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")

main.rkt

@@ -1,145 +1,2 @@
-#lang racket
+#lang reprovide
-
+debug-scopes/superscripts
-(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)

named-scopes-sli-parameter.rkt

@@ -0,0 +1,4 @@
+#lang racket
+
+(provide sli-scopes)
+(define sli-scopes (make-parameter #f))

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
+         named-transformer)
-         (rename-out [-syntax-local-introduce syntax-local-introduce]))
 
 (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)))

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)]))
+    [(_ 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))

scribblings/debug-scopes.scrbl

@@ -1,10 +1,134 @@
 #lang scribble/manual
-@require[@for-label[debug-scopes
+@require[scribble/example
-                    racket/base]]
+         scribble-enhanced/doc
+         @for-label[debug-scopes
+                    racket/base
+                    racket/contract]]
 
-@title{debug-scopes}
+@title{Debuging scope-related issues}
-@author{georges}
+@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).}

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)