(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 0))
    (lambda args
      (set! val (add1 val))
      (unless (null? args) (set! val 0))
      val)))

(define-for-syntax (conj? x) (member x '(and or not set! get!)))

(define-for-syntax patternwalk
  (match-lambda*
   ((softness proc ('unquote tree))
    (list 'unquote (patternwalk (sub1 softness) proc tree)))

   ((softness proc ('unquote-splicing tree))
    (list 'unquote-splicing (patternwalk (sub1 softness) proc tree)))

   ((softness proc ('quasiquote tree))
    (list 'quasiquote (patternwalk (add1 softness) proc tree)))

   ((0 proc tree)
    (patternwalk proc tree))

   ((softness proc (? atom? atom))
    atom)

   ((softness proc (a . b))
    (cons (patternwalk softness proc a) (patternwalk softness proc b)))

   ((softness proc (a))
    (cons (patternwalk softness proc a) '()))

   ((proc (and tree ('quasiquote _))) (patternwalk 0 proc tree))
   ((proc (and tree ('quote _))) tree)
   ((proc ()) '())


   ((proc (? symbol? atom)) (proc atom))
   ((proc (? vector? a)) (list->vector (patternwalk proc (vector->list a))))
   ((proc (? atom? atom)) atom)
   ((proc ('? pred a)) `(? ,pred ,(patternwalk proc a)))
   ((proc ('$ strct a)) `($ ,strct ,(patternwalk proc a)))
   ((proc ('= field a)) `(= ,field ,(patternwalk proc a)))
   ((proc ((? (o not conj?) a)
           (? conj? b)
           . more))
    (cons (patternwalk proc a)
          (cons (patternwalk proc b)
                (patternwalk proc more))))
   ((proc ((? conj? conj) . more))
    (cons conj (patternwalk proc more)))
   ((proc (a . b)) (cons (patternwalk proc a) (patternwalk proc b)))
   ((proc (a)) (cons (patternwalk proc a) '()))))

(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
       (patternwalk
        (fn (if (symbol? x)
                (repsym->name
                 (new->repsym x (counter))
                 (gensym x))
                x))
        (car new))
       (patternwalk
        (fn (if (symbol? x)
                (eif (new->repsym x) (repsym->name it) x)
                x))
        (cdr new)))
    (counter 'reset)
    (values
     that
     (patternwalk
      (fn (if (symbol? x)
              (eif (repsym->name
                    (old->repsym x (counter)))
                   it x)
              x))
      old))))

(define-for-syntax error-handler?
  (match-lambda*
   ((`(args (error ,_ "Can't handle" args))) #t)
   (a #f)))

(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* deduplication 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))))
    `(lambda ,args ,@(optimize-lambdas body)))

   ((('match-lambda* ((? safe-and-boring? args) .
                      (? no-immediate-require? body))
                     (? error-handler? clause)))
    `(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)))