Pattern decomposition

syndicate/pattern.rkt

@@ -6,7 +6,14 @@
                      analyse-pattern-bindings)
          define-preserves-pattern
          :pattern
-         :template)
+         :template
+
+         pattern->constant-values
+         pattern->constant-paths
+         pattern->capture-paths
+         pattern->capture-names
+
+         (all-from-out "schemas/gen/dataspace-patterns.rkt"))
 
 (require (for-syntax racket/base))
 (require (for-syntax racket/match))
@@ -16,6 +23,8 @@
 (require (for-syntax syntax/id-table))
 (require (for-syntax syntax/stx))
 
+(require racket/match)
+(require racket/list)
 (require "pattern-expander.rkt")
 (require "schemas/gen/dataspace-patterns.rkt")
 
@@ -120,8 +129,7 @@
        (struct-info? (id-value #'ctor))
        (let-values (((label arity) (struct-label-and-arity #'ctor)))
          #`(Pattern-DCompound
-            (DCompound-rec '#,label
-                           #,arity
+            (DCompound-rec (CRec '#,label #,arity)
                            (hasheqv #,@(append*
                                         (for/list [(n (in-naturals))
                                                    (piece (in-list (syntax->list #'(piece ...))))]
@@ -130,7 +138,7 @@
       [(list-stx piece ...)
        (list-id? #'list-stx)
        #`(Pattern-DCompound
-          (DCompound-arr #,(length (syntax->list #'(piece ...)))
+          (DCompound-arr (CArr #,(length (syntax->list #'(piece ...))))
                          (hasheqv #,@(append*
                                       (for/list [(n (in-naturals))
                                                  (piece (in-list (syntax->list #'(piece ...))))]
@@ -228,3 +236,40 @@
   (syntax-case stx ()
     [(_ template-stx)
      (analyse-template #'template-stx)]))
+
+;;---------------------------------------------------------------------------
+
+(define (select-pattern-leaves desc capture-fn lit-fn)
+  (let walk-node ((key-rev '()) (desc desc))
+    (match desc
+      [(Pattern-DCompound (or (DCompound-rec _ members)
+                              (DCompound-arr _ members)
+                              (DCompound-dict _ members)))
+       (append* (for/list [((key subdesc) (in-hash members))]
+                  (walk-node (cons key key-rev) subdesc)))]
+      [(Pattern-DBind (DBind name subdesc))
+       (append (capture-fn key-rev name) (walk-node key-rev subdesc))]
+      [(Pattern-DDiscard (DDiscard))
+       '()]
+      [(Pattern-DLit (DLit value))
+       (lit-fn key-rev value)])))
+
+(define (pattern->constant-values desc)
+  (select-pattern-leaves desc
+                         (lambda (key-rev name-stx) (list))
+                         (lambda (key-rev value) (list value))))
+
+(define (pattern->constant-paths desc)
+  (select-pattern-leaves desc
+                         (lambda (key-rev name-stx) (list))
+                         (lambda (key-rev value) (list (reverse key-rev)))))
+
+(define (pattern->capture-paths desc)
+  (select-pattern-leaves desc
+                         (lambda (key-rev name-stx) (list (reverse key-rev)))
+                         (lambda (key-rev value) (list))))
+
+(define (pattern->capture-names desc)
+  (select-pattern-leaves desc
+                         (lambda (key-rev name-stx) (list name-stx))
+                         (lambda (key-rev value) (list))))

syndicate/schema-compiler.rkt

@@ -45,46 +45,54 @@
            [((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
             `(,(N 'Pattern-DCompound)
               (,(N 'DCompound-rec)
-               ',label
-               ,(length field-pats)
+               (,(N 'CRec) ',label ,(length field-pats))
                (hasheqv ,@(append* (for/list [(i (in-naturals))
                                               (p (in-list field-pats))]
                                      (define s (pat-pattern p))
-                                     (if (equal? s discard)
-                                         `()
-                                         `(,i ,s)))))))]
+                                     (if (equal? s discard) `() `(,i ,s)))))))]
            [(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
         [(CompoundPattern-tuple pats)
          `(,(N 'Pattern-DCompound)
            (,(N 'DCompound-arr)
-            ,(length pats)
+            (,(N 'CArr) ,(length pats))
             (hasheqv ,@(append* (for/list [(i (in-naturals))
                                            (p (in-list pats))]
                                   (define s (pat-pattern p))
-                                  (if (equal? s discard)
-                                      `()
-                                      `(,i ,p)))))))]
+                                  (if (equal? s discard) `() `(,i ,p)))))))]
+        [(CompoundPattern-tuple* fixed-pats variable-pat)
+         `#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
+        [(CompoundPattern-dict entries)
+         `(,(N 'Pattern-DCompound)
+           (,(N 'DCompound-dict)
+            (,(N 'CDict))
+            (hash ,@(append* (for/list [((k p) (in-hash entries))]
+                               (define s (pat-pattern p))
+                               (if (equal? s discard) `() `(',k ,s)))))))]
         [other (error 'pat-pattern "Unimplemented: ~v" other)]))
 
-    (define fields (match (definition-ty def)
-                     [(ty-unit) '()]
-                     [(ty-record fields) (map escape (map car fields))]
-                     [_ #f]))
+    (define (top-pat name p ty k-nonrecord)
+      (let ((fields (match ty
+                      [(ty-unit) '()]
+                      [(ty-record fields) (map escape (map car fields))]
+                      [_ #f])))
+        (if (not fields)
+            (k-nonrecord)
+            `(define-preserves-pattern (,name ,@fields)
+               (quasisyntax ,(pat-pattern p))
+               (append ,@(for/list [(f (in-list fields))]
+                           `(analyse-pattern-bindings (syntax ,f))))))))
 
-    (if (not fields)
-        `(begin)
-        `(define-preserves-pattern (,name ,@fields)
-           ,@(match def
-               [(? Definition-or?)
-                `((raise-syntax-error ',name "Union schema cannot be used as a pattern")
-                  (quasisyntax ()))]
-               [(? Definition-and?)
-                `((raise-syntax-error ',name "Intersection schema cannot be used as a pattern")
-                  (quasisyntax ()))]
-               [(Definition-Pattern p)
-                `((quasisyntax ,(pat-pattern p))
-                  (append ,@(for/list [(f (in-list fields))]
-                              `(analyse-pattern-bindings (syntax ,f)))))]))))
+    (match def
+      [(Definition-or p0 p1 pN)
+       `(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
+                            (alt-ty (in-list (map cadr (ty-union-variants (definition-ty def)))))]
+                   (match-define (NamedAlternative variant-label-str pattern) named-alt)
+                   (top-pat (format-symbol "~a-~a" name variant-label-str) pattern alt-ty
+                            (lambda () `(begin)))))]
+      [(? Definition-and?)
+       `(begin)]
+      [(Definition-Pattern p)
+       (top-pat name p (definition-ty def) (lambda () `(begin)))]))
 
   (define exprs
     `((require (prefix-in :pat: ,ds-path))

syndicate/schemas/dataspace-patterns.prs

@@ -6,6 +6,10 @@ Pattern = DDiscard / DBind / DLit / DCompound .
 DDiscard = <_>.
 DBind = <bind @name symbol @pattern Pattern>.
 DLit = <lit @value any>.
-DCompound = @rec  <compound <rec @label any @arity int> @members { int: Pattern ...:... }>
-          / @arr  <compound <arr @arity int>            @members { int: Pattern ...:... }>
-          / @dict <compound <dict>                      @members { any: Pattern ...:... }> .
+DCompound = @rec  <compound @ctor CRec  @members { int: Pattern ...:... }>
+          / @arr  <compound @ctor CArr  @members { int: Pattern ...:... }>
+          / @dict <compound @ctor CDict @members { any: Pattern ...:... }> .
+
+CRec = <rec @label any @arity int>.
+CArr = <arr @arity int>.
+CDict = <dict>.