Initial commit

.gitignore

@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/

.travis.yml

@@ -0,0 +1,58 @@
+language: c
+
+# Based from: https://github.com/greghendershott/travis-racket
+
+# Optional: Remove to use Travis CI's older infrastructure.
+sudo: false
+
+env:
+  global:
+    # Supply a global RACKET_DIR environment variable. This is where
+    # Racket will be installed. A good idea is to use ~/racket because
+    # that doesn't require sudo to install and is therefore compatible
+    # with Travis CI's newer container infrastructure.
+    - RACKET_DIR=~/racket
+  matrix:
+    # Supply at least one RACKET_VERSION environment variable. This is
+    # used by the install-racket.sh script (run at before_install,
+    # below) to select the version of Racket to download and install.
+    #
+    # Supply more than one RACKET_VERSION (as in the example below) to
+    # create a Travis-CI build matrix to test against multiple Racket
+    # versions.
+    - RACKET_VERSION=6.0
+    - RACKET_VERSION=6.1
+    - RACKET_VERSION=6.1.1
+    - RACKET_VERSION=6.2
+    - RACKET_VERSION=6.3
+    - RACKET_VERSION=6.4
+    - RACKET_VERSION=6.5
+    - RACKET_VERSION=6.6
+    - RACKET_VERSION=6.7
+    - RACKET_VERSION=HEAD
+
+matrix:
+  allow_failures:
+#   - env: RACKET_VERSION=HEAD
+  fast_finish: true
+
+before_install:
+- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket
+- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh!
+- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
+
+install:
+ - raco pkg install --deps search-auto
+
+before_script:
+
+# Here supply steps such as raco make, raco test, etc.  You can run
+# `raco pkg install --deps search-auto` to install any required
+# packages without it getting stuck on a confirmation prompt.
+script:
+ - raco test -x -p debug-scopes
+
+after_success:
+ - raco setup --check-pkg-deps --pkgs debug-scopes
+ - raco pkg install --deps search-auto cover cover-coveralls
+ - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage .

LICENSE.txt

@@ -0,0 +1,11 @@
+debug-scopes
+Copyright (c) 2016 georges
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link debug-scopes into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

README.md

@@ -0,0 +1,3 @@
+debug-scopes
+============
+README text here.

info.rkt

