From df594d3b3bd6924b80942323803385964e9a708b Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Sun, 14 Oct 2012 14:09:41 -0400 Subject: [PATCH] Move `define/match` to `racket/match` --- collects/mzlib/scribblings/match.scrbl | 1 + collects/racket/match/define-forms.rkt | 38 ++++++++++++++-- collects/racket/match/legacy-match.rkt | 3 +- collects/racket/match/match.rkt | 3 +- collects/scribblings/reference/match.scrbl | 44 +++++++++++++++++++ .../match/define-match.rkt} | 18 +++++++- collects/unstable/match.rkt | 35 +-------------- 7 files changed, 101 insertions(+), 41 deletions(-) rename collects/{unstable/tests/match.rkt => tests/match/define-match.rkt} (68%) diff --git a/collects/mzlib/scribblings/match.scrbl b/collects/mzlib/scribblings/match.scrbl index e6e761daa8..3919fd668e 100644 --- a/collects/mzlib/scribblings/match.scrbl +++ b/collects/mzlib/scribblings/match.scrbl @@ -31,6 +31,7 @@ follows: @; ------------------------------------------------------------ @deftogether[( +@defform[(define/match (head args) match*-clause ...)] @defform[(match-lambda clause ...)] @defform[(match-lambda* clause ...)] @defform[(match-let ([pat expr] ...) body ...+)] diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index dab3e38e23..4d365e8541 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -5,23 +5,47 @@ (only-in racket/list append* remove-duplicates) unstable/sequence syntax/parse + syntax/parse/experimental/template (only-in racket/match/patterns bound-vars) (only-in racket/match/gen-match go go/one))) (provide define-forms) +;; syntax classes for `define/match` +(begin-for-syntax + (define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:args) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + + (define-syntax-class args + (pattern (arg:arg ...) + #:attr params #'(arg.name ...)) + (pattern (arg:arg ... . rest:id) + #:attr params #'(arg.name ... rest))) + + (define-splicing-syntax-class arg + #:attributes (name) + (pattern name:id) + (pattern [name:id default]) + (pattern (~seq kw:keyword name:id)) + (pattern (~seq kw:keyword [name:id default])))) + (define-syntax-rule (define-forms parse-id match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values match-define match-define-values match-letrec - match/values match/derived match*/derived) + match/values match/derived match*/derived + define/match) (... (begin (provide match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values match-define match-define-values match-letrec - match/values match/derived match*/derived match-define-values) + match/values match/derived match*/derived match-define-values + define/match) (define-syntax (match* stx) (syntax-parse stx [(_ es . clauses) @@ -144,4 +168,12 @@ (quasisyntax/loc stx (define-values #,bound-vars-list (match/values rhs - [(pats ...) (values . #,bound-vars-list)]))))]))))) + [(pats ...) (values . #,bound-vars-list)]))))])) + + (define-syntax (define/match stx) + (syntax-parse stx + [(_ ?header:function-header ?clause ...) + (template + (define ?header + (match* (?? ?header.params) + ?clause ...)))]))))) diff --git a/collects/racket/match/legacy-match.rkt b/collects/racket/match/legacy-match.rkt index 77f8bc4506..e82a4d96ec 100644 --- a/collects/racket/match/legacy-match.rkt +++ b/collects/racket/match/legacy-match.rkt @@ -17,4 +17,5 @@ (define-forms parse/legacy match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values - match-define match-define-values match-letrec match/values match/derived match*/derived) + match-define match-define-values match-letrec match/values match/derived match*/derived + define/match) diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index e16d9d236c..93ced7d355 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -27,4 +27,5 @@ match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values match-define match-define-values match-letrec match/values - match/derived match*/derived) + match/derived match*/derived + define/match) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index 23ba9a1e5a..9de0c54400 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -383,6 +383,50 @@ exactly @racket[n] patterns. At least one clause is required to determine how many values to expect from @racket[expr]. } +@defform/subs[ + (define/match (head args) + match*-clause ...) + ([head id (head args)] + [args (code:line arg ...) + (code:line arg ... @#,racketparenfont{.} rest-id)] + [arg arg-id + [arg-id default-expr] + (code:line keyword arg-id) + (code:line keyword [arg-id default-expr])] + [match*-clause [(pat ...+) body ...+] + [(pat ...+) (=> id) body ...+]]) +]{ + Binds @racket[id] to a procedure that is defined by pattern matching + clauses using @racket[match*]. Each clause takes a sequence of + patterns that correspond to the arguments in the function header. + The arguments are ordered as they appear in the function header for + matching purposes. + + The function header may contain optional or keyword arguments, or + may be in curried form. + + @defexamples[#:eval match-eval + (define/match (fact n) + [(0) 1] + [(n) (* n (fact (sub1 n)))]) + (fact 5) + + (define/match ((f x) #:y [y '(1 2 3)]) + [((regexp #rx"p+") `(,a 2 3)) a] + [(_ _) #f]) + ((f "ape") #:y '(5 2 3)) + ((f "dog")) + + (define/match (g x y . rst) + [(0 0 '()) #t] + [(5 5 '(5 5)) #t] + [(_ _ _) #f]) + (g 0 0) + (g 5 5 5 5) + (g 1 2) + ] +} + @defform[(match-lambda clause ...)]{ Equivalent to @racket[(lambda (id) (match id clause ...))]. diff --git a/collects/unstable/tests/match.rkt b/collects/tests/match/define-match.rkt similarity index 68% rename from collects/unstable/tests/match.rkt rename to collects/tests/match/define-match.rkt index 4c20b037b6..dfcb93a2d9 100644 --- a/collects/unstable/tests/match.rkt +++ b/collects/tests/match/define-match.rkt @@ -1,7 +1,6 @@ #lang racket/base -(require rackunit - unstable/match) +(require rackunit racket/match) (define/match ((curried x) y) [((? number? x) y) (+ x y)] @@ -41,3 +40,18 @@ (check-false (f)) (check-false (f 2)) (check-false (f 2 4 5)) + +(require (prefix-in legacy: mzlib/match)) +(legacy:define/match (fact-2 n) + [(0) 1] + [(n) (* n (fact (sub1 n)))]) + +(check-equal? (fact-2 0) 1) +(check-equal? (fact-2 5) 120) + +(legacy:define/match (list-fun lst) + [((1 2 3)) #t] + [((_ _ _ )) #f]) + +(check-equal? (list-fun '(1 2 3)) #t) +(check-equal? (list-fun '(4 5 6)) #f) diff --git a/collects/unstable/match.rkt b/collects/unstable/match.rkt index b19a1ad6d7..9fdd8d7277 100644 --- a/collects/unstable/match.rkt +++ b/collects/unstable/match.rkt @@ -3,8 +3,7 @@ (require racket/class racket/match (for-syntax racket/base) - (for-syntax syntax/parse - syntax/parse/experimental/template)) + (for-syntax syntax/parse)) (provide match? as object) @@ -15,38 +14,6 @@ (syntax-rules () [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)])) -;; Added by asumu -;; Comprehensive `define` procedure form for match -(provide define/match) - -(begin-for-syntax - (define-syntax-class function-header - (pattern ((~or header:function-header name:id) . args:args) - #:attr params - (template ((?@ . (?? header.params ())) - . args.params)))) - - (define-syntax-class args - (pattern (arg:arg ...) - #:attr params #'(arg.name ...)) - (pattern (arg:arg ... . rest:id) - #:attr params #'(arg.name ... rest))) - - (define-splicing-syntax-class arg - #:attributes (name) - (pattern name:id) - (pattern [name:id default]) - (pattern (~seq kw:keyword name:id)) - (pattern (~seq kw:keyword [name:id default])))) - -(define-syntax (define/match stx) - (syntax-parse stx - [(_ ?header:function-header ?clause ...) - (template - (define ?header - (match* (?? ?header.params) - ?clause ...)))])) - ;; Added by asumu ;; Match expander for objects from racket/class (define-match-expander object