suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Handle quasi-list patterns better inside prefab struct patterns.

Browse Source 
Reported by William Bowman.
This commit is contained in:
Sam Tobin-Hochstadt 2016-11-09 19:46:03 -05:00
parent 81fa8c403d
commit 3b9354f16b
2 changed files with 24 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-test/tests/match/examples.rkt
View File

@ -747,6 +747,12 @@
[(cons a b) #:when (= a b) 1]
[_ 0]))
(test-case "prefab structs and list-rest"
(match #s(meow 1)
[`#s(meow ,@(list-rest a))
a])
(list 1))
(test-case
"robby's slow example"
(define v

28
racket/collects/racket/match/parse-quasi.rkt
View File

@ -25,12 +25,22 @@
[(Null? p1) p2]
[else (error 'match "illegal input to append-pats")]))
(define hard-case?
(lambda (p)
(or (ddk? p)
(syntax-case p (unquote-splicing)
[(unquote-splicing . _) #t]
[_ #f]))))
;; parse stx as a quasi-pattern
;; parse parses unquote
(define (parse-quasi stx parse)
(define (pq s) (parse-quasi s parse))
(syntax-case stx (quasiquote unquote quote unquote-splicing)
[(unquote p) (parse #'p)]
[((unquote-splicing p))
(let ([pat (parameterize ([in-splicing? #t]) (parse #'p))])
pat)]
[((unquote-splicing p) . rest)
(let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
[rpat (pq #'rest)])
@ -60,18 +70,16 @@
(let ([key (prefab-struct-key (syntax-e #'struct))]
[pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
(make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
(make-App #'struct->vector
(list (make-Vector (cons (make-Dummy #f) (map pq pats)))))))
#;
(make-PrefabStruct key (map pq pats)))]
(if (ormap hard-case? pats)
;; hard cases
(make-App #'(λ (v) (vector->list (struct->vector v)))
(list (make-Pair (make-Dummy #f) (pq pats))))
;; no hard cases, avoid creating a list
(make-App #'struct->vector
(list (make-Vector (cons (make-Dummy #f) (map pq pats)))))))))]
;; the hard cases
[#(p ...)
(ormap (lambda (p)
(or (ddk? p)
(syntax-case p (unquote-splicing)
[(unquote-splicing . _) #t]
[_ #f])))
(syntax->list #'(p ...)))
(ormap hard-case? (syntax->list #'(p ...)))
(make-And (list (make-Pred #'vector?)
(make-App #'vector->list
(list (pq (quasisyntax/loc stx (p ...)))))))]