syntax/parse: added head ~optional pattern, improved docs

svn: r15906

collects/syntax/private/stxparse/parse.ss

@@ -308,6 +308,17 @@
                (let ([sub-id alt-sub-id] ...)
                  (success pre ... id ...))))))]))
 
+;; (disjunct (clause:attr ...) id (expr ...) (id ...)) : expr
+(define-syntax (disjunct/sides stx)
+  (syntax-case stx ()
+    [(disjunct/sides clauses success (pre ...) (id ...))
+     (with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses])
+       (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
+         #`(let ([alt-sub-id (attribute sub-id)] ...)
+             (let ([id #f] ...)
+               (let ([sub-id alt-sub-id] ...)
+                 (success pre ... id ...))))))]))
+
 (begin-for-syntax
  ;; convert-list-pattern : ListPattern id -> SinglePattern
  ;; Converts '() datum pattern at end of list to bind (cons stx index)
@@ -382,6 +393,22 @@
                           #'pattern
                           #'#s(internal-rest-pattern rest index index0))])
             #'(parse:S x fc pattern k)))]
+       [#s(hpat:optional (a ...) pattern defaults)
+        (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]
+                      [index0 (frontier->index-expr (wash #'fc))])
+          #`(let ([success
+                   (lambda (rest index fail id ...)
+                     (with-enclosing-fail fail
+                       (let-attributes ([a id] ...) k)))])
+              (try (parse:H x fc pattern rest index
+                            (success rest index enclosing-fail (attribute id) ...))
+                   (let ([rest x]
+                         [index index0])
+                     (convert-sides x defaults
+                       (clause-success ()
+                         (disjunct/sides defaults success
+                                         (rest index enclosing-fail)
+                                         (id ...))))))))]
        [_
         (with-syntax ([attrs (pattern-attrs (wash #'head))]
                       [index0 (frontier->index-expr (wash #'fc))])

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

@@ -30,8 +30,8 @@ A SinglePattern is one of
   (make-pat:compound SPBase Kind (listof SinglePattern))
   (make-pat:cut SPBase SinglePattern)
   (make-pat:describe SPBase stx boolean SinglePattern)
-  (make-pat:bind SPBase (listof clause:attr))
   (make-pat:fail SPBase stx stx)
+  (make-pat:bind SPBase (listof clause:attr))
 
 A ListPattern is a subtype of SinglePattern; one of
   (make-pat:datum SPBase '())
@@ -53,9 +53,8 @@ A ListPattern is a subtype of SinglePattern; one of
 (define-struct pat:compound (attrs kind patterns) #:prefab)
 (define-struct pat:cut (attrs 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)
-
+(define-struct pat:bind (attrs clauses) #:prefab)
 
 #|
 A HeadPattern is one of
@@ -63,12 +62,14 @@ A HeadPattern is one of
   (make-hpat:seq HPBase ListPattern)
   (make-hpat:or HPBase (listof HeadPattern))
   (make-hpat:describe HPBase stx/#f boolean HeadPattern)
+  (make-hpat:optional HPBase HeadPattern (listof clause:attr))
 |#
 
 (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 transparent? pattern) #:prefab)
+(define-struct hpat:optional (attrs inner defaults) #:prefab)
 
 #|
 An EllipsisHeadPattern is
@@ -114,7 +115,8 @@ A Kind is one of
   (or (hpat:ssc? x)
       (hpat:seq? x)
       (hpat:or? x)
-      (hpat:describe? x)))
+      (hpat:describe? x)
+      (hpat:optional? x)))
 
 (define (ellipsis-head-pattern? x)
   (ehpat? x))
@@ -143,5 +145,5 @@ A Kind is one of
     (mk-get-attrs pat:name pat:any pat:sc pat:datum pat:literal pat:head
                   pat:dots pat:and pat:or pat:compound pat:cut pat:describe
                   pat:bind pat:fail
-                  hpat:ssc hpat:seq hpat:or hpat:describe
+                  hpat:ssc hpat:seq hpat:or hpat:describe hpat:optional
                   ehpat)))

collects/syntax/private/stxparse/rep.ss

@@ -306,7 +306,7 @@
 
 ;; parse-head-pattern : stx DeclEnv -> HeadPattern
 (define (parse-head-pattern stx decls)
-  (syntax-case stx (~or ~seq ~describe)
+  (syntax-case stx (~or ~seq ~describe ~optional)
     [id
      (and (identifier? #'id) (not (reserved? #'id)))
      (parse-pat:id stx decls #t)]
@@ -316,6 +316,8 @@
      (parse-hpat:seq stx #'rest decls)]
     [(~describe . rest)
      (parse-pat:describe stx decls #t)]
+    [(~optional . rest)
+     (parse-hpat:optional stx decls)]
     [_
      (parse-single-pattern stx decls)]))
 
@@ -567,7 +569,18 @@
     [else
      (wrong-syntax stx "expected proper list pattern")]))
 
+(define (parse-hpat:optional stx decls)
+  (define-values (head all-iattrs _name _tmm defaults)
+    (parse-optional-pattern stx decls h-optional-directive-table))
+  (make hpat:optional all-iattrs head defaults))
+
 (define (parse-ehpat/optional stx decls)
+  (define-values (head all-iattrs name too-many-msg defaults)
+    (parse-optional-pattern stx decls eh-optional-directive-table))
+  (make ehpat all-iattrs head
+        (make rep:optional name too-many-msg defaults)))
+
+(define (parse-optional-pattern stx decls optional-directive-table)
   (syntax-case stx (~optional)
     [(~optional p . options)
      (let ([head (parse-head-pattern #'p decls)])
@@ -587,8 +600,7 @@
          (define all-iattrs
            (union-iattrs (list pattern-iattrs defaults-iattrs)))
          (check-iattrs-subset defaults-iattrs pattern-iattrs stx)
-         (make ehpat all-iattrs head
+         (values head all-iattrs name too-many-msg defaults)))]))
-               (make rep:optional name too-many-msg defaults))))]))
 
 (define (parse-ehpat/once stx decls)
   (syntax-case stx (~once)
@@ -876,8 +888,12 @@
 (define describe-option-table
   (list (list '#:transparent)))
 
-;; optional-directive-table
+;; eh-optional-directive-table
-(define optional-directive-table
+(define eh-optional-directive-table
   (list (list '#:too-many check-expression)
         (list '#:name check-expression)
         (list '#:defaults check-bind-clause-list)))
+
+;; h-optional-directive-table
+(define h-optional-directive-table
+  (list (list '#:defaults check-bind-clause-list)))

collects/syntax/scribblings/parse.scrbl

@@ -12,16 +12,31 @@
 @(define ellipses @scheme[...])
 
 @(begin
+   (define (fixup exn)
+     (let ([src (ormap values (exn:fail:syntax-exprs exn))])
+       (if src
+           (make-exn:fail:syntax
+            (format "~a at: ~a" (exn-message exn) (syntax->datum src))
+            (exn-continuation-marks exn)
+            (exn:fail:syntax-exprs exn))
+           exn)))
    (define the-eval
      (parameterize ((sandbox-output 'string)
-                    (sandbox-error-output 'string))
+                    (sandbox-error-output 'string)
+                    (sandbox-make-code-inspector current-code-inspector)
+                    (sandbox-eval-handlers
+                     (list #f
+                           (lambda (thunk)
+                             (with-handlers ([exn:fail:syntax?
+                                              (lambda (e) (raise (fixup e)))])
+                               (thunk))))))
        (make-evaluator 'scheme/base
                        #:requires '(syntax/parse (for-syntax scheme/base)))))
+   (the-eval '(error-print-source-location #f))
    (define-syntax-rule (myexamples e ...)
-     (parameterize ((error-print-source-location #f))
+     (examples #:eval the-eval e ...)))
-       (examples #:eval the-eval e ...))))
 
-@title[#:tag "stxparse"]{Parsing and classifying syntax}
+@title[#:tag "stxparse" #:style '(toc)]{Parsing and classifying syntax}
 
 The @schememodname[syntax/parse] library provides a framework for
 describing and parsing syntax. Using @schememodname[syntax/parse],
@@ -32,6 +47,8 @@ which offers many improvements over @scheme[syntax-case].
 
 @defmodule[syntax/parse]
 
+@local-table-of-contents[]
+
 @;{----------}
 
 @section{Parsing syntax}
@@ -59,25 +76,33 @@ subterms of the syntax object and that clause's side conditions and
 If the syntax object fails to match any of the patterns (or all
 matches fail the corresponding clauses' side conditions), a syntax
 error is raised. If the @scheme[#:context] argument is given,
-@scheme[context-expr] is used in reporting the error.
+@scheme[context-expr] is used in reporting the error; otherwise
+@scheme[stx-expr] is used.
+
+@(myexamples
+  (syntax-parse #'(a b 3)
+    [(x:id ...) 'ok])
+  (syntax-parse #'(a b 3)
+    #:context #'(lambda (a b 3) (+ a b))
+    [(x:id ...) 'ok]))
 
 The @scheme[#:literals] option specifies identifiers that should match
-as literals, rather than simply being pattern variables. A literal in
+as @tech{literals}, rather than simply being @tech{pattern
-the literals list has two components: the identifier used within the
+variables}. A literal in the literals list has two components: the
-pattern to signify the positions to be matched (@scheme[pattern-id]),
+identifier used within the pattern to signify the positions to be
-and the identifier expected to occur in those positions
+matched (@scheme[pattern-id]), and the identifier expected to occur in
-(@scheme[literal-id]). If the single-identifier form is used, the same
+those positions (@scheme[literal-id]). If the single-identifier form
-identifier is used for both purposes.
+is used, the same identifier is used for both purposes.
 
 @bold{Note:} Unlike @scheme[syntax-case], @scheme[syntax-parse]
 requires all literals to have a binding. To match identifiers by their
 symbolic names, consider using the @scheme[atom-in-list] syntax class
 instead.
 
-Many literals can be declared at once via one or more @tech{literal sets},
+Many literals can be declared at once via one or more @tech{literal
-imported with the @scheme[#:literal-sets] option. The literal-set
+sets}, imported with the @scheme[#:literal-sets] option. The
-definition determines the literal identifiers to recognize and the
+literal-set definition determines the literal identifiers to recognize
-names used in the patterns to recognize those literals.
+and the names used in the patterns to recognize those literals.
 
 The @scheme[#:conventions] option imports @tech{convention}s that give
 default syntax classes to pattern variables that do not explicitly
@@ -167,9 +192,9 @@ like the following form.
 @specsubform[pvar-id:syntax-class-id]{
 
 Matches only subterms specified by the @svar[syntax-class-id]. The
-syntax class's attributes are computed for the subterm and bound to
+syntax class's @tech{attributes} are computed for the subterm and
-the pattern variables formed by prefixing @svar[pvar-id.] to the
+bound to the pattern variables formed by prefixing @svar[pvar-id.] to
-name of the attribute. @svar[pvar-id] is bound to the matched
+the name of the attribute. @svar[pvar-id] is bound to the matched
 subterm.
 
 If @svar[pvar-id] is @scheme[_], no attributes are bound.
@@ -179,19 +204,27 @@ If @svar[pvar-id] is empty (that is, if the pattern is of the form
 bound, but their names are not prefixed first.
 
 @myexamples[
-(syntax-parse #'x
+(syntax-parse #'a
   [var:id (syntax-e #'var)])
 (syntax-parse #'12
   [var:id (syntax-e #'var)])
-(syntax-parse #'(x y z)
+(define-syntax-class two
-  [var:id (syntax-e #'var)])]
+  #:attributes (x y)
+  (pattern (x y)))
+(syntax-parse #'(a b)
+  [t:two (syntax->datum #'(t t.x t.y))])
+(syntax-parse #'(a b)
+  [t
+   #:declare t two
+   (syntax->datum #'(t t.x t.y))])]
+
 }
 
 @specsubform[literal-id]{
 
 An identifier that appears in the literals list is not a pattern
-variable; instead, it is a literal that matches any identifier
+variable; instead, it is a @deftech{literal} that matches any
-@scheme[free-identifier=?] to it.
+identifier @scheme[free-identifier=?] to it.
 
 Specifically, if @scheme[literal-id] is the ``pattern'' name of an
 entry in the literals list, then it represents a pattern that matches