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

(define-syntax define-ir-syntax*
  (ir-macro-transformer
   (lambda (e i c)
     (let ((cand (caadr e)))
       `(define-syntax ,(if (pair? cand) (car cand) cand)
          (ir-macro-transformer
           (lambda (exp ,(i 'inject) ,(i 'compare))
             (match exp
               ,@(if (pair? cand) (cdr e) (list (cdr 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 str reg expression)
   (let ((op (if (pair? expression) (strip-syntax (car expression)) #f)))
    `(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 (memq op '(return then))
			`(begin ,@(cdr expression) ,@(if (eq? op 'then) '(#f) '()))
			expression))
	      (ret (if (procedure? ret)
		       (ret (irregex-match-substring match 0))
		       ret)))
	 ,(if (eq? op 'return)
	      '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? str reg)
   `(not (not (irregex-search ,(clean reg) ,str))))
  ((strse? reg)
   `(lambda (str) (strse? str ,reg))))

(define-ir-syntax*

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

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

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

  ((inner-strse str  ((? (cut compare <> 'truly) truly) reg) expression (? new-regex? nr) . more)
   `(let ((first (inner-strse ,str ,reg ,expression #f)))
      (if first (inner-strse first ,nr ,@more) #f)))

  ((inner-strse str reg (and expression ((? (cut compare <> 'return) return) . _)) . more)
   `(let ((match (irregex-search ,(clean reg) ,str)))
      (if match ((rep-obj ,str ,reg ,expression) match)
	  ,(if (null? more) str `(inner-strse ,str ,@more)))))

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

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

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

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

  ((inner-strse str ((? (cut compare <> 'recursively) recursively) reg) expression)
   `(inner-strse ,str ,reg ,expression #t))

  ((inner-strse str ((? (cut compare <> 'truly) truly) reg) expression)
   `(inner-strse ,str ,reg ,expression #f))

  ((inner-strse str reg ((? (cut compare <> 'entire) entire) . expression))
   `(inner-strse ,str ,reg (begin ,@expression) 0))

  ((inner-strse str ((? (cut compare <> 'only) only) (? integer? flag) reg) expression)
   `(inner-strse ,str ,reg ,expression ,(if (negative? flag) flag (add1 flag))))

  ((inner-strse str ((? (cut compare <> 'only) only) accessor reg) expression)
   `(let* ((num (condition-case
		 (,accessor (reverse (match-indices ,(clean reg) ,str)))
		 ((exn type) #f))))
      (if num
	  (string-append
	   (string-take ,str num)
	   (irregex-replace
	    ,(clean reg)
	    (substring ,str num)
	    (rep-obj ,str ,reg ,expression)))
	  ,str)))

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

(define-for-syntax (even-ops? ops)
	(cond ((null? ops) #t)
				((or (number? (car ops)) (boolean? (car ops))) (even-ops? (cdr ops)))
				((or (null? (cdr ops)) (number? (cadr ops)) (boolean? (cadr ops))) #f)
				(else (even-ops? (cddr ops)))))

(define-ir-syntax*
	((strse . (? even-ops? ops))
	 `(lambda (str)
			(inner-strse str ,@ops)))
	((strse exp . ops)
   `(let ((str ,exp))
			(inner-strse str ,@ops))))

(define-ir-syntax*
	((strse* in . (? even-ops? ops))
   `(let* ((str (strse (with-output-to-string (lambda () (write ,in))) ,@ops))
					 (it (with-input-from-string str read)))
			it))
	((strse* . ops)
	 `(lambda (in) (strse* in ,@ops))))

(define-ir-syntax*
  ((strse?* str reg)
   `(strse? (with-output-to-string (lambda () (write ,str))) ,reg))
  ((strse?* reg)
   `(lambda (str) (strse? (with-output-to-string (lambda () (write str))) ,reg))))

)