diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index 73fcc92..7b0bc60 100644 --- a/syndicate/pattern.rkt +++ b/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)))) diff --git a/syndicate/schema-compiler.rkt b/syndicate/schema-compiler.rkt index 4b7c462..ce7ba77 100644 --- a/syndicate/schema-compiler.rkt +++ b/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)) diff --git a/syndicate/schemas/dataspace-patterns.prs b/syndicate/schemas/dataspace-patterns.prs index 2740763..bfba3ad 100644 --- a/syndicate/schemas/dataspace-patterns.prs +++ b/syndicate/schemas/dataspace-patterns.prs @@ -6,6 +6,10 @@ Pattern = DDiscard / DBind / DLit / DCompound . DDiscard = <_>. DBind = . DLit = . -DCompound = @rec @members { int: Pattern ...:... }> - / @arr @members { int: Pattern ...:... }> - / @dict @members { any: Pattern ...:... }> . +DCompound = @rec + / @arr + / @dict . + +CRec = . +CArr = . +CDict = .