diff --git a/collects/unstable/match.rkt b/collects/unstable/match.rkt index 9fdd8d7277..b19a1ad6d7 100644 --- a/collects/unstable/match.rkt +++ b/collects/unstable/match.rkt @@ -3,7 +3,8 @@ (require racket/class racket/match (for-syntax racket/base) - (for-syntax syntax/parse)) + (for-syntax syntax/parse + syntax/parse/experimental/template)) (provide match? as object) @@ -14,6 +15,38 @@ (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 diff --git a/collects/unstable/scribblings/match.scrbl b/collects/unstable/scribblings/match.scrbl index f5ffaea610..f1a6741a2e 100644 --- a/collects/unstable/scribblings/match.scrbl +++ b/collects/unstable/scribblings/match.scrbl @@ -48,6 +48,41 @@ result value of @racket[rhs-expr], and continues matching each subsequent @addition[@author+email["Asumu Takikawa" "asumu@racket-lang.org"]] +@defform/subs[ + (define/match (head args) + match*-clause ...) + ([head id (head args)] + [args (arg ...)] + [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 the-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")) + ] +} + @defform/subs[ #:literals (field) (object maybe-class field-clause ...)