(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 (quasi-rename tree new)
  (if (null? new) tree
      (let ((new (append ((over (list (cadr x)
				      (if (eq? (car x) (cadr x))
					  (car x)
					  (gensym (cadr x)))))
			  new) new)))
	(quasiwalk
	 (lambda (name)
	   (let ((presence (assv name new)))
	     (if presence
		 (cadr presence)
		 name)))
	 tree))))

(define-for-syntax ((equivalent? ap) xp)
  (call-with-current-continuation
   (lambda (exit)
     (define (literal? v)
       (or
	(any (fn (x v)) (list null? boolean? number? string? char?))
	(memq v '(and or not))))
     (define pairs (call-table* proc: (fn (if (null? y) (list x) (exit #f)))))
     (define non-pairs (call-table* proc: (fn (if (null? y) (list x) (exit #f)))))
     (define (comp at xt)
       (match (list at xt)
	 ;;FIXME: descend into quasipatterns and tree ***
	 (((? literal? a) (not a)) (exit #f))
	 (((? vector? a) (? vector? b)) (comp (vector->list a) (vector->list b)))
	 (((? symbol? a) (? symbol? x)) (pairs a x) (non-pairs x a) #t)
	 ((a a) '())
	 ((('quote a) _) (exit #f))
	 ((_ ('quote a)) (exit #f))
	 ((('quasiquote a) _) (exit #f))
	 ((_ ('quasiquote a)) (exit #f))
	 ((((and res (or '= '? '$)) op . ar) (res op . xr)) (comp ar xr))
	 ((((and res (or '= '? '$)) op . ar) _) (exit #f))
	 (((ahd . atl) (xhd . xtl)) (and (comp ahd xhd) (comp atl xtl)))
	 (else (exit #f))))
     (comp ap xp)
     (hash-table->alist (non-pairs)))))

(define-for-syntax ((equiv-dsssl? alb) blb)
  (equal? (quasiwalk strip-syntax alb)
	  (quasiwalk strip-syntax blb)))

(define-for-syntax ml-submatch?
  (match-lambda*
   ((a ((= (equivalent? a) res) ('match-lambda* . _))) res)
   (_ #f)))

(define-for-syntax let-ml-submatch?
  (match-lambda*
   ((a al ab (_ ('match-lambda* . _))) #f)
   ((a al ab ((= (equivalent? a) res) ((? (equiv-dsssl? al) bl)
				       (? (equiv-dsssl? ab) bb)
				       ('match-lambda* . _)))) res)
   (_ #f)))

(define-for-syntax wrong-let-ml-submatch?
  (match-lambda*
   ((a al ab (_ ('match-lambda* . _))) #f)
   ((a al ab ((= (equivalent? a) res) ((? (equiv-dsssl? al) bl)
				       _
				       ('match-lambda* . _)))) res)
   (_ #f)))

(define-for-syntax non-ml-submatch?
  (match-lambda*
   ((? immediate-require? args) #f)
   ((a (_
	(or ('match-lambda* . _)
	    (_ _ ('match-lambda* . _))))) #f)
   ((a ((= (equivalent? a) res) . _)) res)
   (_ #f)))

(define-for-syntax ml-merge
  (match-lambda*

   ((((? symbol? a) (and a-clause ('match-lambda* . _)))
     '())
    (list a (ml-merge a-clause
                      `(match-lambda* (args (error ,a '|Can't handle| args))))))

   ((a ()) a)

   ((((? symbol? a) (and a-clause ('match-lambda* . _)))
     (a b-clauses))
    (list a (ml-merge a-clause b-clauses)))

   ((('match-lambda* (and a (ap (and body ('match-lambda* . _)))))
     ('match-lambda* . (? (c any (c ml-submatch? ap)) clauses)))
    `(match-lambda* ,@((over
			(match-let* ((sm (ml-submatch? ap x))
				     (ru (and (list? sm) (memq '_ (map cadr sm))))
				     ((sm (ap body))
				      (if ru
					  (quasi-rename (list sm a) '((_ underscore)))
					  (list sm a))))
				    (if sm
					(list ap (ml-merge body (quasi-rename (cadr x) sm)))
					x)))
		       clauses)))

   ((('match-lambda* (and a (ap (al ab (and body ('match-lambda* . _))))))
     ('match-lambda* . (? (c any (c let-ml-submatch? ap al ab)) clauses)))
    `(match-lambda* ,@((over
			(match-let* ((sm (let-ml-submatch? ap al ab x))
				     (ru (and (list? sm) (memq '_ (map cadr sm))))
				     ((sm (ap (al ab body)))
				      (if ru
					  (quasi-rename (list sm a) '((_ underscore)))
					  (list sm a))))
				    (if sm
					(list ap (list al ab
						       (ml-merge body
								 (quasi-rename (third (cadr x))
									       sm))))
					x)))
		       clauses)))

   ((('match-lambda* (and a (ap (al ab (and body ('match-lambda* . _))))))
     ('match-lambda* . (? (c any (c wrong-let-ml-submatch? ap al ab)) clauses)))
    (##sys#notice "Overwriting older, mismatched DSSSL")
    `(match-lambda* ,a ,@(remove (c wrong-let-ml-submatch? ap al ab) clauses)))

   ((('match-lambda* (and a (ap body)))
     ('match-lambda* . (? (c any (c non-ml-submatch? ap)) clauses)))
    (##sys#notice "Overwriting older definition for same bindings")
    `(match-lambda* ,a ,@(remove (c non-ml-submatch? ap) clauses)))

   ((('match-lambda* ap+b)
     ('match-lambda* . clauses))
    `(match-lambda* ,ap+b ,@clauses))))

(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)))