define/match

gistfile1.rkt

#lang racket

;; added something like `where` clauses

(require (for-syntax syntax/parse
                     syntax/parse/experimental/template))

(provide define/match)

(begin-for-syntax
  
  (struct binding (id val))
  (struct match-clause (expr))
  
  (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-splicing-syntax-class clause
    (pattern (~seq #:with x:id e)
             #:attr data (binding #'x #'e))
    (pattern e:expr
             #:attr data (match-clause #'e))))

(define-syntax (define/match stx)
  (syntax-parse stx
    [(_ ?header:function-header ?clause:clause ...)
     (let* ([clause-data (attribute ?clause.data)]
            [bindings (filter binding? clause-data)]
            [match-clauses (filter match-clause? clause-data)]
            [match-exprs (map match-clause-expr match-clauses)]
            [introducer (make-syntax-introducer)]
            [match-renamed (map introducer match-exprs)]
            [ids (map introducer (map binding-id bindings))]
            [vals (map binding-val bindings)])
       (with-syntax ([(?id ...) ids]
                     [(?val ...) vals]
                     [(?match-clause ...) match-renamed])
         (template
          (define ?header
            (let ([?id ?val] ...)
              (match* (?? ?header.params)
                ?match-clause ...))))))]))

(define/match (g x y)
  [(0 0) 'origin]
  [(x y) (* mult (+ x y))]
  #:with mult 10)

Merge it!