;; -*-theme-d-*-

;; Copyright (C) 2008-2019 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library string-utilities)

  (import (standard-library list-utilities))
  
  (define string-append
    (unchecked-prim-proc string-append ((rest <string>)) <string> pure))

  (define string
    (unchecked-prim-proc string ((rest <character>)) <string> pure))

  (define string-length
    (unchecked-prim-proc string-length (<string>) <integer> pure))

  (define string-ref
    (unchecked-prim-proc string-ref (<string> <integer>) <character> pure))

  (define-simple-proc string-empty? (((str <string>)) <boolean> pure)
    (integer=? (string-length str) 0))

  (define-simple-proc substring
      (((str <string>) (i-start <integer>) (i-end <integer>))
       <string>
       force-pure)
    (let ((i-len (string-length str)))
      (if (or (< i-start 0) (< i-end 0)
	      (> i-start i-len)
	      (> i-end i-len))
	  (raise-simple 'substring:index-out-of-range)
	  (let-mutable ((result <string> ""))
	    (do ((i <integer> i-start (+ i 1))) ((>= i i-end))
	      (set! result (string-append result (string (string-ref str i)))))
	    result))))

  (define-simple-proc string-last-char
      (((str <string>)) <character> pure)
    (let ((i-len <integer> (string-length str)))
      (if (> i-len 0)
	  (string-ref str (- i-len 1))
	  (raise-simple 'string-last-char:empty-string))))

  (define-simple-proc replace-char
      (((str <string>) (ch-src <character>) (ch-dest <character>))
       <string>
       force-pure)
    (let ((i-len (string-length str)))
      (let-mutable ((str-result <string> ""))
	(do ((i <integer> 0 (+ i 1))) ((>= i i-len))
	  (let* ((ch-cur (string-ref str i))
		 (ch-new
		  (if (equal? ch-cur ch-src) ch-dest ch-cur)))
	    (set! str-result (string-append str-result (string ch-new)))))
	str-result)))

  (define-simple-proc replace-char-with-string
      (((str <string>) (ch-src <character>) (str-dest <string>))
       <string>
       force-pure)
    (let ((i-len (string-length str)))
      (let-mutable ((str-result <string> ""))
	(do ((i <integer> 0 (+ i 1))) ((>= i i-len))
	  (let* ((ch-cur (string-ref str i))
		 (str-new
		  (if (equal? ch-cur ch-src) str-dest (string ch-cur))))
	    (set! str-result (string-append str-result str-new))))
	str-result)))

  (define-simple-proc split-string (((str <string>)
				     (ch-split <character>))
				    (:uniform-list <string>)
				    force-pure)
    (let ((i-len <integer> (string-length str)))
      (let-mutable ((lst-result (:uniform-list <string>) null)
		    (str-cur <string> ""))
	(do ((i <integer> 0 (+ i 1)))
	    ((>= i i-len))
	  (let ((ch-cur (string-ref str i)))
	    (if (equal? ch-cur ch-split)
		(begin
		  (set! lst-result (append lst-result
					   (list str-cur)))
		  (set! str-cur ""))
		(set! str-cur (string-append str-cur (string ch-cur))))))
	(append lst-result (list str-cur)))))

  (define-simple-proc join-strings-with-sep
      (((lst (:uniform-list <string>)) (str-sep <string>)) <string> pure)
    (match-type-strong lst
      ((<null>) "")
      ((lst1 (:nonempty-uniform-list <string>))
       (let ((str-head (car lst1))
	     (l-tail (cdr lst1)))
	 (if (null? l-tail)
	     str-head
	     (string-append str-head str-sep
			    (join-strings-with-sep l-tail str-sep)))))))

  (define-simple-proc string-contains-char?
      (((str <string>) (ch <character>)) <boolean> force-pure)
    (let ((i-len (string-length str)))
      (let-mutable ((found? <boolean> #f))
	(do ((i <integer> 0 (+ i 1))) ((or (>= i i-len) found?))
	  (if (equal? (string-ref str i) ch)
	      (set! found? #t)))
	found?)))

  (define-simple-proc string-char-index
      (((str <string>) (ch <character>)) <integer> force-pure)
    (let ((i-len (string-length str)))
      (let-mutable ((i-found <integer> -1))
	(do ((i <integer> 0 (+ i 1))) ((or (>= i i-len) (>= i-found 0)))
	  (if (equal? (string-ref str i) ch)
	      (set! i-found i)))
	i-found)))

  (define-simple-proc string-char-index-right
      (((str <string>) (ch <character>))
       <integer>
       pure)
    (let ((i-len (string-length str)))
      (let-mutable ((i-result <integer> -1))
	(do ((i-cur <integer> (- i-len 1) (- i-cur 1)))
	    ((or (< i-cur 0) (>= i-result 0)) i-result)
	  (if (equal? (string-ref str i-cur) ch)
	      (set! i-result i-cur))))))

  (define-simple-proc string-take
      (((str <string>) (i-count <integer>))
       <string>
       pure)
    (substring str 0 i-count))

  (define-simple-proc string-drop
      (((str <string>) (i-count <integer>))
       <string>
       pure)
    (let ((i-len (string-length str)))
      (substring str i-count i-len)))

  (define-simple-proc string-take-right
      (((str <string>) (i-count <integer>))
       <string>
       pure)
    (let ((i-len (string-length str)))
      (if (> i-count i-len)
	  (raise-simple 'string-index-out-of-range)
	  (substring str (- i-len i-count) i-len))))

  (define-simple-proc string-drop-right
      (((str <string>) (i-count <integer>))
       <string>
       pure)
    (let ((i-len (string-length str)))
      (if (> i-count i-len)
	  (raise-simple 'string-index-out-of-range)
	  (substring str 0 (- i-len i-count)))))

  (define-simple-proc search-substring
      (((str <string>) (str-match <string>)) <integer> pure)
    (let* ((i-len (string-length str))
	   (i-match-len (string-length str-match))
	   (i-limit (- i-len i-match-len)))
      (if (> i-match-len i-len)
	  (raise-simple 'search-substring:index-out-of-range)
	  (let-mutable ((i-found <integer> -1))
	    (do ((i1 <integer> 0 (+ i1 1)))
		((or (>= i1 i-limit) (>= i-found 0)) i-found)
	      (if
	       (let-mutable ((success2? <boolean> #t))
		 (do ((i2 <integer> 0 (+ i2 1)))
		     ((or (>= i2 i-match-len) (not success2?)) success2?)
		   (if (not (character=? (string-ref str (+ i1 i2))
					 (string-ref str-match i2)))
		       (set! success2? #f))))
	       (set! i-found i1)))))))

  (define-simple-proc search-substring-from-end
      (((str <string>) (str-match <string>)) <integer> pure)
    (let ((i-len (string-length str))
	  (i-match-len (string-length str-match)))
      (if (> i-match-len i-len)
	  (raise-simple 'search-substring-from-end:index-out-of-range)
	  (let-mutable ((i-found <integer> -1))
	    (do ((i1 <integer> (- i-len i-match-len) (- i1 1)))
		((or (< i1 0) (>= i-found 0)) i-found)
	      (if
	       (let-mutable ((success2? <boolean> #t))
		 (do ((i2 <integer> 0 (+ i2 1)))
		     ((or (>= i2 i-match-len) (not success2?)) success2?)
		   (if (not (character=? (string-ref str (+ i1 i2))
					 (string-ref str-match i2)))
		       (set! success2? #f))))
	       (set! i-found i1)))))))

  (define string-match
    (prim-proc theme-string-match (<string> <string>)
	       <string-match-result>
	       pure))

  (define-simple-proc string-exact-match?
      (((str-pattern <string>) (str-source <string>)) <boolean> pure)
    (let ((tp-match <string-match-result>
		    (string-match str-pattern str-source)))
      (match-type tp-match
	((tp1 (:tuple <string> <integer> <integer>))
	 (and (equal? (tuple-ref tp1 1) 0)
	      (equal? (tuple-ref tp1 2) (string-length str-source))))
	(else #f)))))
