(module match-generics
;;© Idiomdrottning, 2021. BSD 1-clause license
(define-generic define-dx)
(import (rename scheme (define define-og)) (chicken base) (chicken syntax) (only brev-separate define-ir-syntax* match-define) matchable)
(import-for-syntax (only brev-separate call-table call-table* match-define as-list) matchable srfi-1)

(define-for-syntax gentable (call-table*))
(define-ir-syntax*
  (define-generic (name . pattern) . body)
  (cons 'match-define
        (gentable (strip-syntax name) (cons (cons name pattern) body))))

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

(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
		 (and (proper-list? args)
		      (every symbol? args)
		      (unique? args #f))
		 (and (dotted-list? args)
		      (every symbol? (butlast args))
		      (symbol? (car (last-pair args)))
		      (symbol? (cdr (last-pair args)))
		      (unique? args #t))))
	   (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)))