unstable/match: add define/match

Match-based function definition form that supports optional,
keyword, rest-arg, and curried arguments.

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

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 ...)