@@ -0,0 +1,9 @@
+#lang info
+(define collection "debug-scopes")
+(define deps '("base"
+               "rackunit-lib"))
+(define build-deps '("scribble-lib" "racket-doc"))
+(define scribblings '(("scribblings/debug-scopes.scrbl" ())))
+(define pkg-desc "Description Here")
+(define version "0.0")
+(define pkg-authors '(georges))

main.rkt

@@ -0,0 +1,35 @@
+#lang racket/base
+
+(module+ test
+  (require rackunit))
+
+;; 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
+
+;; Code here
+
+(module+ test
+  ;; Tests to be run with raco test
+  )
+
+(module+ main
+  ;; Main entry point, executed when run with the `racket` executable or DrRacket.
+  )

named-scopes.rkt

@@ -0,0 +1,7 @@
+#lang racket
+
+(require debug-scopes/named-scopes/exptime)
+(require (for-template debug-scopes/named-scopes/override))
+
+(provide (all-from-out debug-scopes/named-scopes/exptime)
+         (for-template (all-from-out debug-scopes/named-scopes/override)))

named-scopes/dummy-lang.rkt

@@ -0,0 +1,10 @@
+#lang racket
+(provide (rename-out [my-module-begin #%module-begin]))
+(define-syntax (my-module-begin stx)
+  (syntax-case stx ()
+    [(_ real-lang body)
+     (syntax-case (local-expand #'(module m real-lang body) 'top-level (list)) ()
+       [(module nm lng (#%plain-module-begin . body2))
+        #`(#%plain-module-begin
+             (#%require real-lang)
+             . #,(values #'body2))])]))

named-scopes/exptime.rkt

@@ -0,0 +1,146 @@
+#lang racket
+
+(require (for-template '#%kernel)
+         type-expander/debug-scopes
+         racket/syntax
+         racket/struct
+         type-expander/debug-scopes)
+
+(provide make-named-scope
+         named-transformer
+         (rename-out [-syntax-local-introduce syntax-local-introduce]))
+
+(define (use-site-context?)
+  (not (bound-identifier=? (syntax-local-introduce #'here)
+                           (syntax-local-identifier-as-binding
+                            (syntax-local-introduce #'here)))))
+
+(define (make-named-scope nm)
+  (define name (if (symbol? nm) nm (string->symbol nm)))
+  (define E1
+    (local-expand (datum->syntax #f
+                                 `(,#'module
+                                   ,name
+                                   debug-scopes/named-scopes/dummy-lang
+                                   '#%kernel
+                                   list))
+                  'top-level
+                  (list)))
+  (define/with-syntax (_module _name _lang (_modbeg (_#%require QK1) Body1)) E1)
+  (define QK (datum->syntax #'QK1 'qk-sym))
+  (define Body (datum->syntax #'Body1 'body-sym))
+  (define Zero (datum->syntax #f 'zero))
+  (define ΔBody (make-syntax-delta-introducer Body Zero))
+  (define QK-Body (ΔBody QK 'remove))
+  (define ΔQK-Body (make-syntax-delta-introducer QK-Body Zero))
+  (define QK-rest (ΔQK-Body QK 'remove))
+  (define named-scope (make-syntax-delta-introducer QK-rest Zero))
+  named-scope)
+
+(define ((has-scope scope) stx)
+  (and (identifier? stx)
+       (bound-identifier=? stx (scope stx 'add))))
+
+(define (replace-scope old new)
+  (define (replace e)
+    (cond
+      [(syntax? e)
+       (datum->syntax (if ((has-scope old) e)
+                          (new (old e 'remove) 'add)
+                          e)
+                      (replace (syntax-e e))
+                      e
+                      e)]
+      [(pair? e) (cons (replace (car e)) (replace (cdr e)))]
+      [(vector? e) (list->vector (replace (vector->list e)))]
+      [(hash? e)
+       (cond [(hash-eq? e) (make-hasheq (replace (hash->list e)))]
+             [(hash-eqv? e) (make-hasheqv (replace (hash->list e)))]
+             [(hash-equal? e) (make-hash (replace (hash->list e)))]
+             [else e])]
+      [(prefab-struct-key e)
+       => (λ (k)
+            (apply make-prefab-struct k (replace (struct->list e))))]
+      [else e]))
+  replace)
+
+(define (deep-has-scope sc)
+  (define (scan e)
+    (cond
+      [(syntax? e) (or ((has-scope sc) e) (scan (syntax-e e)))]
+      [(pair? e) (or (scan (car e)) (scan (cdr e)))]
+      [(vector? e) (scan (vector->list e))]
+      [(hash? e) (scan (hash->list e))]
+      [(prefab-struct-key e) (scan (struct->list e))]
+      [else #f]))
+  scan)
+
+(define (old-macro-scope)
+  (make-syntax-delta-introducer
+   (syntax-local-identifier-as-binding
+    (syntax-local-introduce
+     (datum->syntax #f 'zero)))
+   (datum->syntax #f 'zero)))
+
+(define (old-use-site-scope)
+  (make-syntax-delta-introducer
+   ((old-macro-scope) (syntax-local-introduce (datum->syntax #f 'zero)) 'remove)
+   (datum->syntax #f 'zero)))
+
+(define (convert-macro-scopes stx)
+  (if (sli-scopes)
+      (let* ([macro (car (sli-scopes))]
+             [use-site (cdr (sli-scopes))]
+             [old-macro (old-macro-scope)]
+             [old-use (old-use-site-scope)])
+        ((compose (if (use-site-context?)
+                      (replace-scope old-use use-site)
+                      (λ (x) x))
+                  (replace-scope old-macro macro))
+         stx))
+      ;; Otherwise leave unchanged.
+      stx))
+
+(define ((named-transformer-wrap name f) stx)
+  (parameterize ([sli-scopes
+                  (cons (make-named-scope (format "macro: ~a" name))
+                        (if (use-site-context?)
+                            (make-named-scope (format "use-site: ~a" name))
+                            (make-syntax-delta-introducer
+                             (datum->syntax #f 'zero)
+                             (datum->syntax #f 'zero))))])
+    ;;; TODO: we should detect the presence of old-* here instead, and 'add them
+    (displayln (+scopes stx))
+    (displayln (use-site-context?))
+    (displayln (+scopes (convert-macro-scopes stx)))
+    (let ([res (f (convert-macro-scopes stx))])
+      (when ((deep-has-scope (old-macro-scope)) res)
+        (error (format "original macro scope appeared within the result of a named transformer: ~a\n~a\n~a"
+                       res
+                       (+scopes res)
+                       (with-output-to-string (λ () (print-full-scopes))))))
+      (when (and (use-site-context?)
+                 ((deep-has-scope (old-use-site-scope)) res))
+        (error "original use-site scope appeared within the result of a named transformer"))
+      (let* ([/mm ((car (sli-scopes)) res 'flip)]
+             [/mm/uu (if (use-site-context?) ((cdr (sli-scopes)) /mm 'flip) /mm)]
+             [/mm/uu+m ((old-macro-scope) /mm/uu 'add)])
+        (if (use-site-context?)
+            ((old-use-site-scope) /mm/uu+m 'add)
+            /mm/uu+m)))))
+
+(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)
+      ((cdr (sli-scopes)) ((car (sli-scopes)) stx 'flip)
+                          'flip)
+      (syntax-local-introduce stx)))
+
+(define (-syntax-local-identifier-as-binding stx)
+  (if (and (sli-scopes) (use-site-context?))
+      ((cdr (sli-scopes)) stx 'flip)
+      (syntax-local-introduce stx)))

named-scopes/override.rkt

@@ -0,0 +1,12 @@
+#lang racket
+
+(require (for-syntax "exptime.rkt"))
+
+(provide (rename-out [-define-syntax define-syntax]))
+
+(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)]))

scribblings/debug-scopes.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/manual
+@require[@for-label[debug-scopes
+                    racket/base]]
+
+@title{debug-scopes}
+@author{georges}
+
+@defmodule[debug-scopes]
+
+Package Description Here

test/named-scopes-test-def.rkt

@@ -0,0 +1,24 @@
+#lang racket
+
+(require (for-syntax debug-scopes/named-scopes
+                     type-expander/debug-scopes ;;;
+                     syntax/stx))
+
+(begin-for-syntax
+  (define-syntax-rule (named-transformer (_ stx) . body) (λ (stx) . body))
+  (define (make-named-scope _) (make-syntax-introducer)))
+
+(provide foo-macro bar-macro baz-macro)
+
+(define-syntax (foo-macro stx)
+  (syntax-case stx ()
+    [(_ a)
+     (let ([foo-scope (make-named-scope 'my-foo-scope-wohoo)])
+       (foo-scope #'a))]))
+
+(define-syntax bar-macro
+  (named-transformer (bar-macro stx)
+    #`(let ([x 1]) . #,(stx-cdr stx))))
+
+(define-syntax (baz-macro stx)
+  #`(let ([x 5]) . #,(stx-cdr stx)))

test/named-scopes-test-use.rkt

@@ -0,0 +1,32 @@
+#lang racket
+
+(require ;"named-scopes-test-def.rkt"
+         rackunit
+         (for-syntax type-expander/debug-scopes
+                     ;debug-scopes/named-scopes
+                     ))
+
+#|
+(define r1 (foo-macro +))
+(define r2 (let ([x 2])
+                (bar-macro x)))
+(define r3 (let ([x 3])
+                (baz-macro x)))
+
+(define r4 (let ()
+             (define-syntax (quux stx)
+               (syntax-local-introduce #'+))
+             (quux)))
+
+(check-equal? (list r1 r2 r3 r4) (list + 2 3 +))
+|#
+
+(define-syntax (quux stx)
+  (syntax-case stx ()
+    [(_ m)
+     (let ()
+       (displayln (+scopes #'m))
+       (displayln (+scopes (syntax-local-introduce #'+)))
+       (print-full-scopes)
+       (syntax-local-introduce #'+))]))
+(quux -)