Enforce refactoring rule grammar more rigorously

private/more-syntax-parse-classes.rkt

@@ -0,0 +1,77 @@
+#lang racket/base
+
+
+(provide syntax-parse-option
+         syntax-parse-pattern-directive)
+
+
+(require syntax/parse)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(define-splicing-syntax-class syntax-parse-option
+  (pattern (~seq #:context ~! context-expr:expr))
+  (pattern (~seq #:literals ~! (literal:syntax-parse-literal ...)))
+  (pattern (~seq #:datum-literals ~! (datum-literal:syntax-parse-datum-literal ...)))
+  (pattern (~seq #:literal-sets ~! (literal-set:syntax-parse-literal-set ...)))
+  (pattern #:track-literals)
+  (pattern (~seq #:conventions ~! (convention-id:id ...)))
+  (pattern (~seq #:local-conventions ~! (convention-id:id ...)))
+  (pattern #:disable-colon-notation))
+
+
+(define-syntax-class syntax-parse-literal
+  (pattern literal-id:id)
+  (pattern (pattern-id:id literal-id:id))
+  (pattern (pattern-id:id literal-id:id #:phase phase-expr:expr)))
+
+
+(define-syntax-class syntax-parse-datum-literal
+  (pattern literal-id:id)
+  (pattern (pattern-id:id literal-id:id)))
+
+
+(define-syntax-class syntax-parse-literal-set
+  (pattern literal-set-id:id)
+  (pattern (literal-set-id:id literal-set-option:syntax-parse-literal-set-option ...)))
+
+
+(define-splicing-syntax-class syntax-parse-literal-set-option
+  (pattern (~seq #:at context-id:id))
+  (pattern (~seq #:phase phase-expr:expr)))
+
+
+(define-splicing-syntax-class syntax-parse-pattern-directive
+  (pattern (~seq #:declare ~! pvar-id:id
+                 (~or syntax-class-id:id (syntax-class-id:id arg ...))
+                 (~optional (~seq #:role role-expr:expr))))
+  (pattern (~seq #:post ~! action-pattern:syntax-parse-action-pattern))
+  (pattern (~seq #:and ~! action-pattern:syntax-parse-action-pattern))
+  (pattern (~seq #:with ~! syntax-pattern stx-expr:expr))
+  (pattern (~seq #:attr ~! (~or attr-name-id:id (attr-name-id:id depth)) expr:expr))
+  (pattern (~seq #:fail-when ~! condition-expr:expr message-expr:expr))
+  (pattern (~seq #:fail-unless ~! condition-expr:expr message-expr:expr))
+  (pattern (~seq #:when ~! condition-expr:expr))
+  (pattern (~seq #:do ~! [defn-or-expr ...]))
+  (pattern (~seq #:undo ~! [defn-or-expr ...]))
+  (pattern #:cut))
+
+
+(define-syntax-class syntax-parse-action-pattern
+  #:literals (~! ~bind ~fail ~parse ~and ~do ~undo ~post)
+  (pattern :~!)
+  (pattern (:~bind [(~or attr-name-id:id (attr-name-id:id depth)) expr:expr] ...))
+  (pattern
+    (:~fail (~optional fail-condition:syntax-parse-fail-condition) (~optional mesage-expr:expr)))
+  (pattern (:~parse S-pattern stx-expr:expr))
+  (pattern (:~and A-pattern:syntax-parse-action-pattern ...+))
+  (pattern (:~do defn-or-expr ...))
+  (pattern (:~undo defn-or-expr ...))
+  (pattern (:~post A-pattern:syntax-parse-action-pattern)))
+
+
+(define-splicing-syntax-class syntax-parse-fail-condition
+  (pattern (~seq #:when condition-expr:expr))
+  (pattern (~seq #:unless condition-expr:expr)))

refactoring-rule.rkt

@@ -22,11 +22,12 @@
 
 
 (require (for-syntax racket/base
-                     racket/syntax)
-         (for-template resyntax/default-recommendations/private/definition-context)
+                     racket/syntax
+                     resyntax/private/more-syntax-parse-classes)
          rebellion/base/immutable-string
          rebellion/base/option
          rebellion/type/object
+         resyntax/default-recommendations/private/definition-context
          resyntax/private/source
          resyntax/private/syntax-replacement
          resyntax/private/syntax-neighbors
@@ -68,8 +69,8 @@
 (define-syntax-parse-rule
   (define-refactoring-rule id:id
     #:description description
-    parse-option ...
-    [pattern pattern-directive ... replacement])
+    parse-option:syntax-parse-option ...
+    [pattern pattern-directive:syntax-parse-pattern-directive ... replacement])
   #:declare description (expr/c #'string?)
   (define id
     (constructor:refactoring-rule
@@ -79,16 +80,18 @@
      (λ (stx analysis)
        (parameterize ([current-source-code-analysis analysis])
          (syntax-parse stx
-           parse-option ...
-           [pattern pattern-directive ... (present #'replacement)]
+           (~@ . parse-option) ...
+           [pattern (~@ . pattern-directive) ... (present #'replacement)]
            [_ absent]))))))
 
 
 (define-syntax-parse-rule
   (define-definition-context-refactoring-rule id:id
     #:description (~var description (expr/c #'string?))
-    parse-option ...
-    [splicing-pattern pattern-directive ... (splicing-replacement ...)])
+    parse-option:syntax-parse-option ...
+    [splicing-pattern
+     pattern-directive:syntax-parse-pattern-directive ...
+     (splicing-replacement ...)])
 
   ;; These identifiers are macro-introduced, but we use format-id on them anyway so that the expanded
   ;; code is more readable and it's clearer which refactoring rule these syntax classes are derived
@@ -100,9 +103,9 @@
 
     (define-splicing-syntax-class body-matching-id
       #:attributes ([refactored 1])
-      parse-option ...
+      (~@ . parse-option) ...
       (pattern splicing-pattern
-        pattern-directive ...
+        (~@ . pattern-directive) ...
         #:with (refactored (... ...)) #'(splicing-replacement ...)))
 
     (define-syntax-class expression-matching-id