Skip to content

Commit

Permalink
Revert "match: fix hash-table pattern and its doc, add more optimizat…
Browse files Browse the repository at this point in the history 
…ions (racket#4532)"

This reverts commit ef0fb30.

See discussion of PR racket#4532 for discussion of this.
  • Loading branch information
@jbclements
jbclements committed Feb 3, 2023
1 parent fcfc9b2 commit ed0f793
Show file tree
Hide file tree
Showing 5 changed files with 29 additions and 269 deletions.
7 changes: 2 additions & 5 deletions pkgs/racket-doc/scribblings/reference/match-grammar.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,8 +15,8 @@ pat ::= id @match anything, bind identifier
| (LIST-NO-ORDER pat ...) @match pats in any order
| (LIST-NO-ORDER pat ... lvp) @match pats in any order
| (VECTOR lvp ...) @match vector of pats
| (HASH-TABLE kvp ...) @match hash table
| (HASH-TABLE kvp ...+ ooo) @match hash table
| (HASH-TABLE (pat pat) ...) @match hash table
| (HASH-TABLE (pat pat) ...+ ooo) @match hash table
| (CONS pat pat) @match pair of pats
| (MCONS pat pat) @match mutable pair of pats
| (BOX pat) @match boxed pat
Expand All @@ -42,9 +42,6 @@ literal ::= #t @match true
| keyword @match equal% keyword
| regexp literal @match equal% regexp literal
| pregexp literal @match equal% pregexp literal
kvp ::= _ @match any hash table key-value pair
| id @match hash table key-value pair (as a list)
| (pat pat) @match hash table key-value pair
lvp ::= (code:line pat ooo) @greedily match pat instances
| pat @match pat
qp ::= literal @match literal
Expand Down
4 changes: 1 addition & 3 deletions pkgs/racket-doc/scribblings/reference/match-parse.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,8 +29,6 @@
=> (fixup s (fixup-sexp 'qp))]
[(regexp-match-positions #rx"lvp" s)
=> (fixup s (fixup-sexp 'lvp))]
[(regexp-match-positions #rx"kvp" s)
=> (fixup s (fixup-sexp 'kvp))]
[(regexp-match-positions #rx"struct-id" s)
=> (fixup s (fixup-sexp 'struct-id))]
[(regexp-match-positions #rx"pred-expr" s)
Expand Down Expand Up @@ -66,7 +64,7 @@
(cdr (map fixup-sexp (vector->list (struct->vector s)))))]
[(symbol? s)
(case s
[(lvp kvp pat qp literal ooo datum struct-id
[(lvp pat qp literal ooo datum struct-id
string bytes number character expr id
rx-expr px-expr pred-expr
derived-pattern)
Expand Down
11 changes: 2 additions & 9 deletions pkgs/racket-doc/scribblings/reference/match.scrbl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -223,29 +223,22 @@ In more detail, patterns match as follows:
[(vector 1 (list a) ..3 5) a])
]}

@item{@racket[(#,(match-kw "hash-table") _kvp ...)] ---
@item{@racket[(#,(match-kw "hash-table") (_pat _pat) ...)] ---
similar to @racketidfont{list-no-order}, but matching against
hash table's key--value pairs.

@examples[
#:eval match-eval
(match #hash(("a" . 1) ("b" . 2))
[(hash-table ("b" b) ("a" a)) (list b a)])
(match #hash(("a" . 1) ("b" . 2) ("c" . 3))
[(hash-table ("c" _) ("b" _) x) x])
(match #hash(("a" . 1) ("b" . 2))
[(hash-table ("b" b)) "not matched"]
[(hash-table ("b" b) _) "matched"])
]}

@item{@racket[(#,(racketidfont "hash-table") _kvp ...+ _ooo)]
@item{@racket[(#,(racketidfont "hash-table") (_pat _pat) ...+ _ooo)]
--- Generalizes @racketidfont{hash-table} to support a final
repeating pattern.

@examples[
#:eval match-eval
(match #hash(("a" . 1) ("b" . 2))
[(hash-table ("b" b) _ ...) b])
(match #hash(("a" . 1) ("b" . 2))
[(hash-table (key val) ...) key])
]}
Expand Down
177 changes: 2 additions & 175 deletions pkgs/racket-test/tests/match/match-tests.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,178 +51,7 @@
[_ "non-empty"])
"empty"))
))

(define hash-table-no-rep-tests
(test-suite "hash-table patterns (no ..k)"
(test-case "literal keys"
(check-equal? (match (hash 1 2 3 4)
[(hash-table (1 a) (3 b))
(list a b)])
'(2 4))

(check-equal? (match (hash 'a 'b 'c 'd)
[(hash-table ('c x) ('a y))
(list x y)])
'(d b))

(check-true (match (hash)
[(hash-table) #t]))

(check-equal? (match (hash "a" "b" "c" "d" "e" "f")
[(hash-table ("e" x) ("a" "b") ("c" y))
(list x y)])
'("f" "d")))

(test-case "literal keys predicate"
(check-equal? (match (hash 'a 'b 'c 'd)
[(hash-table ('a x)) 1]
[(hash-table ('a x) ('c y)) 2])
2)

(check-equal? (match (hash 1 2 3 4)
[(hash-table) 1]
[(hash-table (1 a)) 2]
[(hash-table (2 a)) 3]
[(hash-table (1 a) (3 b) (5 c)) 4]
[(hash-table (1 a) (2 b)) 5]
[(hash-table (1 10) (3 b)) 6]
[(hash-table (1 a) (3 b)) 7]
[(hash-table (1 a) (3 4)) 8])
7)

;; Duplicate keys
(check-equal? (match (hash "a" "b" "c" "d")
[(hash-table ("a" x) ("a" y))
(list x y)]
[(hash-table _ _) 42])
42))

(test-case "non literal keys"
(check-equal? (match (hash (list 1 2) 'b (list 3 4) 'd)
[(hash-table ((list 1 2) x) ((list 3 4) y)) (list x y)])
'(b d))

(check-equal? (match (hash (list 1 2) 'b (list 3 4) 'd)
[(hash-table (c d) (a 'b)) (list a c d)])
'((1 2) (3 4) d))

(check-equal? (match (hash (list 1 2) 'b (list 3 4) 'd)
[(hash-table p (a 'b)) (list a p)])
'((1 2) ((3 4) d)))

(check-equal? (match (hash (list 1 2) 'x (list 3 4) 'x)
[(hash-table _ q) (cadr q)])
'x))

(test-case "non literal keys predicate"
(check-equal? (match (hash (list 1 2) 'b (list 3 4) 'd)
[(hash-table) 1]
[(hash-table a) 2]
[(hash-table a b c) 3]
[(hash-table a b) 4]
[(hash-table (p 'd) _) p])
4)

(check-equal? (match (hash (list 1 2) 'b (list 3 4) 'd)
[(hash-table) 1]
[(hash-table a) 2]
[(hash-table a b c) 3]
[(hash-table (p 'd) _) p]
[(hash-table a b) 4])
(list 3 4)))))

(define hash-table-rep-tests
(test-suite "hash-table patterns (with ..k)"
(test-case "literal keys"
(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 b) (5 c) (1 a) _ ...)
(list a b c)])
'(2 4 6))

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 a) (5 b) _ ...)
(list a b)])
'(4 6))

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 a) (5 b) (_ _) ...)
(list a b)])
'(4 6))

;; Duplicate keys are fine
(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 a) (3 b) _ ...)
(list a b)])
'(4 4))

(check-true (match (hash 1 2 3 4 5 6)
[(hash-table _ ...) #t]))

(check-true (match (hash 1 2 3 4 5 6)
[(hash-table (1 2) _ ...) #t])))

(test-case "literal keys predicate"
(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 42) (5 b) _ ...) #f]
[(hash-table (5 b) _ ...) b])
6)

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (1 _) (3 _) (5 _) (7 _) _ ...) #f]
[(hash-table (2 _) _ ...) #f]
[(hash-table (5 b) _ ...) b])
6))

(test-case "non literal keys"
(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (3 42) (5 b) _ ...) #f]
[(hash-table (5 b) _ ...) b])
6)

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (a 2) _ ...) a])
1)

(check-true (match (hash 1 2 3 4)
[(hash-table p _ _ ...) #t]))


(check-equal? (match (hash 1 2 3 4)
[(hash-table (1 x) _ ...) x])
2)

(check-equal? (match (hash 1 2 3 4)
[(hash-table (1 x) _ ..0) x])
2)

(check-equal? (match (hash 1 2 3 4)
[(hash-table (1 x) _ ..1) x])
2)

(check-equal? (match (hash 1 2 3 4)
[(hash-table (1 x) p ...) p])
(list (list 3 4)))

(check-equal? (match (hash 1 2)
[(hash-table (1 x) p ...) p])
'()))

(test-case "non literal keys predicate"
(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table _ ..4) 1]
[(hash-table _ ..3) 2])
2)

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table a b c d _ ...) 1]
[(hash-table a b c _ ...) 2])
2)

(check-equal? (match (hash 1 2 3 4 5 6)
[(hash-table (_ 10) b c _ ...) 1]
[(hash-table a b c _ ...) 2])
2))))


(define nonlinear-tests
(test-suite
"Non-linear patterns"
Expand Down Expand Up @@ -306,7 +135,5 @@
doc-tests
simple-tests
nonlinear-tests
match-expander-tests
hash-table-no-rep-tests
hash-table-rep-tests))
match-expander-tests))
)
99 changes: 22 additions & 77 deletions racket/collects/racket/match/parse.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,52 +52,6 @@
(rest suffix)
(if (eq? ddk-size #t) 0 ddk-size)))

;; ht-trans-fallback :: syntax? stx-list? (or/c #f cons?)
(define (ht-trans-fallback stx ps dd)
(trans-match
#'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...) (map ht-pat-transform (syntax->list ps))])
(parse (quasisyntax/loc stx
(list-no-order elems ...
#,@(if dd
(list (ht-pat-transform (car dd)) (cdr dd))
'())))))))

(define default-val (gensym))

;; ht-trans :: syntax? stx-list? (or/c #f cons?)
;; precondition: dd's car is either #'_ or #'(_ _) and
;; dd's cdr is either #'... or #'..0
(define (ht-trans stx ps dd)
;; do-literal-keys :: list? list? stx-list?
(define (do-literal-keys keys preds vs)
(trans-match*
(append (list #'hash?)
preds
(for/list ([k (in-list keys)]) (λ (e) #`(hash-has-key? #,e '#,k))))
(for/list ([k (in-list keys)]) (λ (e) #`(hash-ref #,e '#,k)))
(map parse (syntax->list vs))))

(syntax-case ps ()
[((k v) ...)
(andmap (λ (p) (and (literal-pat? p) (not (identifier? p)))) (syntax->list #'(k ...)))
(let ([keys (map Exact-v (map literal-pat? (syntax->list #'(k ...))))])
(define preds
(cond
[dd '()]
[else (list (λ (e) #`(= (hash-count #,e) #,(length keys))))]))
(cond
;; There's a dd
[dd
(do-literal-keys keys preds #'(v ...))]
;; There is no dd and there is no duplicate.
[(eq? default-val (check-duplicates keys #:default default-val))
(do-literal-keys keys preds #'(v ...))]
;; There is no dd, but there is a duplicate
[else (ht-trans-fallback stx ps dd)]))]
[_ (ht-trans-fallback stx ps dd)]))

;; parse : syntax -> Pat
;; compile stx into a pattern, using the new syntax
(define (parse stx)
Expand Down Expand Up @@ -168,46 +122,37 @@
(rearm+parse (syntax/loc stx (list es ...))))]
[(vector es ...)
(Vector (map rearm+parse (syntax->list #'(es ...))))]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HASH TABLE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; x ..k is used and k >= 1; use the fallback method
[(hash-table p ... x dd)
(let ([ddk-size (ddk? #'dd)]) (and (number? ddk-size) (>= ddk-size 1)))
(ht-trans-fallback stx #'(p ...) (cons #'x #'dd))]

;; _ ..0
[(hash-table p ... x dd)
(and (ddk? #'dd) (underscore? #'x))
(ht-trans stx #'(p ...) (cons #'x #'dd))]

;; (_ _) ..0
[(hash-table p ... (x y) dd)
(and (ddk? #'dd) (underscore? #'x) (underscore? #'y))
(ht-trans stx #'(p ...) (cons #'(x y) #'dd))]

;; x ..0; use the fallback method
[(hash-table p ... x dd)
[(hash-table p ... dd)
(ddk? #'dd)
(ht-trans-fallback stx #'(p ...) (cons #'x #'dd))]

;; malformed ..k
(trans-match
#'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform (syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ... dd)))))]
[(hash-table p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
'match "dot dot k can only appear at the end of hash-table patterns" stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]

;; ..k is not used
[(hash-table (k0 v0) (k1 v1) ...)
(andmap (λ (p) (and (literal-pat? p) (not (identifier? p)))) (syntax->list #'(k0 k1 ...)))
(with-syntax ([(k ...) #'(k0 k1 ...)]
[(v ...) #'(v0 v1 ...)])
(let ([keys (map Exact-v (map literal-pat? (syntax->list #'(k ...))))])
(trans-match*
(cons #'hash? (for/list ([k (in-list keys)]) (λ (e) #`(hash-has-key? #,e '#,k))))
(for/list ([k (in-list keys)]) (λ (e) #`(hash-ref #,e '#,k)))
(map parse (syntax->list #'(v ...))))))]
[(hash-table p ...)
(ht-trans stx #'(p ...) #f)]

;; malformed hash-table
(trans-match #'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform
(syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ...)))))]
[(hash-table . _)
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]

[(list-no-order p ... lp dd)
(ddk? #'dd)
(let* ([count (ddk? #'dd)]
Expand Down

0 comments on commit ed0f793

Please sign in to comment.