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