syntax/parse: literals, literal-sets, and phases (todo: docs)

typed-scheme: added missing import for literal

collects/syntax/private/stxparse/parse.rkt

@@ -258,16 +258,10 @@
                 (fail x
                       #:expect (expectation pattern0)
                       #:fce fc)))]
-       [#s(pat:literal attrs literal #f)
+       [#s(pat:literal attrs literal input-phase lit-phase)
-        #`(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)
+                   (free-identifier=?/phases x input-phase
-                                      (phase+ (syntax-local-phase-level) phase)))
+                                             (quote-syntax literal) lit-phase))
               k
               (fail x
                     #:expect (expectation pattern0)
@@ -629,7 +623,7 @@
     [(_ #s(pat:datum attrs d))
      #'(begin (collect-error '(datum d))
               (make-expect:atom 'd))]
-    [(_ #s(pat:literal attrs lit phase))
+    [(_ #s(pat:literal attrs lit input-phase lit-phase))
      #'(begin (collect-error '(literal lit))
               (make-expect:literal (quote-syntax lit)))]
     ;; 2 pat:compound patterns

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

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/contract/base
          racket/dict
+         racket/list
          syntax/stx
          syntax/id-table
          "../util.ss"
@@ -92,9 +93,9 @@ A ConventionRule is (list regexp DeclEntry)
 
 #|
 A LiteralSet is
-  (make-literalset (listof (list symbol id ct-phase)))
+  (make-literalset (listof (list symbol id)) stx)
 |#
-(define-struct literalset (literals) #:transparent)
+(define-struct literalset (literals phase) #:transparent)
 
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
@@ -110,14 +111,14 @@ DeclEnv =
                 (listof ConventionRule))
 
 DeclEntry =
-  (make-den:lit id id ct-phase)
+  (make-den:lit id id ct-phase 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 phase))
+(define-struct den:lit (internal external input-phase lit-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 +128,8 @@ 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) (caddr literal))))
+                         (make den:lit (first literal) (second literal)
+                               (third literal) (fourth literal))))
    conventions))
 
 (define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
@@ -141,7 +143,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 _p))
+      [(struct den:lit (_i _e _ip _lp))
        (wrong-syntax id "identifier previously declared as literal")]
       [(struct den:class (name _c _a))
        (if (and blame-declare? stxclass-name)
@@ -205,10 +207,9 @@ DeclEntry =
 (define SideClause/c
   (or/c clause:fail? clause:with? clause:attr?))
 
-;; ct-phase
+;; ct-phase = syntax, expr that computes absolute phase
-;;   #f means not specified, ie default, ie 0
+;;   usually = #'(syntax-local-phase-level)
-;;   syntax means computed by given expr
+(define ct-phase/c syntax?)
-(define ct-phase/c (or/c syntax? #f))
 
 (provide (struct-out den:lit)
          (struct-out den:class)
@@ -225,7 +226,7 @@ DeclEntry =
  [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))]
 
  [new-declenv
-  (->* [(listof (list/c identifier? identifier? ct-phase/c))]
+  (->* [(listof (list/c identifier? identifier? ct-phase/c 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 ct-phase)
+  (make-pat:literal Base identifier ct-phase 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 phase) #:prefab)
+(define-struct pat:literal (attrs id input-phase lit-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 phase)
+(define (create-pat:literal literal input-phase lit-phase)
-  (make pat:literal null literal phase))
+  (make pat:literal null literal input-phase lit-phase))
 
 (define (create-pat:ghost g sp)
   (cond [(ghost:and? g)

collects/syntax/private/stxparse/rep.rkt

@@ -42,10 +42,15 @@
  [create-aux-def
   (-> DeclEntry/c
       (values DeclEntry/c (listof syntax?)))]
+ #|
  [check-literals-list
   ;; NEEDS txlift context
   (-> syntax? syntax?
-      (listof (list/c identifier? identifier? ct-phase/c)))]
+      (listof (list/c identifier? identifier? ct-phase/c ct-phase/c)))]
+ |#
+ [check-literals-list/litset
+  (-> syntax? syntax?
+      (listof (list/c identifier? identifier?)))]
  #|
  [check-literal-sets-list
   ;; NEEDS txlift context
@@ -192,8 +197,7 @@
   (define convs (options-select-value chunks '#:conventions #:default null))
   (define localconvs (options-select-value chunks '#:local-conventions #:default null))
   (define literals
-    (append-lits+litsets (check-literals-bound lits strict?)
+    (append-lits+litsets lits litsets))
-                         litsets))
   (define-values (convs-rules convs-defs)
     (for/fold ([convs-rules null] [convs-defs null])
         ([conv-entry convs])
@@ -217,18 +221,6 @@
         (let-values ([(parsers descriptions) (get-procedures arg ...)])
           (apply values parsers)))))
 
-(define (check-literals-bound lits strict?)
-  (define phase (syntax-local-phase-level))
-  (when strict?
-    (for ([p lits])
-      ;; FIXME: hack...
-      (unless (or (identifier-binding (cadr p) phase)
-                  (identifier-binding (cadr p) (add1 phase))
-                  (identifier-binding (cadr p) (sub1 phase))
-                  (identifier-binding (cadr p) #f))
-        (wrong-syntax (cadr p) "unbound identifier not allowed as literal"))))
-  lits)
-
 ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
 (define (decls-create-defs decls0)
   (define (updater key value defs)
@@ -237,9 +229,10 @@
   (declenv-update/fold decls0 updater null))
 
 ;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
+;; FIXME: replace with txlift mechanism
 (define (create-aux-def entry)
   (match entry
-    [(struct den:lit (_i _e _p))
+    [(struct den:lit (_i _e _ip _lp))
      (values entry null)]
     [(struct den:class (name class args))
      (cond [(identifier? name)
@@ -483,8 +476,8 @@
 (define (parse-pat:id id decls allow-head?)
   (define entry (declenv-lookup decls id))
   (match entry
-    [(struct den:lit (internal literal phase))
+    [(struct den:lit (internal literal input-phase lit-phase))
-     (create-pat:literal literal phase)]
+     (create-pat:literal literal input-phase lit-phase)]
     [(struct den:class (_n _c _a))
      (error 'parse-pat:id
             "(internal error) decls had leftover stxclass entry: ~s"
@@ -610,11 +603,15 @@
 
 (define (parse-pat:literal stx decls)
   (syntax-case stx (~literal)
-    [(~literal lit)
+    [(~literal lit . more)
-     ;; FIXME: support #:phase option here
      (unless (identifier? #'lit)
        (wrong-syntax #'lit "expected identifier"))
-     (create-pat:literal #'lit #f)]
+     (let* ([chunks (parse-keyword-options/eol #'more phase-directive-table
+                                               #:no-duplicates? #t
+                                               #:context stx)]
+            [phase (options-select-value chunks '#:phase #:default #f)])
+       ;; FIXME: Duplicates phase expr!
+       (create-pat:literal #'lit phase phase))]
     [_
      (wrong-syntax stx "bad ~~literal pattern")]))
 
@@ -977,7 +974,9 @@
     [_
      (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
 
-;; check-literals-list : stx stx -> (listof (list id id ct-phase))
+;; check-literals-list : stx stx -> (listof (list id id ct-phase ct-phase))
+;;  - txlifts defs of phase expressions
+;;  - txlifts checks that literals are bound
 (define (check-literals-list stx ctx)
   (unless (stx-list? stx)
     (raise-syntax-error #f "expected literals list" ctx stx))
@@ -986,37 +985,72 @@
       (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup)))
     lits))
 
-;; check-literal-entry : stx stx -> (list id id ct-phase)
+;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase)
 (define (check-literal-entry stx ctx)
+  (define (go internal external phase)
+    (txlift #`(check-literal (quote-syntax #,external)
+                             #,phase (quote-syntax #,ctx)))
+    (list internal external phase phase))
   (syntax-case stx ()
     [(internal external #:phase phase)
      (and (identifier? #'internal) (identifier? #'external))
-     (list #'internal #'external (txlift #'phase))]
+     (go #'internal #'external (txlift #'phase))]
     [(internal external)
      (and (identifier? #'internal) (identifier? #'external))
-     (list #'internal #'external #f)]
+     (go #'internal #'external #'(syntax-local-phase-level))]
     [id
      (identifier? #'id)
-     (list #'id #'id #f)]
+     (go #'id #'id #'(syntax-local-phase-level))]
     [_
-     (raise-syntax-error #f "expected literal (identifier or pair of identifiers)"
+     (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 (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)))
 (define (check-literal-sets-list stx ctx)
   (unless (stx-list? stx)
     (raise-syntax-error #f "expected literal-set list" ctx stx))
   (for/list ([x (stx->list stx)])
     (check-literal-set-entry x ctx)))
 
-;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase))
+;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2))
 (define (check-literal-set-entry stx ctx)
   (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 phase stx)))
+      (elaborate2 litset lctx phase)))
+  (define (elaborate2 litset lctx phase)
+    (for/list ([entry (literalset-literals litset)])
+      (list (datum->syntax lctx (car entry) stx)
+            (cadr entry)
+            phase
+            (literalset-phase litset))))
   (syntax-case stx ()
     [(litset . more)
      (and (identifier? #'litset))
@@ -1024,22 +1058,16 @@
                                                #:no-duplicates? #t
                                                #:context ctx)]
             [lctx (options-select-value chunks '#:at #:default #'litset)]
-            [phase (options-select-value chunks '#:phase #:default #f)])
+            [phase (options-select-value chunks '#:phase
-       (elaborate #'litset lctx (and phase (txlift phase))))]
+                                         #:default #'(syntax-local-phase-level))])
+       (elaborate #'litset lctx (txlift phase)))]
     [litset
      (identifier? #'litset)
-     (elaborate #'litset #'litset #f)]
+     (elaborate #'litset #'litset #'(syntax-local-phase-level))]
     [_
      (raise-syntax-error #f "expected literal-set entry" ctx stx)]))
 
-(define (elaborate-litset litset lctx phase srcctx)
+;; Conventions
-  ;; 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)
-          (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)

collects/syntax/private/stxparse/runtime.rkt

@@ -604,7 +604,55 @@ An Expectation is one of
 
 ;; 
 
-(provide phase+)
+(provide phase+
+         check-literal
+         free-identifier=?/phases)
 
 (define (phase+ a b)
   (and (number? a) (number? b) (+ a b)))
+
+;; check-literal : id phase-level stx -> void
+;; FIXME: change to normal 'error', if src gets stripped away
+(define (check-literal id phase ctx)
+  (unless (identifier-binding id phase)
+    (raise-syntax-error #f "literal identifier has no binding" ctx id)))
+
+;; free-identifier=?/phases : id phase-level id phase-level -> boolean
+;; Determines whether x has the same binding at phase-level phase-x
+;; that y has at phase-level y.
+;; At least one of the identifiers MUST have a binding (module or lexical)
+(define (free-identifier=?/phases x phase-x y phase-y)
+  (let ([base-phase (syntax-local-phase-level)])
+    (let ([bx (identifier-binding x (phase+ base-phase phase-x))]
+          [by (identifier-binding y (phase+ base-phase phase-y))])
+      (cond [(and (list? bx) (list? by))
+             (let ([modx (module-path-index-resolve (first bx))]
+                   [namex (second bx)]
+                   [phasex (fifth bx)]
+                   [mody (module-path-index-resolve (first by))]
+                   [namey (second by)]
+                   [phasey (fifth by)])
+               (and (eq? modx mody) ;; resolved-module-paths are interned
+                    (eq? namex namey)
+                    (equal? phasex phasey)))]
+            [else
+             ;; 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)]))))
+
+;; ----
+
+(provide begin-for-syntax/once)
+
+;; (begin-for-syntax/once expr/phase1 ...)
+;; evaluates in pass 2 of module/intdefs expansion
+(define-syntax (begin-for-syntax/once stx)
+  (syntax-case stx ()
+    [(bfs/o e ...)
+     (cond [(list? (syntax-local-context))
+            #`(define-values ()
+                (begin (begin-for-syntax/once e ...)
+                       (values)))]
+           [else
+            #'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
+                (m))])]))

collects/syntax/private/stxparse/sc.rkt

@@ -144,21 +144,50 @@
 (define-syntax (define-literal-set stx)
   (syntax-case stx ()
     [(define-literal-set name (lit ...))
-     (begin
+     (let ([phase-of-definition (syntax-local-phase-level)])
        (unless (identifier? #'name)
          (raise-syntax-error #f "expected identifier" stx #'name))
-       (with-txlifts/defs
+       (let ([lits (check-literals-list/litset #'(lit ...) stx)])
-        (lambda ()
+         (with-syntax ([((internal external) ...) lits])
-          (let ([lits (check-literals-list #'(lit ...) stx)])
+           #`(begin
-            (with-syntax ([((internal external _) ...) lits]
+               (define phase-of-literals
-                          [(phase ...)
+                 (let ([phase-of-module-instantiation
-                           (for/list ([lit lits])
+                        ;; Hack to get enclosing module's base phase
-                             (if (caddr lit)
+                        (variable-reference->phase (#%variable-reference))])
-                                 #`(quote-syntax #,(caddr lit))
+                   (- phase-of-module-instantiation
-                                 #'(quote #f)))])
+                      '#,(if (zero? phase-of-definition) 0 1))))
-              #'(define-syntax name
+               (define-syntax name
-                  (make-literalset
+                 (make-literalset
-                   (list (list 'internal (quote-syntax external) phase) ...))))))))]))
+                  (list (list 'internal (quote-syntax external)) ...)
+                  (quote-syntax phase-of-literals)))
+               (begin-for-syntax/once
+                (for ([x (syntax->list #'(external ...))])
+                  (unless (identifier-binding x 0)
+                    (raise-syntax-error #f "literal identifier has no binding"
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+Literal sets: The goal is for literals to refer to their bindings at
+
+  phase 0 relative to the enclosing module
+
+Use cases, explained:
+1) module X with def-lit-set is required-for-syntax
+     phase-of-mod-inst = 1
+     phase-of-def = 0
+     literals looked up at abs phase 1
+       which is phase 0 rel to module X
+2) module X with local def-lit-set within define-syntax
+     phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax)
+     phase-of-def = 1
+     literals looked up at abs phase 0
+       which is phase 0 rel to module X
+3) module X with def-lit-set in phase-2 position (really uncommon case!)
+     phase-of-mod-inst = 1 (not 2, apparently)
+     phase-of-def = 2
+     literals looked up at abs phase 0
+       (that's why the weird (if (z?) 0 1) term)
+|#
 
 ;; ----
 

collects/typed-scheme/private/parse-type.rkt

@@ -10,7 +10,8 @@
          (prefix-in t: (combine-in "base-types-extra.ss" "base-types.ss")) (only-in "colon.ss" :)
          scheme/match 
          (for-template scheme/base "base-types-extra.ss" "colon.ss")
-         (for-template (prefix-in t: "base-types-extra.ss")))
+         (for-template (prefix-in t: "base-types-extra.ss")
+                       (prefix-in t: (only-in "base-types.ss" Vectorof))))
 
 (define-struct poly (name vars) #:prefab)