Correct generation of patterns for literal embedded-values
This commit is contained in:
parent
7790923e65
commit
3984a2c22a
|
|
@ -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)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in New Issue