syntax/parse: added litset extension

collects/syntax/parse/private/litconv.rkt

@@ -64,13 +64,50 @@
     (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
   stx)
 
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals stx imports lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) stx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (check+enter! (car entry) litset-id))))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
 (define-syntax (define-literal-set stx)
   (syntax-case stx ()
     [(define-literal-set name . rest)
      (let-values ([(chunks rest)
                    (parse-keyword-options
                     #'rest
-                    `((#:phase ,check-phase-level)
+                    `((#:literal-sets ,check-litset-list)
+                      (#:phase ,check-phase-level)
                       (#:for-template)
                       (#:for-syntax)
                       (#:for-label))
@@ -86,9 +123,13 @@
                     [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)])])
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits)
          (with-syntax ([((internal external) ...) lits]
+                       [(litset-id ...) (map car imports)]
                        [relphase relphase])
            #`(begin
                (define phase-of-literals
@@ -97,13 +138,23 @@
                      'relphase))
                (define-syntax name
                  (make-literalset
-                  (list (list 'internal (quote-syntax external)) ...)
-                  (quote-syntax phase-of-literals)))
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (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 'relphase)
                     (raise-syntax-error #f
-                                        (format "literal is unbound in phase ~a" 'relphase)
+                                        (format "literal is unbound in phase ~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else "")))
                                         (quote-syntax #,stx) x))))))))]))
 
 (define-syntax (phase-of-enclosing-module stx)

collects/syntax/parse/private/rep-data.rkt

@@ -81,9 +81,9 @@ A ConventionRule is (list regexp DeclEntry)
 
 #|
 A LiteralSet is
-  (make-literalset (listof (list symbol id)) stx)
+  (make-literalset (listof (list symbol id phase-var-id)))
 |#
-(define-struct literalset (literals phase) #:transparent)
+(define-struct literalset (literals) #:transparent)
 
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.

collects/syntax/parse/private/rep.rkt

@@ -57,9 +57,6 @@
  [check-stxclass-application
   (-> syntax? syntax?
       (cons/c identifier? arguments?))]
- [check-literals-list/litset
-  (-> syntax? syntax?
-      (listof (list/c identifier? identifier?)))]
  [check-conventions-rules
   (-> syntax? syntax?
       (listof (list/c regexp? any/c)))]
@@ -1320,29 +1317,6 @@ A syntax class is integrable if
      (raise-syntax-error #f "expected literal entry"
                          ctx stx)]))
 
-;; Literal sets - Definition
-
-;; check-literals-list/litset : stx stx -> (listof (list id id))
-(define (check-literals-list/litset stx ctx)
-  (let ([lits (for/list ([x (in-list (stx->list stx))])
-                (check-literal-entry/litset x ctx))])
-    (let ([dup (check-duplicate-identifier (map car lits))])
-      (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
-    lits))
-
-;; check-literal-entry/litset : stx stx -> (list id id)
-(define (check-literal-entry/litset stx ctx)
-  (syntax-case stx ()
-    [(internal external)
-     (and (identifier? #'internal) (identifier? #'external))
-     (list #'internal #'external)]
-    [id
-     (identifier? #'id)
-     (list #'id #'id)]
-    [_
-     (raise-syntax-error #f "expected literal entry"
-                         ctx stx)]))
-
 ;; Literal sets - Import
 
 ;; check-literal-sets-list : stx stx -> (listof (listof (list id id ct-phase^2)))
@@ -1365,7 +1339,7 @@ A syntax class is integrable if
       (list (datum->syntax lctx (car entry) stx)
             (cadr entry)
             phase
-            (literalset-phase litset))))
+            (caddr entry))))
   (syntax-case stx ()
     [(litset . more)
      (and (identifier? #'litset))

collects/syntax/scribblings/parse/litconv.scrbl

@@ -15,20 +15,24 @@ 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 maybe-phase (literal ...))
+@defform/subs[(define-literal-set id maybe-phase maybe-imports (literal ...))
               ([literal 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)])]{
+                            (code:line #:phase phase-level)]
+               [maybe-imports (code:line)
+                              (code:line #:literal-sets (imported-litset-id ...))])]{
 
-Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal]
-can have a separate @scheme[pattern-id] and @scheme[literal-id]. The
+Defines @scheme[id] as a @tech{literal set}. Each @scheme[literal] can
+have a separate @scheme[pattern-id] and @scheme[literal-id]. The
 @scheme[pattern-id] determines what identifiers in the pattern are
 treated as literals. The @scheme[literal-id] determines what
-identifiers the literal matches.
+identifiers the literal matches. If the @racket[#:literal-sets] option
+is present, the contents of the given @racket[imported-litset-id]s are
+included.
 
 @myexamples[
 (define-literal-set def-litset

collects/tests/stxparse/test-litset.rkt

@@ -1,30 +1,10 @@
-#lang scheme
+#lang racket/base
 (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))
-  (define-syntax (snarf stx)
-    ;;(printf "slpl of snarf: ~s\n" (syntax-local-phase-level))
-    (syntax-parse stx
-      #: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))
 
@@ -87,3 +67,33 @@
                        '(b))
          ;; check that passed lambda is not a literal, but a pattern variable:
          (check-equal? (syntax->datum (getvar lambda #'(lambda b c))))))
+
+;; Litset extension
+
+(tcerr "litset ext, dup 1"
+       (let ()
+         (define-literal-set lits1 (define))
+         (define-literal-set lits2 #:literal-sets (lits1) (define))
+         (void)))
+
+(tcerr "litset ext, dup 2"
+       (let ()
+         (define-literal-set lits1 (define))
+         (define-literal-set lits2 (define))
+         (define-literal-set lits3 #:literal-sets (lits1 lits2) ())
+         (void)))
+
+(test-case "litset ext, works"
+  (let ()
+    (define-literal-set lits1 (define))
+    (define-literal-set lits2 #:literal-sets (lits1) (lambda))
+    (define (go x exp)
+      (check-equal? (syntax-parse x #:literal-sets (lits2)
+                      [lambda 'lambda]
+                      [define 'define]
+                      [_ #f])
+                    exp))
+    (go #'lambda 'lambda)
+    (go #'define 'define)
+    (go #'begin #f)
+    (void)))