;; © 2021 Idiomdrottning, BSD 1-Clause License
(module strse
(strse match-indices)
(import scheme (chicken syntax)  matchable (chicken irregex) (chicken string) srfi-13)
(import-for-syntax (chicken irregex) matchable  miscmacros)

(define-syntax define-ir-syntax*
  (ir-macro-transformer
   (lambda (e i c)
     `(define-syntax ,(cadr e)
        (ir-macro-transformer
         (lambda (exp ,(i 'inject) ,(i 'compare))
           (match exp
             ,@(cddr e))))))))

(define-for-syntax raw-regex?
  (conjoin pair?
	   (complement
	    (disjoin (lambda (n) (equal? 'quote (car (strip-syntax n))))
		     (lambda (n) (equal? 'quasiquote (car (strip-syntax n))))))))

(define-for-syntax new-regex?
  (complement
   (disjoin
    (cut eq? #f <>)
    integer?)))

(define-ir-syntax* rep-obj
  ((rep-obj str reg expression)
   `(lambda (match)
      (let* (,@(if (raw-regex? reg)
		   (map
		    (lambda (n) `(,(inject (car n)) (irregex-match-substring match ,(cdr n))))
		    (irregex-names (irregex (strip-syntax reg))))
		   '())
	     (,(inject 'm) (lambda (n) (irregex-match-substring match n)))
	     (,(inject 'it) ,str)
	     (ret ,(if (and (pair? expression) (eq? 'then (strip-syntax (car expression))))
		       `(begin ,@(cdr expression) #f)
		       expression))
	     (ret (if (procedure? ret)
		      (ret (irregex-match-substring match 0))
		      ret)))
	(if (string? ret) ret (irregex-match-substring match 0))))))

(begin-for-syntax
 (define-syntax-rule
   (clean reg)
   (if (raw-regex? reg)
       `',reg
       reg)))

(define (match-indices reg str)
  (irregex-fold
   reg
   (lambda (from-index match seed)
     (cons from-index seed))
   '()
   str))

(define-ir-syntax* strse

  ((strse str reg expression #t)
   `(let loop ((old ,str)
	       (new (strse ,str ,reg ,expression)))
      (if (string=? old new) new
	  (loop new (strse new ,reg ,expression)))))

  ((strse str reg expression #f (? new-regex? nr) . more)
   `(let ((first (strse ,str ,reg ,expression #f)))
      (if first (strse first ,nr ,@more) #f)))

  ((strse str reg expression (? (disjoin (cut eq? #t <>) integer?) flag)
	  (? new-regex? nr) . more)
   `(let ((first (strse ,str ,reg ,expression ,flag)))
      (strse first ,nr ,@more)))

  ((strse str reg expression (? new-regex? nr) . more)
   `(let ((first (strse ,str ,reg ,expression)))
      (strse first ,nr ,@more)))

  ((strse str reg expression #f)
   `(let ((match (irregex-search ,(clean reg) ,str)))
      (if match
	  (irregex-replace/all ,(clean reg) ,str
			       (rep-obj ,str ,reg ,expression))
	  #f)))

  ((strse str reg expression 0)
   `(let ((match (irregex-search ,(clean reg) ,str)))
      (if match
	  ((rep-obj ,str ,reg ,expression) match)
	  ,str)))

  ((strse str reg expression (? integer? flag))
   `(let* ((mi (,(if (< 0 flag) 'reverse 'identity)
		(match-indices ,(clean reg) ,str)))
	   (i ,(sub1 (abs flag)))
	   (num (if (< i (length mi)) (list-ref mi i) #f)))
      (if num
	  (string-append
	   (string-take ,str num)
	   (irregex-replace
	    ,(clean reg)
	    (substring ,str num)
	    (rep-obj ,str ,reg ,expression)))
	  ,str)))

  ((strse str reg expression)
   `(irregex-replace/all
     ,(clean reg) ,str
     (rep-obj ,str ,reg ,expression))))

)