syntax/parse: added phase options to define-literal-set

collects/syntax/parse/private/litconv.rkt

@@ -3,6 +3,7 @@
                      "sc.rkt"
                      "lib.rkt"
                      unstable/syntax
+                     syntax/keyword
                      "rep-data.rkt"
                      "rep.rkt"
                      "kws.rkt")
@@ -57,25 +58,52 @@
                def ...
                (list parser ...)))))]))
 
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
 (define-syntax (define-literal-set stx)
   (syntax-case stx ()
-    [(define-literal-set name (lit ...))
+    [(define-literal-set name . rest)
-     (let ([phase-of-definition (syntax-local-phase-level)])
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
        (unless (identifier? #'name)
          (raise-syntax-error #f "expected identifier" stx #'name))
-       (let ([lits (check-literals-list/litset #'(lit ...) stx)])
+       (let ([relphase
-         (with-syntax ([((internal external) ...) lits])
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (check-literals-list/litset #'(lit ...) stx)]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])])
+         (with-syntax ([((internal external) ...) lits]
+                       [relphase relphase])
            #`(begin
                (define phase-of-literals
-                 (phase-of-enclosing-module))
+                 (if 'relphase
+                     (+ (phase-of-enclosing-module) 'relphase)
+                     'relphase))
                (define-syntax name
                  (make-literalset
                   (list (list 'internal (quote-syntax external)) ...)
                   (quote-syntax phase-of-literals)))
                (begin-for-syntax/once
                 (for ([x (in-list (syntax->list #'(external ...)))])
-                  (unless (identifier-binding x 0)
+                  (unless (identifier-binding x 'relphase)
-                    (raise-syntax-error #f "literal is unbound in phase 0"
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a" 'relphase)
                                         (quote-syntax #,stx) x))))))))]))
 
 (define-syntax (phase-of-enclosing-module stx)

collects/syntax/parse/private/runtime.rkt

@@ -266,9 +266,10 @@
                   (eq? namex namey)
                   (equal? phasex phasey)))]
           [else
+           (and (eq? bx 'lexical) (eq? by 'lexical)
                 ;; One must be lexical (can't be #f, since one must be bound)
                 ;; lexically-bound names bound in only one phase; just compare
-           (free-identifier=? x y)])))
+                (free-identifier=? x y))])))
 
 ;; ----
 

collects/syntax/scribblings/parse/litconv.scrbl

@@ -15,9 +15,14 @@ As a remedy, @schememodname[syntax/parse] offers @deftech{literal
 sets}. A literal set is defined via @scheme[define-literal-set] and
 used via the @scheme[#:literal-set] option of @scheme[syntax-parse].
 
-@defform/subs[(define-literal-set name-id (literal ...))
+@defform/subs[(define-literal-set name-id maybe-phase (literal ...))
               ([literal literal-id
-                        (pattern-id literal-id)])]{
+                        (pattern-id literal-id)]
+               [maybe-phase (code:line)
+                            (code:line #:for-template)
+                            (code:line #:for-syntax)
+                            (code:line #:for-label)
+                            (code:line #:phase phase-level)])]{
 
 Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal]
 can have a separate @scheme[pattern-id] and @scheme[literal-id]. The
@@ -34,8 +39,14 @@ identifiers the literal matches.
   [(define-syntaxes (x:id ...) e:expr) 's])
 ]
 
-The literals in a literal set always refer to the phase-0 bindings of
+The literals in a literal set always refer to the bindings at phase
-the enclosing module. For example:
+@scheme[phase-level] @emph{relative to the enclosing module}. If the
+@scheme[#:for-template] option is given, @scheme[phase-level] is
+@scheme[-1]; @scheme[#:for-syntax] means @racket[1], and
+@racket[#:for-label] means @racket[#f]. If no phase keyword option is
+given, then @racket[phase-level] is @racket[0].
+
+For example:
 
 @myexamples[
 (module common racket/base
@@ -52,7 +63,17 @@ In the literal set @scheme[common-lits], the literal @scheme[x] always
 recognizes identifiers bound to the variable @scheme[x] defined in
 module @schememodname['common].
 
-When a literal set is used with the @scheme[#:phase phase-expr]
+The following module defines an equivalent literal set, but imports
+the @racket['common] module for-template instead:
+
+@myexamples[
+(module lits racket/base
+  (require syntax/parse (for-template 'common))
+  (define-literal-set common-lits #:for-template (x))
+  (provide common-lits))
+]
+
+When a literal set is @emph{used} with the @scheme[#:phase phase-expr]
 option, the literals' fixed bindings are compared against the binding of
 the input literal at the specified phase. Continuing the example:
 

collects/tests/stxparse/litset-phases.rkt

@@ -1,10 +1,15 @@
-#lang racket/load
+#lang scheme
+(require syntax/parse
+         syntax/parse/debug
+         rackunit
+         "setup.rkt")
+(require (for-syntax syntax/parse))
 
+#|
 (module a racket
   (require syntax/parse)
   (define-literal-set lits (begin))
   (provide lits))
-
 (module b racket
   (require (for-syntax 'a syntax/parse))
   (require (for-syntax syntax/parse/private/runtime))
@@ -14,8 +19,54 @@
       #:literal-sets (lits)
       [(snarf (begin e)) #'e]))
   (provide snarf))
-
 (module c racket
   (require (for-syntax 'b racket/base))
   (begin-for-syntax
     (displayln (snarf (begin 5)))))
+|#
+
+(define-literal-set lits0 #:phase 0
+  (define lambda))
+
+(tcerr "litset unbound"
+       (let ()
+         (define-literal-set lits #:phase 0
+           (none-such))
+         (void)))
+
+(tcerr "litset unbound, phase"
+       (let ()
+         (define-literal-set lits #:for-template
+           (lambda))
+         (void)))
+
+(tcerr "litset ok, use fails"
+       (let ()
+         (define-literal-set lits #:phase 0
+           (define lambda))
+         (syntax-parse #'foo #:literal-sets (lits)
+           [lambda (void)])))
+
+(define-literal-set lits #:phase 0
+  (define lambda))
+(require (prefix-in mz: racket/base))
+
+(test-case "litset ok, use ok"
+  (syntax-parse #'lambda #:literal-sets (lits)
+    [lambda (void)]))
+
+(test-case "litset ok, use ok prefix"
+  (syntax-parse #'mz:lambda #:literal-sets (lits)
+    [lambda (void)]))
+
+(require (for-meta 2 (only-in '#%kernel #%app)))
+(define-literal-set litsk #:phase 2
+  (#%app))
+
+(test-case "litset, phase"
+  (syntax-parse #'#%plain-app #:literal-sets (litsk)
+    [#%app (void)]))
+
+(tcerr "litset, phase fail"
+  (syntax-parse #'#%app #:literal-sets (litsk)
+    [#%app (void)]))