commit 2c8423ac166e6345a9bd54c4d4863dad5a398622
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 14 Dec 2016 17:44:42 +0100
Initial commit
Diffstat:
13 files changed, 368 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/
diff --git a/.travis.yml b/.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 .
diff --git a/LICENSE.txt b/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.
diff --git a/README.md b/README.md
@@ -0,0 +1,3 @@
+debug-scopes
+============
+README text here.
diff --git a/info.rkt b/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))
diff --git a/main.rkt b/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.
+ )
diff --git a/named-scopes.rkt b/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)))
+\ No newline at end of file
diff --git a/named-scopes/dummy-lang.rkt b/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))])]))
+\ No newline at end of file
diff --git a/named-scopes/exptime.rkt b/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)))
+\ No newline at end of file
diff --git a/named-scopes/override.rkt b/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)]))
+\ No newline at end of file
diff --git a/scribblings/debug-scopes.scrbl b/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
diff --git a/test/named-scopes-test-def.rkt b/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)))
diff --git a/test/named-scopes-test-use.rkt b/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 -)
+\ No newline at end of file
