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 scope-operations
+
+after_success:
+ - raco setup --check-pkg-deps --pkgs scope-operations
+ - 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 @@
+scope-operations
+Copyright (c) 2016 georges
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link scope-operations 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 @@
+scope-operations
+================
+README text here.

info.rkt

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

main.rkt

@@ -0,0 +1,100 @@
+#lang racket
+
+(provide scopes/c
+         →scopes
+         →scopes*
+         (rename-out [→scopes ->scopes]
+                     [→scopes* ->scopes*])
+         empty-scopes
+         scopes-add
+         scopes-remove
+         scopes-flip
+         scopes-intersect
+         (rename-out [scopes-flip scopes-symmetric-difference])
+         single-scope?
+         scope-kind
+         use-site-scope?
+         macro-scope?
+         module-scope?
+         intdef-scope?
+         local-scope?
+         top-scope?)
+
+(define scopes/c
+  (->* (syntax?) ([or/c 'add 'remove 'flip]) syntax?))
+
+(define/contract (→scopes stx)
+  (-> syntax? scopes/c)
+  (make-syntax-delta-introducer (datum->syntax stx 'stx)
+                                (datum->syntax #f 'zero)))
+
+(define/contract empty-scopes
+  scopes/c
+  (→scopes (datum->syntax #f 'zero)))
+
+(define/contract (→scopes* stx)
+  (-> (or/c syntax? scopes/c) scopes/c)
+  (if (syntax? stx)
+      (→scopes stx)
+      stx))
+
+(define/contract (scopes-add sc1 sc2)
+  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
+  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes)
+                           'add)))
+
+(define/contract (scopes-remove sc1 sc2)
+  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
+  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes)
+                           'remove)))
+
+(define/contract (scopes-flip sc1 sc2)
+  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
+  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes)
+                           'flip)))
+
+(define/contract (scopes-intersect sc1 sc2)
+  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
+  (scopes-remove sc1 (scopes-remove sc1 sc2)))
+
+#;(define/contract (scopes-symmetric-difference sc1 sc2)
+    (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
+    (scopes-add (scopes-remove sc1 sc2)
+                (scopes-remove sc2 sc1)))
+
+(define/contract (single-scope? sc)
+  (-> (or/c syntax? scopes/c) boolean?)
+  (= (length (hash-ref (syntax-debug-info ((→scopes* sc) empty-scopes))
+                       'context))))
+
+(define/contract (scope-kind sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) symbol?)
+  (define stx ((→scopes* sc) empty-scopes))
+  (vector-ref (list-ref (hash-ref (syntax-debug-info stx) 'context) 0) 1))
+
+(define/contract (use-site-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'use-site))
+
+(define/contract (macro-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'macro))
+
+(define/contract (module-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'module))
+
+(define/contract (intdef-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'intdef))
+
+(define/contract (local-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'local))
+
+;; Untested, I've seen this once, but can't remember where exactly. I think it
+;; occured while expanding a module with local-expand, and injecting the
+;; expanded body somewhere else.
+(define/contract (top-scope? sc)
+  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
+  (eq? (scope-kind sc) 'top))

scribblings/scope-operations.scrbl

@@ -0,0 +1,95 @@
+#lang scribble/manual
+@require[@for-label[scope-operations
+                    racket/base]]
+
+@title{scope-operations}
+@author{georges}
+
+@defmodule[scope-operations]
+
+@defproc[(scopes/c [v any/c]) boolean?]{                                       
+ Contract which recognizes a set of scopes, represented as an introducer
+ function. Equivalent to:
+ @racketblock[(->* (syntax?)
+                   ([or/c 'add 'remove 'flip])
+                   syntax?)]
+}
+
+@defproc*[(((→scopes [stx syntax?]) scopes/c)
+           ((->scopes [stx syntax?]) scopes/c))]{
+ Extracts the scopes present on the topmost syntax object of @racket[stx].
+ This is equivalent to:
+
+ @racket[
+ (make-syntax-delta-introducer (datum->syntax stx 'stx)
+                               (datum->syntax #f 'zero))]
+
+ Unlike a @racket[make-syntax-delta-introducer], this procedure does not
+ expect a second argument (always creating an introducer for all the scopes
+ present on @racket[stx]), and works on syntax objects which are not
+ identifiers.}
+
+@defproc*[(((→scopes* [stx (or/c syntax? scopes/c)]) scopes/c)
+           ((->scopes* [stx (or/c syntax? scopes/c)]) scopes/c))]{
+ Lenient version of @racket[→scopes], which acts as a no-op when passed a set
+ of scopes, instead of raising an error.}
+
+@defthing[empty-scopes]{
+ The empty set of scopes, as produced by:
+ @racketblock[(→scopes (datum->syntax #f 'zero))]
+}
+
+@defproc[(scopes-add [sc1 (or/c syntax? scopes/c)]
+                     [sc2 (or/c syntax? scopes/c)])
+         scopes/c]{Set union of the given sets of scopes.}
+
+@defproc[(scopes-remove [sc1 (or/c syntax? scopes/c)]
+                        [sc2 (or/c syntax? scopes/c)])
+         scopes/c]{Set difference of the given sets of scopes.
+
+ The resulting set of scopes contains all the scopes present in @racket[sc1]
+ which are not present in @racket[sc2].}
+
+@defproc*[(((scopes-flip [sc1 (or/c syntax? scopes/c)]
+                         [sc2 (or/c syntax? scopes/c)])
+            scopes/c)
+           ((scopes-symmetric-difference [sc1 (or/c syntax? scopes/c)]
+                                         [sc2 (or/c syntax? scopes/c)])
+            scopes/c))]{
+
+ Flips the scopes in @racket[sc2] on the @racket[sc1] set of scopes.
+ 
+ The resulting set of scopes contains all the scopes present in @racket[sc1]
+ which are not present in @racket[sc2], as well as the scopes present in
+ @racket[sc2] which were not present in @racket[sc1].
+
+ Flipping the @racket[sc2] scopes on @racket[sc1] has the same effect as
+ computing the symmetric difference of the two sets of scopes.}
+
+@defproc[(scopes-intersect [sc1 (or/c syntax? scopes/c)]
+                           [sc2 (or/c syntax? scopes/c)])
+         scopes/c]{Set intersection of the given sets of scopes.}
+
+
+@defproc[(single-scope? [sc (or/c syntax? scopes/c)]) boolean?]{
+ Predicate which returns @racket[#true] iff the given set of scopes contains
+ only a single scope.}
+
+@defproc[(scope-kind [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         symbol?]{
+ Returns the kind of the single scope in @racket[sc]. To my knowledge, this
+ will be one of @racket[use-site], @racket[macro], @racket[module],
+ @racket[intdef], @racket[local] or @racket[top].}
+
+@defproc[(use-site-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'use-site)]}
+@defproc[(macro-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'macro)]}
+@defproc[(module-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'module)]}
+@defproc[(intdef-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'intdef)]}
+@defproc[(local-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'local)]}
+@defproc[(top-scope? [sc (and/c (or/c syntax? scopes/c) single-scope?)])
+         boolean?]{A shorthand for @racket[(eq? (scope-kind sc) 'top)]}

short.rkt

@@ -0,0 +1,25 @@
+#lang racket
+
+(require scope-operations)
+(provide scopes/c
+         →scopes
+         →scopes*
+         ->scopes
+         ->scopes*
+         (rename-out [empty-scopes scopes0]
+                     [scopes-add scopes+]
+                     [scopes-add scopes∪]
+                     [scopes-remove scopes-]
+                     [scopes-flip scopes~]
+                     [scopes-intersect scopes∩]
+                     [scopes-symmetric-difference scopesΔ]
+                     [scopes-symmetric-difference scopes⊖]
+                     [scopes-symmetric-difference scopes⊕])
+         single-scope?
+         scope-kind
+         use-site-scope?
+         macro-scope?
+         module-scope?
+         intdef-scope?
+         local-scope?
+         top-scope?)