syntax/parse: allow phase spec for literals

collects/syntax/private/stxparse/parse.rkt

@@ -8,6 +8,7 @@
                      "rep-data.ss"
                      "rep.ss"
                      "codegen-data.ss"
+                     "../util/txlift.ss"
                      "../util.ss")
          scheme/stxparam
          scheme/list
@@ -158,7 +159,8 @@
   (syntax-case stx ()
     [(parse:clauses x clauses ctx)
      (with-disappeared-uses
-      (let ()
+      (with-txlifts
+       (lambda ()
         (define-values (chunks clauses-stx)
           (parse-keyword-options #'clauses parse-directive-table
                                  #:context #'ctx
@@ -191,19 +193,13 @@
                                              (clause-success () (let () . rest)))))))]))
         (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx))
           (raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx))
-        (with-syntax ([(def ...) defs]
+        (with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
                       [(alternative ...)
                        (map for-clause (stx->list clauses-stx))])
           #`(let ([fail (syntax-patterns-fail #,context)])
               def ...
               (with-enclosing-fail* fail
-                (try alternative ...))))))]))
+                (try alternative ...)))))))]))
-
-(define-for-syntax (wash-literal stx)
-  (syntax-case stx ()
-    [(a b) (list #'a #'b)]))
-(define-for-syntax (wash-literals stx)
-  (wash-list wash-literal stx))
 
 ;; (clause-success (IAttr ...) expr) : expr
 (define-syntax (clause-success stx)
@@ -262,12 +258,20 @@
                 (fail x
                       #:expect (expectation pattern0)
                       #:fce fc)))]
-       [#s(pat:literal attrs literal)
+       [#s(pat:literal attrs literal #f)
         #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal)))
               k
               (fail x
                     #:expect (expectation pattern0)
                     #:fce fc))]
+       [#s(pat:literal attrs literal phase)
+        #`(if (and (identifier? x)
+                   (free-identifier=? x (quote-syntax literal)
+                                      (phase+ (syntax-local-phase-level) phase)))
+              k
+              (fail x
+                    #:expect (expectation pattern0)
+                    #:fce fc))]
        [#s(pat:ghost attrs ghost subpattern)
         #'(parse:G x fc ghost (parse:S x fc subpattern k))]
        [#s(pat:head attrs head tail)
@@ -625,7 +629,7 @@
     [(_ #s(pat:datum attrs d))
      #'(begin (collect-error '(datum d))
               (make-expect:atom 'd))]
-    [(_ #s(pat:literal attrs lit))
+    [(_ #s(pat:literal attrs lit phase))
      #'(begin (collect-error '(literal lit))
               (make-expect:literal (quote-syntax lit)))]
     ;; 2 pat:compound patterns

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

@@ -92,7 +92,7 @@ A ConventionRule is (list regexp DeclEntry)
 
 #|
 A LiteralSet is
-  (make-literalset (listof (list symbol id)))
+  (make-literalset (listof (list symbol id ct-phase)))
 |#
 (define-struct literalset (literals) #:transparent)
 
@@ -110,14 +110,14 @@ DeclEnv =
                 (listof ConventionRule))
 
 DeclEntry =
-  (make-den:lit id id)
+  (make-den:lit id id ct-phase)
   (make-den:class id id (listof syntax) bool)
   (make-den:parser id id (listof SAttr) bool bool)
   (make-den:delayed id id id)
 |#
 (define-struct declenv (table conventions))
 
-(define-struct den:lit (internal external))
+(define-struct den:lit (internal external phase))
 (define-struct den:class (name class args))
 (define-struct den:parser (parser description attrs splicing? commit?))
 (define-struct den:delayed (parser description class))
@@ -127,7 +127,7 @@ DeclEntry =
    (for/fold ([table (make-immutable-bound-id-table)])
        ([literal literals])
      (bound-id-table-set table (car literal)
-                         (make den:lit (car literal) (cadr literal))))
+                         (make den:lit (car literal) (cadr literal) (caddr literal))))
    conventions))
 
 (define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
@@ -141,7 +141,7 @@ DeclEntry =
   ;; So blame-declare? only applies to stxclass declares
   (let ([val (declenv-lookup env id #:use-conventions? #f)])
     (match val
-      [(struct den:lit (_i _e))
+      [(struct den:lit (_i _e _p))
        (wrong-syntax id "identifier previously declared as literal")]
       [(struct den:class (name _c _a))
        (if (and blame-declare? stxclass-name)
@@ -205,6 +205,11 @@ DeclEntry =
 (define SideClause/c
   (or/c clause:fail? clause:with? clause:attr?))
 
+;; ct-phase
+;;   #f means not specified, ie default, ie 0
+;;   syntax means computed by given expr
+(define ct-phase/c (or/c syntax? #f))
+
 (provide (struct-out den:lit)
          (struct-out den:class)
          (struct-out den:parser)
@@ -214,12 +219,13 @@ DeclEntry =
  [DeclEnv/c contract?]
  [DeclEntry/c contract?]
  [SideClause/c contract?]
+ [ct-phase/c contract?]
 
  [make-dummy-stxclass (-> identifier? stxclass?)]
  [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
 
  [new-declenv
-  (->* [(listof (list/c identifier? identifier?))]
+  (->* [(listof (list/c identifier? identifier? ct-phase/c))]
        [#:conventions list?]
        DeclEnv/c)]
  [declenv-lookup

collects/syntax/private/stxparse/rep-patterns.rkt

@@ -17,7 +17,7 @@ A Base is (listof IAttr)
 A SinglePattern is one of
   (make-pat:any Base)
   (make-pat:var Base id id (listof stx) (listof IAttr) bool)
-  (make-pat:literal Base identifier)
+  (make-pat:literal Base identifier ct-phase)
   (make-pat:datum Base datum)
   (make-pat:ghost Base GhostPattern SinglePattern)
   (make-pat:head Base HeadPattern SinglePattern)
@@ -38,7 +38,7 @@ A ListPattern is a subtype of SinglePattern; one of
 
 (define-struct pat:any (attrs) #:prefab)
 (define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
-(define-struct pat:literal (attrs id) #:prefab)
+(define-struct pat:literal (attrs id phase) #:prefab)
 (define-struct pat:datum (attrs datum) #:prefab)
 (define-struct pat:ghost (attrs ghost inner) #:prefab)
 (define-struct pat:head (attrs head tail) #:prefab)
@@ -186,8 +186,8 @@ A Kind is one of
 (define (create-pat:datum datum)
   (make pat:datum null datum))
 
-(define (create-pat:literal literal)
+(define (create-pat:literal literal phase)
-  (make pat:literal null literal))
+  (make pat:literal null literal phase))
 
 (define (create-pat:ghost g sp)
   (cond [(ghost:and? g)

collects/syntax/private/stxparse/rep.rkt

@@ -9,6 +9,7 @@
          syntax/keyword
          unstable/syntax
          unstable/struct
+         "../util/txlift.ss"
          "rep-data.ss"
          "codegen-data.ss")
 
@@ -42,12 +43,14 @@
   (-> DeclEntry/c
       (values DeclEntry/c (listof syntax?)))]
  [check-literals-list
+  ;; NEEDS txlift context
   (-> syntax? syntax?
-      (listof (list/c identifier? identifier?)))]
+      (listof (list/c identifier? identifier? ct-phase/c)))]
  #|
  [check-literal-sets-list
+  ;; NEEDS txlift context
   (-> syntax? syntax?
-      (listof (listof (list/c identifier? identifier?))))]
+      (listof (listof (list/c identifier? identifier? ct-phase/c))))]
  |#
  [check-conventions-rules
   (-> syntax? syntax?
@@ -124,6 +127,8 @@
 ;; literals must be bound. Set to #f for pass1 (attr collection);
 ;; parser requires stxclasses to be bound.
 (define (parse-rhs stx expected-attrs splicing? #:context ctx)
+  (call/txlifts
+   (lambda ()
      (parameterize ((current-syntax-context ctx))
        (define-values (rest description transp? attributes auto-nested?
                             decls defs commit?)
@@ -139,7 +144,9 @@
        (let ([sattrs
               (or attributes
                   (intersect-sattrss (map variant-attrs patterns)))])
-      (make rhs stx sattrs transp? description patterns defs commit?))))
+         (make rhs stx sattrs transp? description patterns 
+               (append (get-txlifts-as-definitions) defs)
+               commit?))))))
 
 (define (parse-rhs/part1 stx splicing? strict?)
   (define-values (chunks rest)
@@ -232,7 +239,7 @@
 ;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
 (define (create-aux-def entry)
   (match entry
-    [(struct den:lit (_i _e))
+    [(struct den:lit (_i _e _p))
      (values entry null)]
     [(struct den:class (name class args))
      (cond [(identifier? name)
@@ -476,8 +483,8 @@
 (define (parse-pat:id id decls allow-head?)
   (define entry (declenv-lookup decls id))
   (match entry
-    [(struct den:lit (internal literal))
+    [(struct den:lit (internal literal phase))
-     (create-pat:literal literal)]
+     (create-pat:literal literal phase)]
     [(struct den:class (_n _c _a))
      (error 'parse-pat:id
             "(internal error) decls had leftover stxclass entry: ~s"
@@ -604,9 +611,10 @@
 (define (parse-pat:literal stx decls)
   (syntax-case stx (~literal)
     [(~literal lit)
+     ;; FIXME: support #:phase option here
      (unless (identifier? #'lit)
        (wrong-syntax #'lit "expected identifier"))
-     (create-pat:literal #'lit)]
+     (create-pat:literal #'lit #f)]
     [_
      (wrong-syntax stx "bad ~~literal pattern")]))
 
@@ -969,7 +977,7 @@
     [_
      (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
 
-;; check-literals-list : stx stx -> (listof (list id id))
+;; check-literals-list : stx stx -> (listof (list id id ct-phase))
 (define (check-literals-list stx ctx)
   (unless (stx-list? stx)
     (raise-syntax-error #f "expected literals list" ctx stx))
@@ -978,15 +986,18 @@
       (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
     lits))
 
-;; check-literal-entry : stx stx -> (list id id)
+;; check-literal-entry : stx stx -> (list id id ct-phase)
 (define (check-literal-entry stx ctx)
   (syntax-case stx ()
+    [(internal external #:phase phase)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external (txlift #'phase))]
     [(internal external)
      (and (identifier? #'internal) (identifier? #'external))
-     (list #'internal #'external)]
+     (list #'internal #'external #f)]
     [id
      (identifier? #'id)
-     (list #'id #'id)]
+     (list #'id #'id #f)]
     [_
      (raise-syntax-error #f "expected literal (identifier or pair of identifiers)"
                          ctx stx)]))
@@ -997,27 +1008,38 @@
   (for/list ([x (stx->list stx)])
     (check-literal-set-entry x ctx)))
 
+;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase))
 (define (check-literal-set-entry stx ctx)
-  (define (elaborate litset-id lctx)
+  (define (elaborate litset-id lctx phase)
+    ;; phase is #f (not specified, means 0) or syntax (expr)
     (let ([litset (syntax-local-value/catch litset-id literalset?)])
       (unless litset
         (raise-syntax-error #f "expected identifier defined as a literal-set"
                             ctx litset-id))
-      (elaborate-litset litset lctx stx)))
+      (elaborate-litset litset lctx phase stx)))
   (syntax-case stx ()
-    [(litset #:at lctx)
+    [(litset . more)
-     (and (identifier? #'litset) (identifier? #'lctx))
+     (and (identifier? #'litset))
-     (elaborate #'litset #'lctx)]
+     (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table
+                                               #:no-duplicates? #t
+                                               #:context ctx)]
+            [lctx (options-select-value chunks '#:at #:default #'litset)]
+            [phase (options-select-value chunks '#:phase #:default #f)])
+       (elaborate #'litset lctx (and phase (txlift phase))))]
     [litset
      (identifier? #'litset)
-     (elaborate #'litset #'litset)]
+     (elaborate #'litset #'litset #f)]
     [_
      (raise-syntax-error #f "expected literal-set entry" ctx stx)]))
 
-(define (elaborate-litset litset lctx srcctx)
+(define (elaborate-litset litset lctx phase srcctx)
+  ;; phase is #f (not specified, means 0) or syntax (expr)
   (for/list ([entry (literalset-literals litset)])
     (list (datum->syntax lctx (car entry) srcctx)
-          (cadr entry))))
+          (cadr entry)
+          (cond [(not (caddr entry)) phase]
+                [(not phase) (caddr entry)]
+                [else #`(phase+ #,(caddr entry) #,phase)]))))
 
 ;; returns (listof (cons Conventions (listof syntax)))
 (define (check-conventions-list stx ctx)
@@ -1140,3 +1162,12 @@
 ;; h-optional-directive-table
 (define h-optional-directive-table
   (list (list '#:defaults check-bind-clause-list)))
+
+;; phase-directive-table
+(define phase-directive-table
+  (list (list '#:phase check-expression)))
+
+;; litset-directive-table
+(define litset-directive-table
+  (cons (list '#:at check-identifier)
+        phase-directive-table))

collects/syntax/private/stxparse/runtime.rkt

@@ -356,6 +356,8 @@ A Dynamic Frontier Context (DFC) is one of
 
 ;; == Expectations
 
+;; FIXME: add phase to expect:literal
+
 #|
 An Expectation is one of
   'ineffable
@@ -599,3 +601,10 @@ An Expectation is one of
                           #'(k))])
          #'(values (lambda (x extra ...) (parser x extra ... arg ...))
                    (lambda () (get-description arg ...)))))]))
+
+;; 
+
+(provide phase+)
+
+(define (phase+ a b)
+  (and (number? a) (number? b) (+ a b)))

collects/syntax/private/stxparse/sc.rkt

@@ -4,6 +4,7 @@
                      unstable/syntax
                      unstable/struct
                      "minimatch.ss"
+                     "../util/txlift.ss"
                      "rep-data.ss"
                      "rep.ss")
          racket/list
@@ -146,11 +147,18 @@
      (begin
        (unless (identifier? #'name)
          (raise-syntax-error #f "expected identifier" stx #'name))
+       (with-txlifts/defs
+        (lambda ()
           (let ([lits (check-literals-list #'(lit ...) stx)])
-         (with-syntax ([((internal external) ...) lits])
+            (with-syntax ([((internal external _) ...) lits]
+                          [(phase ...)
+                           (for/list ([lit lits])
+                             (if (caddr lit)
+                                 #`(quote-syntax #,(caddr lit))
+                                 #'(quote #f)))])
               #'(define-syntax name
                   (make-literalset
-                (list (list 'internal (quote-syntax external)) ...))))))]))
+                   (list (list 'internal (quote-syntax external) phase) ...))))))))]))
 
 ;; ----
 

collects/syntax/private/util/txlift.ss

@@ -0,0 +1,53 @@
+#lang scheme/base
+(require (for-template scheme/base))
+(provide txlift
+         get-txlifts
+         get-txlifts-as-definitions
+         call/txlifts
+         with-txlifts
+         with-txlifts/defs)
+
+;; Like lifting definitions, but within a single transformer.
+
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))
+
+(define (with-txlifts/defs proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([(def ...) (get-txlifts-as-definitions)])
+         #`(begin def ... #,v))))))