added lookahead (~peek)

collects/syntax/parse/private/keywords.rkt

@@ -35,3 +35,4 @@
 (define-keyword ~splicing-reflect)
 (define-keyword ~post)
 (define-keyword ~eh-var)
+(define-keyword ~peek)

collects/syntax/parse/private/parse.rkt

@@ -598,6 +598,11 @@ Conventions:
        [#s(hpat:post _ pattern)
         #'(let ([pr (ps-add-post pr)])
             (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
+       [#s(hpat:peek _ pattern)
+        #`(let ([saved-x x] [saved-cx cx] [saved-pr pr])
+            (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es
+                     (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr])
+                       k)))]
        [_
         (with-syntax ([attrs (pattern-attrs (wash #'head))])
           #'(parse:S x cx

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

@@ -104,6 +104,7 @@ A HeadPattern is one of
   (hpat:commit Base HeadPattern)
   (hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
   (hpat:post Base HeadPattern)
+  (hpat:peek Base HeadPattern)
 |#
 
 (define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
@@ -117,6 +118,7 @@ A HeadPattern is one of
 (define-struct hpat:commit (attrs pattern) #:prefab)
 (define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab)
 (define-struct hpat:post (attrs pattern) #:prefab)
+(define-struct hpat:peek (attrs pattern) #:prefab)
 
 #|
 An EllipsisHeadPattern is
@@ -189,7 +191,8 @@ A SideClause is one of
       (hpat:delimit? x)
       (hpat:commit? x)
       (hpat:reflect? x)
-      (hpat:post? x)))
+      (hpat:post? x)
+      (hpat:peek? x)))
 
 (define (ellipsis-head-pattern? x)
   (ehpat? x))
@@ -221,6 +224,7 @@ A SideClause is one of
                   action:do action:post
                   hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe
                   hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post
+                  hpat:peek
                   ehpat)))
 
 ;; ----
@@ -368,6 +372,9 @@ A SideClause is one of
 (define (create-hpat:post pattern)
   (make hpat:post (pattern-attrs pattern) pattern))
 
+(define (create-hpat:peek pattern)
+  (make hpat:peek (pattern-attrs pattern) pattern))
+
 ;; ----
 
 (define (action/head-pattern->list-pattern p)

collects/syntax/parse/private/rep.rkt

@@ -119,7 +119,8 @@
         (quote-syntax ~commit)
         (quote-syntax ~reflect)
         (quote-syntax ~splicing-reflect)
-        (quote-syntax ~eh-var)))
+        (quote-syntax ~eh-var)
+        (quote-syntax ~peek)))
 
 (define (reserved? stx)
   (and (identifier? stx)
@@ -463,7 +464,8 @@ A syntax class is integrable if
            (wrong-syntax stx "action pattern not allowed here")]))
   (syntax-case stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe
                     ~seq ~optional ~! ~bind ~fail ~parse ~do
-                    ~post ~delimit-cut ~commit ~reflect ~splicing-reflect)
+                    ~post ~peek ~delimit-cut ~commit ~reflect
+                    ~splicing-reflect)
     [wildcard
      (wildcard? #'wildcard)
      (begin (disappeared! stx)
@@ -544,6 +546,10 @@ A syntax class is integrable if
     [(~post . rest)
      (disappeared! stx)
      (parse-pat:post stx decls allow-head? allow-action?)]
+    [(~peek . rest)
+     (disappeared! stx)
+     (check-head!
+      (parse-pat:peek stx decls))]
     [(~parse . rest)
      (disappeared! stx)
      (check-action!
@@ -1016,6 +1022,12 @@ A syntax class is integrable if
              [else
               (create-pat:post p)]))]))
 
+(define (parse-pat:peek stx decls)
+  (syntax-case stx (~peek)
+    [(~peek pattern)
+     (let ([p (parse-head-pattern #'pattern decls)])
+       (create-hpat:peek p))]))
+
 (define (parse-pat:parse stx decls)
   (syntax-case stx (~parse)
     [(~parse pattern expr)

collects/syntax/scribblings/parse/patterns.scrbl

@@ -32,7 +32,7 @@ means specifically @tech{@Spattern}.
 
 @schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~datum
                             ~describe ~seq ~optional ~rep ~once ~between
-                            ~! ~bind ~fail ~parse)
+                            ~! ~bind ~fail ~parse ~peek)
                 [S-pattern
                  pvar-id
                  pvar-id:syntax-class-id
@@ -76,6 +76,7 @@ means specifically @tech{@Spattern}.
                  (@#,ref[~describe h] maybe-opaque expr H-pattern)
                  (@#,ref[~commit h] H-pattern)
                  (@#,ref[~delimit-cut h] H-pattern)
+                 (~peek H-pattern)
                  proper-S-pattern]
                 [EH-pattern
                  (@#,ref[~or eh] EH-pattern ...)
@@ -715,6 +716,23 @@ Like the @Spattern version, @ref[~delimit-cut s], but matches a head
 pattern instead.
 }
 
+@specsubform[(@#,defhere[~peek] H-pattern)]{
+
+Matches the @racket[H-pattern] but then resets the matching position,
+so the @racket[~peek] pattern consumes no input. Used to look ahead in
+a sequence.
+
+@examples[#:eval the-eval
+(define-splicing-syntax-class nf-id (code:comment "non-final id")
+  (pattern (~seq x:id (~peek another:id))))
+
+(syntax-parse #'(a b c 1 2 3)
+  [(n:nf-id ... rest ...)
+   (printf "nf-ids are ~s\n" (syntax->datum #'(n.x ...)))
+   (printf "rest is ~s\n" (syntax->datum #'(rest ...)))])
+]
+}
+
 @specsubform[S-pattern]{
 
 Matches a sequence of one element, which must be a term matching