From 3984a2c22a4af8f10c1ef0fa82e57afae85752cc Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 10 Jun 2021 13:32:39 +0200 Subject: [PATCH] Correct generation of patterns for literal embedded-values --- syndicate/pattern.rkt | 150 ++++++++++++++++++---------------- syndicate/schema-compiler.rkt | 2 + 2 files changed, 83 insertions(+), 69 deletions(-) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index df1ef16..23dee46 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -92,12 +92,6 @@ (define (constructor-registered? stx) (free-id-table-ref preserves-pattern-registry stx #f)) - (define (member-entry key-stx pat-stx) - (define analysed (analyse-pattern pat-stx)) - (syntax-case analysed (Pattern-DDiscard DDiscard) - [(Pattern-DDiscard (DDiscard)) (list)] - [_ (list key-stx analysed)])) - (define (struct-label-and-arity id-stx actual-count) (match-define (list _type-stx ctor-stx pred-stx accessor-stxs _mutator-stxs _super) (extract-struct-info (id-value id-stx))) @@ -117,68 +111,80 @@ [(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")] [(list* k v more) (append (f k v) (append-map-pairs f more))])) - (define (analyse-pattern stx) - (define disarmed-stx (syntax-disarm stx orig-insp)) - (syntax-case disarmed-stx ($ quasiquote unquote quote) - [(ctor args ...) - (constructor-registered? #'ctor) - ((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx)] + (define (analyse-pattern stx + [check-destructuring (lambda (stx) stx)] + [wrap-literal (lambda (stx) stx)]) + (define (member-entry key-stx pat-stx) + (define analysed (analyse-pattern pat-stx check-destructuring wrap-literal)) + (syntax-case analysed (Pattern-DDiscard DDiscard) + [(Pattern-DDiscard (DDiscard)) (list)] + [_ (list key-stx analysed)])) + (let walk ((stx stx)) + (define disarmed-stx (syntax-disarm stx orig-insp)) + (syntax-case disarmed-stx ($ quasiquote unquote quote) + [(ctor args ...) + (constructor-registered? #'ctor) + (check-destructuring + ((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx))] - [(expander args ...) - (pattern-expander-id? #'expander) - (pattern-expander-transform disarmed-stx - (lambda (result) - (analyse-pattern (syntax-rearm result stx))))] + [(expander args ...) + (pattern-expander-id? #'expander) + (pattern-expander-transform disarmed-stx + (lambda (result) + (walk (syntax-rearm result stx))))] - ;; Extremely limited support for quasiquoting and quoting - [(quasiquote (unquote p)) (analyse-pattern #'p)] - [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))] - [(quasiquote p) #`(Pattern-DLit (DLit 'p))] - [(quote p) #`(Pattern-DLit (DLit 'p))] + ;; Extremely limited support for quasiquoting and quoting + [(quasiquote (unquote p)) (walk #'p)] + [(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))] + [(quasiquote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))] + [(quote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))] - [(unquote p) #'p] + [(unquote p) #'p] - [(ctor piece ...) - (struct-info? (id-value #'ctor)) - (let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...)))))) - #`(Pattern-DCompound - (DCompound-rec (CRec '#,label #,arity) - (hasheqv #,@(append* - (for/list [(n (in-naturals)) - (piece (in-list (syntax->list #'(piece ...))))] - (member-entry n piece)))))))] + [(ctor piece ...) + (struct-info? (id-value #'ctor)) + (let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...)))))) + (check-destructuring + #`(Pattern-DCompound + (DCompound-rec (CRec '#,label #,arity) + (hasheqv #,@(append* + (for/list [(n (in-naturals)) + (piece (in-list (syntax->list #'(piece ...))))] + (member-entry n piece))))))))] - [(list-stx piece ...) - (list-id? #'list-stx) - #`(Pattern-DCompound - (DCompound-arr (CArr #,(length (syntax->list #'(piece ...)))) - (hasheqv #,@(append* - (for/list [(n (in-naturals)) - (piece (in-list (syntax->list #'(piece ...))))] - (member-entry n piece))))))] + [(list-stx piece ...) + (list-id? #'list-stx) + (check-destructuring + #`(Pattern-DCompound + (DCompound-arr (CArr #,(length (syntax->list #'(piece ...)))) + (hasheqv #,@(append* + (for/list [(n (in-naturals)) + (piece (in-list (syntax->list #'(piece ...))))] + (member-entry n piece)))))))] - [(hash-stx piece ...) - (hash-or-hasheqv-id? #'hash-stx) - #`(Pattern-DCompound - (DCompound-dict (CDict) - (hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...))))))] + [(hash-stx piece ...) + (hash-or-hasheqv-id? #'hash-stx) + (check-destructuring + #`(Pattern-DCompound + (DCompound-dict (CDict) + (hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...)))))))] - [id - (dollar-id? #'id) - #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))] + [id + (dollar-id? #'id) + #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))] - [($ (unquote bp) p) - #`(Pattern-DBind (DBind bp #,(analyse-pattern #'p)))] + [($ (unquote bp) p) + #`(Pattern-DBind (DBind bp #,(walk #'p)))] - [($ id p) - #`(Pattern-DBind (DBind 'id #,(analyse-pattern #'p)))] + [($ id p) + #`(Pattern-DBind (DBind 'id #,(walk #'p)))] - [id - (discard-id? #'id) - #`(Pattern-DDiscard (DDiscard))] + [id + (discard-id? #'id) + #`(Pattern-DDiscard (DDiscard))] - [other - #`(Pattern-DLit (DLit other))])) + [other + #`(Pattern-DLit (DLit #,(wrap-literal #'other)))]))) (define (analyse-pattern-bindings stx) (let walk ((stx stx)) @@ -223,22 +229,28 @@ '()] [other - '()])))) + '()]))) + + (define (expand-:pattern stx) + (syntax-case stx () + [(_ pat-stx atomic-literal-transformer) + (analyse-pattern #'pat-stx + (lambda (stx) (raise-syntax-error #f "Attempt to destructure known-atomic")) + (lambda (stx) #`(atomic-literal-transformer #,stx)))] + [(_ pat-stx) + (analyse-pattern #'pat-stx)]))) (define-pattern-expander :pattern (lambda (stx) - (syntax-case stx () - [(_ pat-stx) - ;; This effectively quasiquotes the pattern; a naked unquote in - ;; the pattern returns to the "outer" context. This is useful - ;; for observing observers: - ;; - ;; (Observe (:pattern (some-pattern ...)) _) - (analyse-pattern #'pat-stx)])) + ;; This effectively quasiquotes the pattern; a naked unquote in + ;; the pattern returns to the "outer" context. This is useful for + ;; observing observers: + ;; + ;; (Observe (:pattern (some-pattern ...)) _) + ;; + (expand-:pattern stx)) (lambda (stx) - (syntax-case stx () - [(_ pat-stx) - (analyse-pattern #'pat-stx)]))) + (expand-:pattern stx))) ;;--------------------------------------------------------------------------- diff --git a/syndicate/schema-compiler.rkt b/syndicate/schema-compiler.rkt index 69f6d48..a5e5bfb 100644 --- a/syndicate/schema-compiler.rkt +++ b/syndicate/schema-compiler.rkt @@ -67,6 +67,8 @@ (define (pat-pattern p) (match (unwrap p) + [(NamedSimplePattern_ name (SimplePattern-embedded _)) + `(:pattern ,(escape name) embedded)] [(NamedSimplePattern_ name p) `(:pattern ,(escape name))] [(SimplePattern-any) discard]