(module match-generics
;;© Idiomdrottning, 2021. BSD 1-clause license
(define-dx)
(import (rename scheme (define define-og)) (chicken base) (chicken syntax) brev-separate matchable)
(import-for-syntax brev-separate matchable srfi-1)

(define-for-syntax gentable (call-table*))

(define-for-syntax (unique? args)
  (let ((syms (call-table* proc: add1 initial: 0 unary: #t)))
    (for-each syms (butlast args))
    (let ((lp (last-pair args)))
      (syms (car lp))
      (unless (null? (cdr lp)) (syms (cdr lp))))
    (> 2 ((as-list (c apply max) (c map cdr)) (syms)))))

(define-for-syntax (all-symbols? lis)
  (or (symbol? lis)
      (and (pair? lis)
	   (symbol? (car lis))
	   (or (all-symbols? (cdr lis))
	       (null? (cdr lis))))))

(define-ir-syntax*
  ((define-dx (name . pattern) . body)
   (receive
       (pattern body)
       (if (##sys#extended-lambda-list? pattern)
	   (##sys#expand-extended-lambda-list
	    pattern body
	    ##sys#syntax-error-hook (##sys#current-environment))
	   (values pattern body))
     (let* ((clauses (gentable (strip-syntax name) (cons (cons name pattern) body)))
	    (args (cdaar clauses)))
       (if (and (null? (cdr clauses))
		(or
		 (null? args)
		 (symbol? args)
		 (and (pair? args)
		      (all-symbols? args)
		      (unique? args))))
	   (cons 'define-og (car clauses))
	   (cons 'match-define clauses)))))

  ((define-dx reset: name)
   ((call-table seed: (gentable)) (strip-syntax name) '())
   '(void))

  ((define-dx var thing)
   `(define-og ,var ,thing))

  ((define-dx)
   `',gentable)))