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

;; Implicity rename parts of an otherwise explicitly renaming macro

(define-syntax define-er-syntax*
  (ir-macro-transformer
   (lambda (e i c)
     (let ((cand (caadr e)))
       `(define-syntax ,(if (pair? cand) (car cand) cand)
          (er-macro-transformer
           (lambda (exp ,(i 'rename) ,(i 'compare))
	     (let* ((injected (gensym))
		    (,(i 'inject) (lambda (x) (vector injected x)))
		    (injected? (lambda (x) (and (vector? x) (eq? injected (vector-ref x 0)))))
		    (,(i 'ir)
		     (lambda (tree)
		       (quasiwalk
			(lambda (x) (if (injected? x) (vector-ref x 1) (,(i 'rename) x)))
			tree))))
               (match exp
		 ,@(if (pair? cand) (cdr e) (list (cdr e))))))))))))

(define-for-syntax (immediate-requires tree)
  (let ((req 0))
    (call-with-current-continuation
     (lambda (exit)
       (quasiwalk
	(fn
	 (when (eq? 'match-lambda* x) (exit #f))
	 (when (eq? 'require x) (set! req (add1 req))))
	tree)))
    req))

(define-for-syntax (immediate-require? tree)
  (< 0 (immediate-requires tree)))

(define-for-syntax (no-immediate-require? tree)
  (= 0 (immediate-requires tree)))

(define-for-syntax counter
  (let ((val -1))
    (lambda args
      (set! val (add1 val))
      (unless (null? args) (set! val 0))
      val)))

(define-for-syntax (harmonize new old)
  (define new->repsym (call-table* proc: (fn (eif y y x))))
  (define old->repsym (call-table* proc: (fn (eif y y x))))
  (define repsym->name (call-table* proc: (fn (eif y y x))))
  (counter 'reset)
  (this
      (cons
       (quasiwalk
        (fn (if (symbol? x)
                (repsym->name
                 (new->repsym x (counter))
                 (gensym x))
                x))
        (car new))
       (quasiwalk
        (fn (if (symbol? x)
                (eif (new->repsym x) (repsym->name it) x)
                x))
        (cdr new)))
    (counter 'reset)
    (values
     that
     (quasiwalk
      (fn (if (symbol? x)
              (eif (repsym->name
                    (old->repsym x (counter)))
                   it x)
              x))
      old))))

(define-for-syntax (ml-merge new-one old-ones)
  (let ((old-ones
         (if (null? old-ones)
             (list (car new-one)
                   `(match-lambda* (args (error ',(car new-one)
                                                "Can't handle" args))))
             old-ones)))
    (list (car old-ones)
          (cons (caadr old-ones)
                (receive (similar different)
                    (partition (lambda (o)
                                 ((compose equal? harmonize)
                                  (list (car (cadadr new-one)))
                                  (list (car o))))
                               (cdadr old-ones))
                  (cond
                   ((null? similar)
                    (cons (cadadr new-one) different))
                   ((immediate-require? (cadadr new-one))
                             ;;; FIXME this does *no* deduplicatiom if
                             ;;; there's a require in the new one.
                             ;;; even though it might be a dupe.
                    (cons (cadadr new-one) (cdadr old-ones)))
                   ((and (eq? 'match-lambda* (caadar similar))
                         (eq? 'match-lambda* (caadar (cdadr new-one))))
                    (cons (receive (gn gs) (harmonize
                                            (cadadr new-one)
                                            (car similar))
                            (ml-merge gn gs))
                          different))
                   (else
                    (unless (null? different)
                      ;; can only be null if we are more of a
                      ;; catch-all than the catch-all, which
                      ;; is fine
                      (##sys#notice "Overwriting older definition for same bindings"))
                    (cons (cadadr new-one) different))))))))

(define-for-syntax gentable
  (call-table* proc: ml-merge))

(define-for-syntax (unique? args)
  (or (null? args) (symbol? 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))))))

;; Written this way instead of every so it can handle dotted lists
(define-for-syntax (all-symbols? lis)
  (or (null? lis)
      (symbol? lis)
      (and (pair? lis)
           (symbol? (car lis))
           (all-symbols? (cdr lis)))))

(define-for-syntax (safe-and-boring? lis)
  (and (all-symbols? lis) (unique? lis)))

(define-for-syntax (all-safe-clauses? lis)
  (and (list? lis)
       (< 1 (length lis))
       (every pair? lis)
       (every safe-and-boring? (map car lis))
       (every no-immediate-require? (map cdr lis))))

(define-for-syntax optimize-lambdas
  (match-lambda*

   (((name (and val ('match-lambda* . _)))) (list name (optimize-lambdas val)))

   ((('match-lambda* ((? safe-and-boring? args) .
                      (? no-immediate-require? body))
                     error-handler))
    `(lambda ,args ,@(optimize-lambdas body)))

   ((('match-lambda* . (? all-safe-clauses? clauses)))
    `(case-lambda ,@((over (if (= 2 (length x))
                               (list (first x) (optimize-lambdas (second x)))
                               x))
                     clauses)))

   ((((? (o (is? 'let) strip-syntax) lt) bdg single-statement))
    (list lt bdg (optimize-lambdas single-statement)))

   ((x) x)))

(define-for-syntax (add-backtracker ir inject clause)
  (if (no-immediate-require? clause)
      clause
      (ir
       `(,(inject (car clause))
	 (=> backtrack)
	 (call-with-current-continuation
	  (lambda (exit)
	    (let ((,(inject 'require)
		   (lambda (valid result)
		     (if (if (procedure? valid)
			     (valid result) valid)
			 result
			 (exit (backtrack))))))
	      ,@(quasiwalk inject (cdr clause)))))))))

(define-for-syntax (extend bindings body)
  (receive
      (bindings body)
      (if (##sys#extended-lambda-list? bindings)
          (##sys#expand-extended-lambda-list
           bindings body
           ##sys#syntax-error-hook (##sys#current-environment))
          (values bindings body))
    (cons bindings body)))

(define-er-syntax*
  ((define-dx ((name . inner) . outer) . body)
   `(,(rename 'define-dx) (,name . ,inner)
     (match-lambda* ,(add-backtracker ir inject (extend outer body)))))

  ((define-dx (name . pattern) . body)
   (let ((clauses (gentable
		   name
		   `(,name (match-lambda*
			    ,(add-backtracker ir inject (extend pattern body)))))))
     (quasiwalk
      (?-> (fn (memq x '(define-og match-lambda* case-lambda lambda)))
	   rename)
      (cons 'define-og (optimize-lambdas clauses)))))

  ((define-dx reset: name)
   ((call-table seed: (gentable)) name '())
   `(,(rename 'void)))

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

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