Pattern decomposition
This commit is contained in:
parent
044860a3b5
commit
6fe14e09a5
|
@ -6,7 +6,14 @@
|
||||||
analyse-pattern-bindings)
|
analyse-pattern-bindings)
|
||||||
define-preserves-pattern
|
define-preserves-pattern
|
||||||
: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/base))
|
||||||
(require (for-syntax racket/match))
|
(require (for-syntax racket/match))
|
||||||
|
@ -16,6 +23,8 @@
|
||||||
(require (for-syntax syntax/id-table))
|
(require (for-syntax syntax/id-table))
|
||||||
(require (for-syntax syntax/stx))
|
(require (for-syntax syntax/stx))
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require racket/list)
|
||||||
(require "pattern-expander.rkt")
|
(require "pattern-expander.rkt")
|
||||||
(require "schemas/gen/dataspace-patterns.rkt")
|
(require "schemas/gen/dataspace-patterns.rkt")
|
||||||
|
|
||||||
|
@ -120,8 +129,7 @@
|
||||||
(struct-info? (id-value #'ctor))
|
(struct-info? (id-value #'ctor))
|
||||||
(let-values (((label arity) (struct-label-and-arity #'ctor)))
|
(let-values (((label arity) (struct-label-and-arity #'ctor)))
|
||||||
#`(Pattern-DCompound
|
#`(Pattern-DCompound
|
||||||
(DCompound-rec '#,label
|
(DCompound-rec (CRec '#,label #,arity)
|
||||||
#,arity
|
|
||||||
(hasheqv #,@(append*
|
(hasheqv #,@(append*
|
||||||
(for/list [(n (in-naturals))
|
(for/list [(n (in-naturals))
|
||||||
(piece (in-list (syntax->list #'(piece ...))))]
|
(piece (in-list (syntax->list #'(piece ...))))]
|
||||||
|
@ -130,7 +138,7 @@
|
||||||
[(list-stx piece ...)
|
[(list-stx piece ...)
|
||||||
(list-id? #'list-stx)
|
(list-id? #'list-stx)
|
||||||
#`(Pattern-DCompound
|
#`(Pattern-DCompound
|
||||||
(DCompound-arr #,(length (syntax->list #'(piece ...)))
|
(DCompound-arr (CArr #,(length (syntax->list #'(piece ...))))
|
||||||
(hasheqv #,@(append*
|
(hasheqv #,@(append*
|
||||||
(for/list [(n (in-naturals))
|
(for/list [(n (in-naturals))
|
||||||
(piece (in-list (syntax->list #'(piece ...))))]
|
(piece (in-list (syntax->list #'(piece ...))))]
|
||||||
|
@ -228,3 +236,40 @@
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ template-stx)
|
[(_ template-stx)
|
||||||
(analyse-template #'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))))
|
||||||
|
|
|
@ -45,46 +45,54 @@
|
||||||
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
||||||
`(,(N 'Pattern-DCompound)
|
`(,(N 'Pattern-DCompound)
|
||||||
(,(N 'DCompound-rec)
|
(,(N 'DCompound-rec)
|
||||||
',label
|
(,(N 'CRec) ',label ,(length field-pats))
|
||||||
,(length field-pats)
|
|
||||||
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||||
(p (in-list field-pats))]
|
(p (in-list field-pats))]
|
||||||
(define s (pat-pattern p))
|
(define s (pat-pattern p))
|
||||||
(if (equal? s discard)
|
(if (equal? s discard) `() `(,i ,s)))))))]
|
||||||
`()
|
|
||||||
`(,i ,s)))))))]
|
|
||||||
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
||||||
[(CompoundPattern-tuple pats)
|
[(CompoundPattern-tuple pats)
|
||||||
`(,(N 'Pattern-DCompound)
|
`(,(N 'Pattern-DCompound)
|
||||||
(,(N 'DCompound-arr)
|
(,(N 'DCompound-arr)
|
||||||
,(length pats)
|
(,(N 'CArr) ,(length pats))
|
||||||
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||||
(p (in-list pats))]
|
(p (in-list pats))]
|
||||||
(define s (pat-pattern p))
|
(define s (pat-pattern p))
|
||||||
(if (equal? s discard)
|
(if (equal? s discard) `() `(,i ,p)))))))]
|
||||||
`()
|
[(CompoundPattern-tuple* fixed-pats variable-pat)
|
||||||
`(,i ,p)))))))]
|
`#,(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)]))
|
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
||||||
|
|
||||||
(define fields (match (definition-ty def)
|
(define (top-pat name p ty k-nonrecord)
|
||||||
|
(let ((fields (match ty
|
||||||
[(ty-unit) '()]
|
[(ty-unit) '()]
|
||||||
[(ty-record fields) (map escape (map car fields))]
|
[(ty-record fields) (map escape (map car fields))]
|
||||||
[_ #f]))
|
[_ #f])))
|
||||||
|
|
||||||
(if (not fields)
|
(if (not fields)
|
||||||
`(begin)
|
(k-nonrecord)
|
||||||
`(define-preserves-pattern (,name ,@fields)
|
`(define-preserves-pattern (,name ,@fields)
|
||||||
,@(match def
|
(quasisyntax ,(pat-pattern p))
|
||||||
[(? 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))]
|
(append ,@(for/list [(f (in-list fields))]
|
||||||
`(analyse-pattern-bindings (syntax ,f)))))]))))
|
`(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
|
(define exprs
|
||||||
`((require (prefix-in :pat: ,ds-path))
|
`((require (prefix-in :pat: ,ds-path))
|
||||||
|
|
|
@ -6,6 +6,10 @@ Pattern = DDiscard / DBind / DLit / DCompound .
|
||||||
DDiscard = <_>.
|
DDiscard = <_>.
|
||||||
DBind = <bind @name symbol @pattern Pattern>.
|
DBind = <bind @name symbol @pattern Pattern>.
|
||||||
DLit = <lit @value any>.
|
DLit = <lit @value any>.
|
||||||
DCompound = @rec <compound <rec @label any @arity int> @members { int: Pattern ...:... }>
|
DCompound = @rec <compound @ctor CRec @members { int: Pattern ...:... }>
|
||||||
/ @arr <compound <arr @arity int> @members { int: Pattern ...:... }>
|
/ @arr <compound @ctor CArr @members { int: Pattern ...:... }>
|
||||||
/ @dict <compound <dict> @members { any: Pattern ...:... }> .
|
/ @dict <compound @ctor CDict @members { any: Pattern ...:... }> .
|
||||||
|
|
||||||
|
CRec = <rec @label any @arity int>.
|
||||||
|
CArr = <arr @arity int>.
|
||||||
|
CDict = <dict>.
|
||||||
|
|
Loading…
Reference in New Issue