syntax/parse: added literal-set->predicate

closes PR 11968

collects/syntax/parse/private/litconv.rkt

@@ -10,6 +10,7 @@
          "runtime.rkt")
 (provide define-conventions
          define-literal-set
+         literal-set->predicate
          kernel-literals)
 
 (define-syntax (define-conventions stx)
@@ -181,6 +182,24 @@ Use cases, explained:
        (that's why the weird (if (z?) 0 1) term)
 |#
 
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((_sym lit phase-var) ...) lits])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)))))]))
+
+(define (make-literal-set-predicate lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (for/or ([lit (in-list lits)])
+      (let ([lit-id (car lit)]
+            [lit-phase (cadr lit)])
+        (free-identifier=?/phases x phase lit-id lit-phase)))))
 
 ;; Literal sets
 

collects/syntax/scribblings/parse/litconv.scrbl

@@ -93,6 +93,24 @@ whose binding at phase 1 is the @scheme[x] from module
 @schememodname['common].
 }
 
+@defform[(literal-set->predicate litset-id)]{
+
+Given the name of a literal set, produces a predicate that recognizes
+identifiers in the literal set. The predicate takes one required
+argument, an identifier @racket[_id], and one optional argument, the
+phase @racket[_phase] at which to examine the binding of @racket[_id];
+the @racket[_phase] argument defaults to
+@racket[(syntax-local-phase-level)].
+
+@myexamples[
+(define kernel? (literal-set->predicate kernel-literals))
+(kernel? #'lambda)
+(kernel? #'#%plain-lambda)
+(kernel? #'define-values)
+(kernel? #'define-values 4)
+]
+}
+
 @defform/subs[(define-conventions name-id convention-rule ...)
               ([convention-rule (name-pattern syntax-class)]
                [name-pattern exact-id

collects/tests/stxparse/test-litset.rkt

@@ -3,7 +3,6 @@
          syntax/parse/debug
          rackunit
          "setup.rkt")
-(require (for-syntax syntax/parse))
 
 (define-literal-set lits0 #:phase 0
   (define lambda))
@@ -97,3 +96,14 @@
     (go #'define 'define)
     (go #'begin #f)
     (void)))
+
+(require (for-label '#%kernel))
+
+(test-case "litset->pred"
+  (let ([kernel? (literal-set->predicate kernel-literals)])
+    (check-equal? (kernel? #'#%plain-lambda) #t)
+    (check-equal? (kernel? #'define-values) #t)
+    (check-equal? (kernel? #'define-values #f) #t)
+    (check-equal? (kernel? #'define-values 4) #f)
+    (check-equal? (kernel? #'foo) #f)
+    (void)))