Added ~peek-not, cf packrat/PEG ! operator

collects/syntax/parse/private/parse.rkt

@@ -603,6 +603,23 @@ Conventions:
             (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)))]
+       [#s(hpat:peek-not () subpattern)
+        #`(let* ([fh0 fail-handler]
+                 [pr0 pr]
+                 [es0 es]
+                 [fail-to-succeed
+                  (lambda (fs)
+                    (let ([rest-x x]
+                          [rest-cx cx]
+                          [rest-pr pr])
+                      k))])
+            ;; ~not implicitly prompts to be safe,
+            ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
+            ;; (statically checked!)
+            (with ([fail-handler fail-to-succeed]
+                   [cut-prompt fail-to-succeed]) ;; to be safe
+              (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
+                       (fh0 (failure pr0 es0)))))]
        [_
         (with-syntax ([attrs (pattern-attrs (wash #'head))])
           #'(parse:S x cx

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

@@ -105,6 +105,7 @@ A HeadPattern is one of
   (hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr))
   (hpat:post Base HeadPattern)
   (hpat:peek Base HeadPattern)
+  (hpat:peek-not Base HeadPattern)
 |#
 
 (define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
@@ -119,6 +120,7 @@ A HeadPattern is one of
 (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)
+(define-struct hpat:peek-not (attrs pattern) #:prefab)
 
 #|
 An EllipsisHeadPattern is
@@ -192,7 +194,8 @@ A SideClause is one of
       (hpat:commit? x)
       (hpat:reflect? x)
       (hpat:post? x)
-      (hpat:peek? x)))
+      (hpat:peek? x)
+      (hpat:peek-not? x)))
 
 (define (ellipsis-head-pattern? x)
   (ehpat? x))
@@ -224,7 +227,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
+                  hpat:peek hpat:peek-not
                   ehpat)))
 
 ;; ----
@@ -375,6 +378,9 @@ A SideClause is one of
 (define (create-hpat:peek pattern)
   (make hpat:peek (pattern-attrs pattern) pattern))
 
+(define (create-hpat:peek-not pattern)
+  (make hpat:peek-not null pattern))
+
 ;; ----
 
 (define (action/head-pattern->list-pattern p)

collects/syntax/parse/private/rep.rkt

@@ -120,7 +120,8 @@
         (quote-syntax ~reflect)
         (quote-syntax ~splicing-reflect)
         (quote-syntax ~eh-var)
-        (quote-syntax ~peek)))
+        (quote-syntax ~peek)
+        (quote-syntax ~peek-not)))
 
 (define (reserved? stx)
   (and (identifier? stx)
@@ -464,7 +465,7 @@ 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 ~peek ~delimit-cut ~commit ~reflect
+                    ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
                     ~splicing-reflect)
     [wildcard
      (wildcard? #'wildcard)
@@ -550,6 +551,10 @@ A syntax class is integrable if
      (disappeared! stx)
      (check-head!
       (parse-pat:peek stx decls))]
+    [(~peek-not . rest)
+     (disappeared! stx)
+     (check-head!
+      (parse-pat:peek-not stx decls))]
     [(~parse . rest)
      (disappeared! stx)
      (check-action!
@@ -1028,6 +1033,12 @@ A syntax class is integrable if
      (let ([p (parse-head-pattern #'pattern decls)])
        (create-hpat:peek p))]))
 
+(define (parse-pat:peek-not stx decls)
+  (syntax-case stx (~peek-not)
+    [(~peek-not pattern)
+     (let ([p (parse-head-pattern #'pattern decls)])
+       (create-hpat:peek-not p))]))
+
 (define (parse-pat:parse stx decls)
   (syntax-case stx (~parse)
     [(~parse pattern expr)

collects/syntax/parse/todo.txt

@@ -29,7 +29,18 @@ Allow reflected syntax classes in conventions.
 
 Rename "conventions" to "convention-set"?
 
+Unify convention-sets and literal-sets?
+
 For documentation, talk about "primary attributes" vs "nested
 attributes". Helps explain ~eh-var and #:auto-nested-attributes.
 
+For documentation, deftech "term-sequence", use consistently in
+H-pattern docs, etc.
+
+Add documentation sections:
+  - Pattern matching model
+  - Static semantics (attributes)
+
+Add syntax exception variant with more information.
+
 Fix syntaxes pinpointed for repetition constraint violations.

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 ~peek)
+                            ~! ~bind ~fail ~parse ~peek ~peek-not)
                 [S-pattern
                  pvar-id
                  pvar-id:syntax-class-id
@@ -77,6 +77,7 @@ means specifically @tech{@Spattern}.
                  (@#,ref[~commit h] H-pattern)
                  (@#,ref[~delimit-cut h] H-pattern)
                  (~peek H-pattern)
+                 (~peek-not H-pattern)
                  proper-S-pattern]
                 [EH-pattern
                  (@#,ref[~or eh] EH-pattern ...)
@@ -733,6 +734,25 @@ a sequence.
 ]
 }
 
+@specsubform[(@#,defhere[~peek-not] H-pattern)]{
+
+Like @racket[~peek], but succeeds if the subpattern fails and fails if
+the subpattern succeeds. On success, the @racket[~peek-not] resets the
+matching position, so the pattern consumes no input. Used to look
+ahead in a sequence. None of the subpattern's attributes are bound
+outside of the @scheme[~peek-not]-pattern.
+
+@myexamples[
+(define-splicing-syntax-class final (code:comment "final term")
+  (pattern (~seq x (~peek-not _))))
+
+(syntax-parse #'(a b c)
+  [((~or f:final o:other) ...)
+   (printf "finals are ~s\n" (syntax->datum #'(f.x ...)))
+   (printf "others are ~s\n" (syntax->datum #'(o ...)))])
+]
+}
+
 @specsubform[S-pattern]{
 
 Matches a sequence of one element, which must be a term matching