syntax/parse

added #:opaque syntax class option
  changed expectation handling

svn: r15831

collects/syntax/private/stxparse/parse.ss

@@ -235,13 +235,13 @@
             (if (equal? d (quote datum))
                 k
                 (fail x
-                      #:expect (expectation-of-constant datum)
+                      #:expect (expectation pattern0)
                       #:fce fc)))]
        [#s(pat:literal attrs literal)
         #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal)))
               k
               (fail x
-                    #:expect (expectation-of-literal literal)
+                    #:expect (expectation pattern0)
                     #:fce fc))]
        [#s(pat:head attrs head tail)
         #`(parse:H x fc head rest index
@@ -276,17 +276,17 @@
                       (let ([part part-expr] ...)
                         (parse:S* (part ...) (part-fc ...) (part-pattern ...) k))
                       (fail x
-                            #:expect (expectation-of-compound kind0 (part-pattern ...))
+                            #:expect (expectation pattern0)
                             #:fce fc))))))]
        [#s(pat:cut attrs pattern)
         #`(with-enclosing-fail enclosing-cut-fail
             (parse:S x fc pattern k))]
-       [#s(pat:describe attrs description pattern)
+       [#s(pat:describe attrs description transparent? pattern)
         #`(let ([previous-fail enclosing-fail]
                 [previous-cut-fail enclosing-cut-fail])
             (define (new-fail failure)
               (fail x
-                    #:expect (expectation-of-thing description #f failure)
+                    #:expect (expectation-of-thing description transparent? failure)
                     #:fce fc))
             (with-enclosing-fail* new-fail
               (parse:S x #,(empty-frontier #'x) pattern
@@ -298,7 +298,7 @@
        [#s(pat:fail _ condition message)
         #`(if condition
               (fail x
-                    #:expect (expectation-of-message message)
+                    #:expect (expectation pattern0)
                     #:fce fc)
               k)])]))
 
@@ -347,12 +347,12 @@
   (syntax-case stx ()
     [(parse:H x fc head rest index k)
      (syntax-case #'head ()
-       [#s(hpat:describe _ description pattern)
+       [#s(hpat:describe _ description transparent? pattern)
         #`(let ([previous-fail enclosing-fail]
                 [previous-cut-fail enclosing-cut-fail])
             (define (new-fail failure)
               (fail x
-                    #:expect (expectation-of-thing description #f failure)
+                    #:expect (expectation-of-thing description transparent? failure)
                     #:fce fc))
             (with-enclosing-fail* new-fail
               (parse:H x #,(empty-frontier #'x) pattern
@@ -522,6 +522,24 @@
 
 ;; ----
 
+;; (expectation Pattern)
+(define-syntax (expectation stx)
+  (syntax-case stx ()
+    [(_ #s(pat:datum attrs datum))
+     #'(make-expect:atom 'datum)]
+    [(_ #s(pat:literal attrs literal))
+     #'(make-expect:literal (quote-syntax literal))]
+    ;; 2 pat:compound patterns
+    ;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern)))
+    ;; #'(make-expect:pair)]
+    [(_ #s(pat:compound attrs kind0 (part-pattern ...)))
+     #''ineffable]
+    [(_ #s(pat:fail _ condition message))
+     #'(expectation-of-message message)]
+    ))
+
+;; ----
+
 (define-syntax-rule (expectation-of-thing description transparent? chained)
   (make-expect:thing description transparent? chained))
 
@@ -529,18 +547,6 @@
   (let ([msg message])
     (if msg (make-expect:message msg) 'ineffable)))
 
-(define-syntax-rule (expectation-of-constant constant)
-  (make-expect:atom 'constant))
-
-(define-syntax-rule (expectation-of-literal literal)
-  (make-expect:literal (quote-syntax literal)))
-
-(define-syntax expectation-of-compound
-  (syntax-rules ()
-    [(_ #:pair (head-pattern tail-pattern))
-     (make-expect:pair)]
-    [(_ _ _) 'ineffable]))
-
 (define-syntax expectation-of-reps/too-few
   (syntax-rules ()
     [(_ rep #s(rep:once name too-few-msg too-many-msg))

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

@@ -29,7 +29,7 @@ A SinglePattern is one of
   (make-pat:or SPBase (listof SinglePattern))
   (make-pat:compound SPBase Kind (listof SinglePattern))
   (make-pat:cut SPBase SinglePattern)
-  (make-pat:describe SPBase stx SinglePattern)
+  (make-pat:describe SPBase stx boolean SinglePattern)
   (make-pat:bind SPBase (listof clause:attr))
   (make-pat:fail SPBase stx stx)
 
@@ -52,7 +52,7 @@ A ListPattern is a subtype of SinglePattern; one of
 (define-struct pat:or (attrs patterns) #:prefab)
 (define-struct pat:compound (attrs kind patterns) #:prefab)
 (define-struct pat:cut (attrs pattern) #:prefab)
-(define-struct pat:describe (attrs description pattern) #:prefab)
+(define-struct pat:describe (attrs description transparent? pattern) #:prefab)
 (define-struct pat:bind (attrs clauses) #:prefab)
 (define-struct pat:fail (attrs when message) #:prefab)
 
@@ -62,13 +62,13 @@ A HeadPattern is one of
   (make-hpat:ssc HPBase id id boolean boolean)
   (make-hpat:seq HPBase ListPattern)
   (make-hpat:or HPBase (listof HeadPattern))
-  (make-hpat:describe HPBase stx/#f HeadPattern)
+  (make-hpat:describe HPBase stx/#f boolean HeadPattern)
 |#
 
 (define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab)
 (define-struct hpat:seq (attrs inner) #:prefab)
 (define-struct hpat:or (attrs patterns) #:prefab)
-(define-struct hpat:describe (attrs description pattern) #:prefab)
+(define-struct hpat:describe (attrs description transparent? pattern) #:prefab)
 
 #|
 An EllipsisHeadPattern is
@@ -76,13 +76,13 @@ An EllipsisHeadPattern is
 
 A RepConstraint is one of
   (make-rep:once stx stx stx)
-  (make-rep:optional stx stx)
+  (make-rep:optional stx stx (listof clause:attr))
   (make-rep:bounds nat/#f nat/#f stx stx stx)
   #f
 |#
 (define-struct ehpat (attrs head repc) #:prefab)
 (define-struct rep:once (name under-message over-message) #:prefab)
-(define-struct rep:optional (name over-message) #:prefab)
+(define-struct rep:optional (name over-message #| defaults |#) #:prefab)
 (define-struct rep:bounds (min max name under-message over-message) #:prefab)
 
 

collects/syntax/private/stxparse/rep.ss

@@ -70,6 +70,7 @@
         (quote-syntax ~rep)
         (quote-syntax ~once)
         (quote-syntax ~optional)
+        (quote-syntax ~bounds)
         (quote-syntax ~rest)
         (quote-syntax ~struct)
         (quote-syntax ~!)
@@ -109,11 +110,14 @@
                            #:context ctx
                            #:no-duplicates? #t))
   (define desc0 (assq '#:description chunks))
-  (define trans0 (assq '#:transparent chunks))
+  ;; (define trans0 (assq '#:transparent chunks))
+  (define opaque0 (assq '#:opaque chunks))
   (define attrs0 (assq '#:attributes chunks))
   (define auto-nested0 (assq '#:auto-nested-attributes chunks))
   (define description (and desc0 (caddr desc0)))
-  (define transparent? (and trans0 #t))
+  (define opaque? (and opaque0 #t))
+  (define transparent? (not opaque?))
+  ;;(define transparent? (and trans0 #t))
   (define attributes
     (cond [(and attrs0 auto-nested0)
            (raise-syntax-error #f "cannot use both #:attributes and #:auto-nested-attributes"
@@ -406,11 +410,21 @@
 
 (define (parse-pat:describe stx decls allow-head?)
   (syntax-case stx ()
-    [(_ description pattern)
-     (let ([p (parse-some-pattern #'pattern decls allow-head?)])
-       (if (head-pattern? p)
-           (make hpat:describe (pattern-attrs p) #'description p)
-           (make pat:describe (pattern-attrs p) #'description p)))]))
+    [(_ . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options #'rest describe-option-table
+                                          #:no-duplicates? #t
+                                          #:context stx)])
+       (define trans0 (assq '#:transparent chunks))
+       (define transparent? (and trans0 #t))
+       (syntax-case rest ()
+         [(description pattern)
+          (let ([p (parse-some-pattern #'pattern decls allow-head?)])
+            (if (head-pattern? p)
+                (make hpat:describe (pattern-attrs p)
+                      #'description transparent? p)
+                (make pat:describe (pattern-attrs p)
+                      #'description transparent? p)))]))]))
 
 (define (parse-pat:or stx decls allow-head?)
   (define patterns (parse-cdr-patterns stx decls allow-head? #f))
@@ -500,17 +514,10 @@
 (define (parse-pat:bind stx decls)
   (syntax-case stx ()
     [(_ clause ...)
-     (parameterize ((current-syntax-context stx))
-       (let ([clauses (map parse-bind-clause (syntax->list #'(clause ...)))])
-         (make pat:bind
-           (append-iattrs (side-clauses-attrss clauses))
-           clauses)))]))
-
-(define (parse-bind-clause clause)
-  (syntax-case clause ()
-    [(attr-decl expr)
-     (make clause:attr (check-attr-arity #'attr-decl #f) #'expr)]
-    [_ (wrong-syntax clause "expected bind clause")]))
+     (let ([clauses (check-bind-clause-list #'(clause ...) stx)])
+       (make pat:bind
+         (append-iattrs (side-clauses-attrss clauses))
+         clauses))]))
 
 (define (parse-pat:fail stx decls)
   (syntax-case stx ()
@@ -576,17 +583,20 @@
     [(~optional p . options)
      (let ([head (parse-head-pattern #'p decls)])
        (define chunks
-         (parse-keyword-options/eol #'options
-                                    (list (list '#:too-many check-expression)
-                                          (list '#:name check-expression))
+         (parse-keyword-options/eol #'options optional-directive-table
+                                    #:no-duplicates? #t
                                     #:context stx))
+       #|
+       (define defaults
+         (car (options-select-one chunks '#:defaults #:default '(()))))
+       |#
        (with-syntax ([(too-many-msg)
                       (options-select-one chunks '#:too-many #:default #'(#f))]
                      [(name)
                       (options-select-one chunks '#:name #:default #'(#f))])
          (make ehpat (map attr-make-uncertain (pattern-attrs head))
                head
-               (make rep:optional #'name #'too-many-msg))))]))
+               (make rep:optional #'name #'too-many-msg #| defaults |#))))]))
 
 (define (parse-ehpat/once stx decls)
   (syntax-case stx (~once)
@@ -817,6 +827,19 @@
      (list (check-conventions-pattern (syntax-e #'rx) #'rx)
            (check-sc-expr #'sc))]))
 
+;; bind clauses
+(define (check-bind-clause-list stx ctx)
+  (unless (stx-list? stx)
+    (raise-syntax-error #f "expected sequence of bind clauses" ctx stx))
+  (for/list ([clause (stx->list stx)])
+    (check-bind-clause clause ctx)))
+
+(define (check-bind-clause clause ctx)
+  (syntax-case clause ()
+    [(attr-decl expr)
+     (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)]
+    [_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
+
 ;; common-parse-directive-table
 (define common-parse-directive-table
   (list (list '#:literals check-literals-list)
@@ -832,6 +855,7 @@
 (define rhs-directive-table
   (list* (list '#:description check-expression)
          (list '#:transparent)
+         (list '#:opaque)
          (list '#:attributes check-attr-arity-list)
          (list '#:auto-nested-attributes)
          common-parse-directive-table))
@@ -848,3 +872,13 @@
 (define fail-directive-table
   (list (list '#:when check-expression)
         (list '#:unless check-expression)))
+
+;; describe-option-table
+(define describe-option-table
+  (list (list '#:transparent)))
+
+;; optional-directive-table
+(define optional-directive-table
+  (list (list '#:too-many check-expression)
+        (list '#:name check-expression)
+        #| (list '#:defaults check-bind-clause-list) |#))

collects/syntax/private/stxparse/runtime-prose.ss

@@ -55,7 +55,7 @@
                 stx0
                 frontier-stx))]
         [else
-         (err #f stx0 stx0)]))
+         (err "bad syntax" stx0 stx0)]))
 
 ;; FIXME: try different selection/simplification algorithms/heuristics
 (define (simplify-failure f)
@@ -115,10 +115,11 @@
 ;; prose-for-expectation : Expectation syntax -> string/#f
 (define (prose-for-expectation e index stx)
   (cond [(expect? e)
-         (let ([parts
-                (for/list ([alt (expect->alternatives e)])
-                  (for-alternative alt index stx))])
-           (join-sep parts ";" "or"))]
+         (let ([alts (expect->alternatives e)])
+           (and alts
+                (join-sep (for/list ([alt alts])
+                            (for-alternative alt index stx))
+                          ";" "or")))]
         [(eq? e 'ineffable)
          #f]))
 

collects/syntax/private/stxparse/runtime.ss

@@ -2,6 +2,7 @@
 (require scheme/contract
          scheme/match
          scheme/stxparam
+         scheme/list
          (for-syntax scheme/base
                      syntax/stx
                      scheme/private/sc
@@ -238,20 +239,16 @@ An Expectation is one of
 ;; expect->alternatives : Expectation -> (listof Expectation)/#f
 ;; #f indicates 'ineffable somewhere in expectation
 (define (expect->alternatives e)
-  (define (loop e)
+  (define (loop-onto e rest)
     (cond [(expect:disj? e)
-           (union (expect->alternatives (expect:disj-a e))
-                  (expect->alternatives (expect:disj-b e)))]
-          [else (list e)]))
-  (let ([alts (loop e)])
+           (loop-onto (expect:disj-a e)
+                      (loop-onto (expect:disj-b e) rest))]
+          [else (cons e rest)]))
+  (let ([alts (remove-duplicates (loop-onto e null))])
     (if (for/or ([alt alts]) (eq? alt 'ineffable))
         #f
         alts)))
 
-;; FIXME: n^2 use of union above
-(define (union a b)
-  (append a (for/list ([x b] #:when (not (member x a))) x)))
-
 (define (expectation-of-null? e)
   (or (equal? e '#s(expect:atom ()))
       (and (expect:disj? e)

collects/syntax/scribblings/parse.scrbl

@@ -578,15 +578,22 @@ pattern that the @scheme[#:declare] directive applies to.
 
 }
 
-@specsubform[(code:line #:with syntax-pattern expr)]{
+@specsubform[(code:line #:with syntax-pattern stx-expr)]{
+
+Evaluates the @scheme[stx-expr] in the context of all previous
+attribute bindings and matches it against the pattern. If the match
+succeeds, the pattern's attributes are added to environment for the
+evaluation of subsequent side conditions. If the @scheme[#:with] match
+fails, the matching process backtracks. Since a syntax object may
+match a pattern in several ways, backtracking may cause the same
+clause to be tried multiple times before the next clause is reached.
+}
+
+@specsubform[(code:line #:attr attr-id expr)]{
 
 Evaluates the @scheme[expr] in the context of all previous attribute
-bindings and matches it against the pattern. If the match succeeds,
-the pattern's attributes are added to environment for the evaluation
-of subsequent side conditions. If the @scheme[#:with] match fails, the
-matching process backtracks. Since a syntax object may match a pattern
-in several ways, backtracking may cause the same clause to be tried
-multiple times before the next clause is reached.
+bindings and binds it to the attribute named by @scheme[attr-id]. The
+value of @scheme[expr] need not be syntax.
 }
 
 @specsubform[(code:line #:fail-when condition-expr message-expr)]
@@ -735,8 +742,8 @@ depth (zero if not explicitly specified).
 If the attributes are not explicitly listed, they are inferred as the
 set of all pattern variables occurring in every variant of the syntax
 class. Pattern variables that occur at different ellipsis depths are
-not included, nor are nested attributes.
-
+not included. Only nested attributes from previously declared syntax
+classes are included.
 }
 
 @specsubform[(code:line #:description description)]{