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

Add OrderedAnd patterns, and use them in ? patterns.

Browse Source 
This guarantees that patterns like (? pred pat) will
always check `pred` before matching any of `pat`.
However, `and` patterns are not required to match left-
to-right.
This commit is contained in:
Sam Tobin-Hochstadt 2013-01-22 14:48:49 -05:00
parent bcec8bc26e
commit 40d2fd65b0
5 changed files with 50 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/racket/match/compiler.rkt
View File

@ -249,20 +249,22 @@
esc))))]
;; the And rule
[(And? first)
;; we only handle 1-row Ands atm - this is all the mixture rule should
;; give us
;; we only handle 1-row Ands
;; this is all the mixture rule should give us
(unless (null? (cdr block))
(error 'compile-one "And block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
;; all the patterns
[qs (And-ps (car pats))])
(compile* (append (map (lambda _ x) qs) xs)
(list (make-Row (append qs (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc))]
(define row (car block))
(define pats (Row-pats row))
;; all the patterns
(define qs (And-ps (car pats)))
(compile* (append (map (lambda _ x) qs) xs)
(list (make-Row (append qs (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc
;; don't re-order OrderedAnd patterns
(not (OrderedAnd? first)))]
;; the Not rule
[(Not? first)
;; we only handle 1-row Nots atm - this is all the mixture rule should
@ -407,7 +409,7 @@
#'failkv)))]
[else (error 'compile "unsupported pattern: ~a\n" first)]))
(define (compile* vars rows esc)
(define (compile* vars rows esc [reorder? #t])
(define (let/wrap clauses body)
(if (stx-null? clauses)
body
@ -447,7 +449,9 @@
;; and compile each block with a reference to its continuation
[else
(let*-values
([(rows vars) (reorder-columns rows vars)]
([(rows vars) (if reorder?
(reorder-columns rows vars)
(values rows vars))]
[(fns)
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
(if (null? blocks)

51
collects/racket/match/parse.rkt
View File

@ -36,23 +36,23 @@
"This expander only works with the legacy match syntax")]
[(var v)
(identifier? #'v)
(make-Var (rearm #'v))]
(Var (rearm #'v))]
[(and p ...)
(make-And (map rearm+parse (syntax->list #'(p ...))))]
(And (map rearm+parse (syntax->list #'(p ...))))]
[(or)
(make-Not (make-Dummy stx))]
(Not (Dummy stx))]
[(or p ps ...)
(let ([ps (map rearm+parse (syntax->list #'(p ps ...)))])
(all-vars ps stx)
(make-Or ps))]
(Or ps))]
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose make-Not rearm+parse) (syntax->list #'(p ...)))])
(make-And ps))]
(let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
(And ps))]
[(regexp r)
(trans-match #'matchable?
(rearm #'(lambda (e) (regexp-match r e)))
(make-Pred #'values))]
(Pred #'values))]
[(regexp r p)
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
[(pregexp r)
@ -60,21 +60,21 @@
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(make-Pred #'values))]
(Pred #'values))]
[(pregexp r p)
(trans-match #'matchable?
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(rearm+parse #'p))]
[(box e) (make-Box (parse #'e))]
[(box e) (Box (parse #'e))]
[(vector es ...)
(ormap ddk? (syntax->list #'(es ...)))
(trans-match #'vector?
#'vector->list
(rearm+parse (syntax/loc stx (list es ...))))]
[(vector es ...)
(make-Vector (map rearm+parse (syntax->list #'(es ...))))]
(Vector (map rearm+parse (syntax->list #'(es ...))))]
[(hash-table p ... dd)
(ddk? #'dd)
(trans-match
@ -103,13 +103,13 @@
[min (if (number? count) count #f)]
[max (if (number? count) count #f)]
[ps (syntax->list #'(p ...))])
(make-GSeq (cons (list (rearm+parse #'lp))
(GSeq (cons (list (rearm+parse #'lp))
(for/list ([p ps]) (list (parse p))))
(cons min (map (lambda _ 1) ps))
(cons max (map (lambda _ 1) ps))
;; vars in lp are lists, vars elsewhere are not
(cons #f (map (lambda _ #t) ps))
(make-Null (make-Dummy (syntax/loc stx _)))
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list-no-order p ...)
(ormap ddk? (syntax->list #'(p ...)))
@ -119,15 +119,15 @@
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(list-no-order p ...)
(let ([ps (syntax->list #'(p ...))])
(make-GSeq (for/list ([p ps]) (list (rearm+parse p)))
(GSeq (for/list ([p ps]) (list (rearm+parse p)))
(map (lambda _ 1) ps)
(map (lambda _ 1) ps)
;; all of these patterns get bound to only one thing
(map (lambda _ #t) ps)
(make-Null (make-Dummy (syntax/loc stx _)))
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list) (make-Null (make-Dummy (syntax/loc stx _)))]
[(mlist) (make-Null (make-Dummy (syntax/loc stx _)))]
[(list) (Null (Dummy (syntax/loc stx _)))]
[(mlist) (Null (Dummy (syntax/loc stx _)))]
[(list ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
@ -141,9 +141,9 @@
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
[(list e es ...)
(make-Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
[(mlist e es ...)
(make-MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist es ...))))]
(MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist es ...))))]
[(list* . rest)
(rearm+parse (syntax/loc stx (list-rest . rest)))]
[(list-rest e)
@ -152,21 +152,22 @@
(ddk? #'dd)
(dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
[(list-rest e . es)
(make-Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (make-Pair (rearm+parse #'e1) (rearm+parse #'e2))]
[(mcons e1 e2) (make-MPair (rearm+parse #'e1) (rearm+parse #'e2))]
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]
[(mcons e1 e2) (MPair (rearm+parse #'e1) (rearm+parse #'e2))]
[(struct s pats)
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(s . pats)
(and (identifier? #'s) (struct-info? (syntax-local-value #'s (lambda () #f))))
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred (rearm #'p))
(map rearm+parse (syntax->list #'(q1 qs ...)))))]
(OrderedAnd
(list (Pred (rearm #'p))
(And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
[(? p)
(make-Pred (rearm #'p))]
(Pred (rearm #'p))]
[(app f p)
(make-App #'f (rearm+parse #'p))]
(App #'f (rearm+parse #'p))]
[(quasiquote p)
(parse-quasi #'p rearm+parse)]
[(quasiquote . _)

1
collects/racket/match/patterns.rkt
View File

@ -69,6 +69,7 @@
;; ps are patterns
(define-struct (Or Pat) (ps) #:transparent)
(define-struct (And Pat) (ps) #:transparent)
(define-struct (OrderedAnd And) () #:transparent)
;; p is a pattern
(define-struct (Not Pat) (p) #:transparent)

3
collects/racket/match/reorder.rkt
View File

@ -51,8 +51,7 @@
(ormap (lambda (p) (andmap p l)) ps))
(define (count-while pred l)
(let loop ([l l] [r 0])
(if (or (null? l) (not (pred (car l)))) r (loop (cdr l) (add1 r)))))
(for/sum ([e (in-list l)] #:break (not (pred e))) 1))
(define (score col)
(define n (length col))

6
collects/scribblings/reference/match.scrbl
View File

@ -326,8 +326,10 @@ In more detail, patterns match as follows:
@item{@racket[(#,(racketidfont "?") _expr _pat ...)] --- applies
@racket[_expr] to the value to be matched, and checks whether
the result is a true value; the additional @racket[_pat]s must
also match (i.e., @racketidfont{?} combines a predicate
application and an @racketidfont{and} pattern).
also match; i.e., @racketidfont{?} combines a predicate
application and an @racketidfont{and} pattern. However,
@racketidfont{?}, unlike @racketidfont{and}, guarantees that
@racket[_expr] is matched before any of the @racket[_pat]s.
@examples[
#:eval match-eval