syntax/parse: started support for backtracking into syntax classes

incomplete, need to separate descriptions from failure handlers

svn: r18013

collects/syntax/keyword.ss

@@ -58,4 +58,5 @@
  [check-expression checker]
  [check-identifier checker]
  [check-stx-string checker]
+ [check-stx-boolean checker]
  [check-stx-listof (-> checker checker)])

collects/syntax/parse/experimental.ss

@@ -37,6 +37,7 @@
                           '(#s(attr a.name a.depth #f) ...)
                           (quote-syntax parser)
                           (quote-syntax get-description)
+                          #t
                           #t)))]))
 
 

collects/syntax/private/keyword.ss

@@ -12,6 +12,7 @@
 
          check-expression
          check-identifier
+         check-stx-boolean
          check-stx-string
          check-stx-listof)
 

collects/syntax/private/stxparse/parse.ss

@@ -44,56 +44,88 @@
     [(fail x #:expect p #:fce fce)
      #'(enclosing-fail (make-failure x fce p))]))
 
+;; ----
+
+#|
+
+syntax-class protocol
+---------------------
+
+for  syntax-class SC with args (P ...)
+
+if commit? = #t
+  parser : Stx P ... -> (U list expectation)
+if commit? = #f
+  parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer
+
+|#
+
 ;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
 ;;   : expr[(values ParseFunction DescriptionFunction)]
 ;; Takes a list of the relevant attrs; order is significant!
 ;; Returns either fail or a list having length same as 'relsattrs'
 (define-syntax (parse:rhs stx)
   (syntax-case stx ()
-    [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...))
+    [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) commit?)
                 relsattrs (arg ...) get-description splicing?)
-     #`(with-error-collector
+     (with-syntax ([(k-param ...)
-         (make-parser
+                    (if (syntax-e #'commit?)
-          (lambda (x arg ...)
+                        #'()
-            (define (fail-rhs failure)
+                        #'(return))]
+                   [k-ref/fail
+                    (if (syntax-e #'commit?)
+                        #'values
+                        #'return)]
+                   [k-ref/ok
+                    (if (syntax-e #'commit?)
+                        #'values
+                        #'(lambda (result) (return (cons enclosing-fail result))))])
+       #| #`(with-error-collector
+             (make-parser
+              (lambda ___)
+              (collect-error)))
+       |#
+       #'(lambda (x k-param ... arg ...)
+           (define (fail-rhs failure)
+             (k-ref/fail
               (expectation-of-thing (get-description arg ...)
                                     transparent?
-                                    (if transparent? failure #f)))
+                                    (if transparent? failure #f))))
-            def ...
+           def ...
-            (syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
+           (syntax-parameterize ((this-syntax (make-rename-transformer #'x)))
-              (with-enclosing-fail* fail-rhs
+             (with-enclosing-fail* fail-rhs
-                (parse:variants x relsattrs variants splicing?))))
+               (parse:variants x relsattrs variants splicing? k-ref/ok)))))]))
-          (collect-error)))]))
 
 ;; (parse:variants id (SAttr ...) (Variant ...) boolean)
 ;;   : expr[SyntaxClassResult]
 (define-syntax (parse:variants stx)
   (syntax-case stx ()
-    [(parse:variants x relsattrs (variant ...) splicing?)
+    [(parse:variants x relsattrs (variant ...) splicing? k-ref)
-     #'(try (parse:variant x relsattrs variant splicing?) ...)]))
+     #'(try (parse:variant x relsattrs variant splicing? k-ref) ...)]))
 
 (define-syntax (parse:variant stx)
   (syntax-case stx ()
-    [(parse:variant x relsattrs variant #f)
+    [(parse:variant x relsattrs variant #f k-ref)
      (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
        #`(let ([fc (dfc-empty x)])
            def ...
-           (parse:S x fc pattern (variant-success x relsattrs variant ()))))]
+           (parse:S x fc pattern (variant-success x relsattrs variant () k-ref))))]
-    [(parse:variant x relsattrs variant #t)
+    [(parse:variant x relsattrs variant #t k-ref)
      (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
        #`(let ([fc (dfc-empty x)])
            def ...
            (parse:H x fc pattern rest index
-                    (variant-success x relsattrs variant (rest index)))))]))
+                    (variant-success x relsattrs variant (rest index) k-ref))))]))
 
 ;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult]
 (define-syntax (variant-success stx)
   (syntax-case stx ()
-    [(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...))
+    [(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...) k-ref)
      #`(convert-sides x sides
                       (base-success-expr #,(pattern-attrs (wash #'pattern))
                                          relsattrs
-                                         (also ...)))]))
+                                         (also ...)
+                                         k-ref))]))
 
 ;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X]
 ;;   where (m (IAttr ...) MArgs) : expr[X]
@@ -126,12 +158,12 @@
 ;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult]
 (define-syntax (base-success-expr stx)
   (syntax-case stx ()
-    [(base-success-expr iattrs relsattrs (also ...))
+    [(base-success-expr iattrs relsattrs (also ...) k-ref)
      (let ([reliattrs
             (reorder-iattrs (wash-sattrs #'relsattrs)
                             (wash-iattrs #'iattrs))])
        (with-syntax ([(#s(attr name _ _) ...) reliattrs])
-         #'(list also ... (attribute name) ...)))]))
+         #'(k-ref (list also ... (attribute name) ...))))]))
 
 ;; ----
 
@@ -209,18 +241,34 @@
             (parse:S x fc pattern k))]
        [#s(pat:any attrs)
         #'k]
-       [#s(pat:var _attrs name  #f () ())
+       [#s(pat:var _attrs name #f () () _)
         #'(let-attributes ([#s(attr name 0 #t) x])
             k)]
-       [#s(pat:var _attrs name parser (arg ...) (nested-a ...))
+       [#s(pat:var _attrs name parser (arg ...) (nested-a ...) commit?)
-        #`(let ([result (parser x arg ...)])
+        (with-syntax* ([(name-attr ...)
-            (if (ok? result)
+                        (if (identifier? #'name)
-                (let-attributes (#,@(if (identifier? #'name)
+                            #'([#s(attr name 0 #t) x])
-                                        #'([#s(attr name 0 #t) x])
+                            #'())]
-                                        #'()))
+                       [ok-e
-                  (let/unpack ((nested-a ...) result)
+                        #'(let-attributes (name-attr ...)
-                    k))
+                            (let/unpack ((nested-a ...) result)
-                (fail x #:expect result #:fce fc)))]
+                              k))]
+                       [fail-e
+                        #'(fail x #:expect result #:fce fc)])
+          (if (syntax-e #'commit?)
+              #'(let ([result (parser x arg ...)])
+                  (if (ok? result)
+                      ok-e
+                      fail-e))
+              #'(parser x
+                        (lambda (result)
+                          (if (ok? result)
+                              (let ([fail-k (car result)]
+                                    [result (cdr result)])
+                                (with-enclosing-fail fail-k
+                                  ok-e))
+                              fail-e))
+                        arg ...)))]
        [#s(pat:datum attrs datum)
         #`(let ([d (syntax->datum x)])
             (if (equal? d (quote datum))
@@ -387,19 +435,35 @@
                        (with-enclosing-cut-fail previous-cut-fail
                          (with-enclosing-fail previous-fail
                            k))))))]
-       [#s(hpat:var _attrs name parser (arg ...) (nested-a ...))
+       [#s(hpat:var _attrs name parser (arg ...) (nested-a ...) commit?)
-        #`(let ([result (parser x arg ...)])
+        (with-syntax* ([(name-attr ...)
-            (if (ok? result)
+                        (if (identifier? #'name)
-                (let* ([rest (car result)]
+                            #'([#s(attr name 0 #t)
-                       [local-fc (cadr result)]
+                                (stx-list-take x (dfc->index local-fc))])
-                       [rest-fc (dfc-append fc local-fc)])
+                            #'())]
-                  (let-attributes (#,@(if (identifier? #'name)
+                       [ok-e
-                                          #'([#s(attr name 0 #t)
+                        #'(let* ([rest (car result)]
-                                              (stx-list-take x (dfc->index local-fc))])
+                                 [local-fc (cadr result)]
-                                          #'()))
+                                 [rest-fc (dfc-append fc local-fc)])
-                    (let/unpack ((nested-a ...) (cddr result))
+                            (let-attributes (name-attr ...)
-                      k)))
+                              (let/unpack ((nested-a ...) (cddr result))
-                (fail x #:expect result #:fce fc)))]
+                                k)))]
+                       [fail-e
+                        #'(fail x #:expect result #:fce fc)])
+          (if (syntax-e #'commit?)
+              #'(let ([result (parser x arg ...)])
+                  (if (ok? result)
+                      ok-e
+                      fail-e))
+              #'(parser x
+                        (lambda (result)
+                          (if (ok? result)
+                              (let ([fail-k (car result)]
+                                    [result (cdr result)])
+                                (with-enclosing-fail fail-k
+                                  ok-e))
+                              fail-e))
+                        arg ...)))]
        [#s(hpat:and (a ...) head single)
         #`(parse:H x fc head rest rest-fc
                    (let ([lst (stx-list-take x (dfc-difference fc rest-fc))])

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

@@ -23,9 +23,10 @@
 
 #|
 A stxclass is
-  (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean)
+  (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean)
 |#
-(define-struct stxclass (name params attrs parser-name description splicing?)
+(define-struct stxclass (name params attrs parser-name description
+                         splicing? commit?)
   #:prefab)
 
 (define (stxclass/s? x)
@@ -38,7 +39,7 @@ An RHS is
   (make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx))
 definitions: auxiliary definitions from #:declare
 |#
-(define-struct rhs (ostx attrs transparent? description variants definitions)
+(define-struct rhs (ostx attrs transparent? description variants definitions commit?)
   #:prefab)
 
 #|
@@ -73,7 +74,7 @@ A LiteralSet is
 ;; make-dummy-stxclass : identifier -> SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
 (define (make-dummy-stxclass name)
-  (make stxclass (syntax-e name) null null #f #f #f))
+  (make stxclass (syntax-e name) null null #f #f #f #t))
 
 
 ;; Environments
@@ -86,13 +87,13 @@ DeclEnv =
 DeclEntry =
   (make-den:lit id id)
   (make-den:class id id (listof syntax) bool)
-  (make-den:parser id id (listof SAttr) bool)
+  (make-den:parser id id (listof SAttr) bool bool)
 |#
 (define-struct declenv (table conventions))
 
 (define-struct den:lit (internal external))
 (define-struct den:class (name class args))
-(define-struct den:parser (parser description attrs splicing?))
+(define-struct den:parser (parser description attrs splicing? commit?))
 
 (define (new-declenv literals #:conventions [conventions null])
   (for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)])
@@ -119,7 +120,7 @@ DeclEntry =
                          stxclass-name)
            (wrong-syntax (if blame-declare? name id)
                          "identifier previously declared"))]
-      [(struct den:parser (_p _d _a _sp))
+      [(struct den:parser (_p _d _a _sp _c))
        (wrong-syntax id "(internal error) late unbound check")]
       ['#f (void)])))
 
@@ -137,11 +138,11 @@ DeclEntry =
                        (make den:class id stxclass-name args))
    (declenv-conventions env)))
 
-(define (declenv-put-parser env id parser get-description attrs splicing?)
+(define (declenv-put-parser env id parser get-description attrs splicing? commit?)
   ;; no unbound check, since replacing 'stxclass entry
   (make-declenv
    (bound-id-table-set (declenv-table env) id
-                       (make den:parser parser get-description attrs splicing?))
+                       (make den:parser parser get-description attrs splicing? commit?))
    (declenv-conventions env)))
 
 ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
@@ -212,7 +213,7 @@ DeclEntry =
   (-> DeclEnv/c identifier? identifier?
       DeclEnv/c)]
  [declenv-put-parser
-  (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean?
+  (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? boolean?
       DeclEnv/c)]
  [declenv-domain-difference
   (-> DeclEnv/c (listof identifier?)

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

@@ -16,7 +16,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))
+  (make-pat:var Base id id (listof stx) (listof IAttr) bool)
   (make-pat:literal Base identifier)
   (make-pat:datum Base datum)
   (make-pat:ghost Base GhostPattern SinglePattern)
@@ -37,7 +37,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) #:prefab)
+(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab)
 (define-struct pat:literal (attrs id) #:prefab)
 (define-struct pat:datum (attrs datum) #:prefab)
 (define-struct pat:ghost (attrs ghost inner) #:prefab)
@@ -68,7 +68,7 @@ ghost:and is desugared below in create-* procedures
 
 #|
 A HeadPattern is one of 
-  (make-hpat:var Base id id (listof stx) (listof IAttr))
+  (make-hpat:var Base id id (listof stx) (listof IAttr) bool)
   (make-hpat:seq Base ListPattern)
   (make-hpat:ghost Base GhostPattern HeadPattern)
   (make-hpat:and Base HeadPattern SinglePattern)
@@ -77,7 +77,7 @@ A HeadPattern is one of
   (make-hpat:describe Base stx/#f boolean HeadPattern)
 |#
 
-(define-struct hpat:var (attrs name parser args nested-attrs) #:prefab)
+(define-struct hpat:var (attrs name parser args nested-attrs commit?) #:prefab)
 (define-struct hpat:seq (attrs inner) #:prefab)
 (define-struct hpat:ghost (attrs ghost inner) #:prefab)
 (define-struct hpat:and (attrs head single) #:prefab)
@@ -178,10 +178,10 @@ A Kind is one of
 (define (create-pat:any)
   (make pat:any null))
 
-(define (create-pat:var name parser args nested-attrs)
+(define (create-pat:var name parser args nested-attrs commit?)
   (let ([attrs
          (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
-    (make pat:var attrs name parser args nested-attrs)))
+    (make pat:var attrs name parser args nested-attrs commit?)))
 
 (define (create-pat:datum datum)
   (make pat:datum null datum))
@@ -239,10 +239,10 @@ A Kind is one of
 
 ;; ----
 
-(define (create-hpat:var name parser args nested-attrs)
+(define (create-hpat:var name parser args nested-attrs commit?)
   (let ([attrs
          (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
-    (make hpat:var attrs name parser args nested-attrs)))
+    (make hpat:var attrs name parser args nested-attrs commit?)))
 
 (define (create-hpat:seq lp)
   (make hpat:seq (pattern-attrs lp) lp))

collects/syntax/private/stxparse/rep.ss

@@ -124,8 +124,9 @@
 ;; parser requires stxclasses to be bound.
 (define (parse-rhs stx expected-attrs splicing? #:context ctx)
   (parameterize ((current-syntax-context ctx))
-    (define-values (rest description transp? attributes auto-nested? decls defs)
+    (define-values (rest description transp? attributes auto-nested?
-      (parse-rhs/part1 stx (and expected-attrs #t)))
+                    decls defs commit?)
+      (parse-rhs/part1 stx splicing? (and expected-attrs #t)))
     (define patterns
       (parameterize ((stxclass-lookup-config
                       (cond [expected-attrs 'yes]
@@ -137,9 +138,9 @@
     (let ([sattrs
            (or attributes
                (intersect-sattrss (map variant-attrs patterns)))])
-      (make rhs stx sattrs transp? description patterns defs))))
+      (make rhs stx sattrs transp? description patterns defs commit?))))
 
-(define (parse-rhs/part1 stx strict?)
+(define (parse-rhs/part1 stx splicing? strict?)
   (define-values (chunks rest)
     (parse-keyword-options stx rhs-directive-table
                            #:context (current-syntax-context)
@@ -149,9 +150,11 @@
   (define opaque? (and (assq '#:opaque chunks) #t))
   (define transparent? (not opaque?))
   (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t))
+  (define commit? ;; FIXME: default value should be (not splicing?) once this works
+    (options-select-value chunks '#:commit? #:default #t))
   (define attributes (options-select-value chunks '#:attributes #:default #f))
   (define-values (decls defs) (get-decls+defs chunks strict?))
-  (values rest description transparent? attributes auto-nested? decls defs))
+  (values rest description transparent? attributes auto-nested? decls defs commit?))
 
 (define (parse-variants rest decls splicing? expected-attrs)
   (define (gather-patterns stx)
@@ -218,13 +221,15 @@
                            [description (generate-temporary class)]
                            [(arg ...) args])
                (values (make den:parser #'parser #'description
-                             (stxclass-attrs sc) (stxclass/h? sc))
+                             (stxclass-attrs sc) (stxclass/h? sc)
+                             (stxclass-commit? sc))
                        (list #'(define (parser x) (sc-parser x arg ...))
                              #'(define (description) (description arg ...)))))
              (values (make den:parser #'sc-parser #'sc-description
-                           (stxclass-attrs sc) (stxclass/h? sc))
+                           (stxclass-attrs sc) (stxclass/h? sc)
+                           (stxclass-commit? sc))
                      null))))]
-    [(struct den:parser (_p _d _a _sp))
+    [(struct den:parser (_p _d _a _sp _c))
      (values entry null)]))
 
 (define (append-lits+litsets lits litsets)
@@ -444,10 +449,10 @@
      (error 'parse-pat:id
             "(internal error) decls had leftover stxclass entry: ~s"
             entry)]
-    [(struct den:parser (parser desc attrs splicing?))
+    [(struct den:parser (parser desc attrs splicing? commit?))
      (if splicing?
-         (parse-pat:id/h id parser null attrs)
+         (parse-pat:id/h id parser null attrs commit?)
-         (parse-pat:id/s id parser null attrs))]
+         (parse-pat:id/s id parser null attrs commit?))]
     ['#f
      (when #t ;; FIXME: right place???
        (unless (safe-name? id)
@@ -455,7 +460,7 @@
      (let-values ([(name sc) (split-id/get-stxclass id decls)])
        (if sc
            (parse-pat:var* id allow-head? name sc null)
-           (create-pat:var name #f null null)))]))
+           (create-pat:var name #f null null #t)))]))
 
 (define (parse-pat:var stx decls allow-head?)
   (define name0
@@ -486,31 +491,33 @@
          (let ([sc (get-stxclass/check-arg-count scname (length args))])
            (parse-pat:var* stx allow-head? name0 sc args))]
         [else ;; Just proper name
-         (create-pat:var name0 #f null null)]))
+         (create-pat:var name0 #f null null #t)]))
 
 (define (parse-pat:var* stx allow-head? name sc args)
   (cond [(stxclass/s? sc)
          (parse-pat:id/s name
                          (stxclass-parser-name sc)
                          args
-                         (stxclass-attrs sc))]
+                         (stxclass-attrs sc)
+                         (stxclass-commit? sc))]
         [(stxclass/h? sc)
          (unless allow-head?
            (wrong-syntax stx "splicing syntax class not allowed here"))
          (parse-pat:id/h name
                          (stxclass-parser-name sc)
                          args
-                         (stxclass-attrs sc))]))
+                         (stxclass-attrs sc)
+                         (stxclass-commit? sc))]))
 
-(define (parse-pat:id/s name parser args attrs)
+(define (parse-pat:id/s name parser args attrs commit?)
   (define prefix (name->prefix name))
   (define bind (name->bind name))
-  (create-pat:var bind parser args (id-pattern-attrs attrs prefix)))
+  (create-pat:var bind parser args (id-pattern-attrs attrs prefix) commit?))
 
-(define (parse-pat:id/h name parser args attrs)
+(define (parse-pat:id/h name parser args attrs commit?)
   (define prefix (name->prefix name))
   (define bind (name->bind name))
-  (create-hpat:var bind parser args (id-pattern-attrs attrs prefix)))
+  (create-hpat:var bind parser args (id-pattern-attrs attrs prefix) commit?))
 
 (define (name->prefix id)
   (cond [(wildcard? id) #f]
@@ -1038,6 +1045,7 @@
          (list '#:opaque)
          (list '#:attributes check-attr-arity-list)
          (list '#:auto-nested-attributes)
+         (list '#:commit? check-stx-boolean)
          common-parse-directive-table))
 
 ;; pattern-directive-table

collects/syntax/private/stxparse/sc.ss

@@ -59,13 +59,15 @@
               (parse-rhs #'rhss #f splicing? #:context stx))])
        (with-syntax ([parser (generate-temporary
                               (format-symbol "parse-~a" (syntax-e #'name)))]
-                     [attrs (rhs-attrs the-rhs)])
+                     [attrs (rhs-attrs the-rhs)]
+                     [commit? (rhs-commit? the-rhs)])
          #`(begin (define-syntax name
                     (make stxclass 'name '(arg ...)
                           'attrs
                           ((syntax-local-certifier) (quote-syntax parser))
                           ((syntax-local-certifier) (quote-syntax description))
-                          '#,splicing?))
+                          '#,splicing?
+                          'commit?))
                   (define-values (parser description)
                     (functions/rhs name (arg ...) attrs rhss #,splicing? #,stx))))))))
 
@@ -103,7 +105,8 @@
                                            (quote-syntax #,(den:parser-parser den))
                                            (quote-syntax #,(den:parser-description den))
                                            (quote #,(den:parser-attrs den))
-                                           (quote #,(den:parser-splicing? den))))
+                                           (quote #,(den:parser-splicing? den))
+                                           (quote #,(den:parser-commit? den))))
                                   defs))))])
          #'(begin
              def ... ...

collects/syntax/scribblings/keyword.scrbl

@@ -268,3 +268,10 @@ original procedure accepted.
 A @techlink{check-procedure} that accepts syntax strings.
 
 }
+
+@defproc[(check-stx-boolean [stx syntax?] [ctx (or/c false/c syntax?)])
+         syntax?]{
+
+A @techlink{check-procedure} that accepts syntax booleans.
+
+}