mes/module/srfi/srfi-13.mes

;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; srfi-13.mes is the minimal srfi-13

;;; Code:

(mes-use-module (srfi srfi-14))

(define (string-join lst . delimiter+grammar)
  (let ((delimiter (or (and (pair? delimiter+grammar) (car delimiter+grammar))
                       " "))
        (grammar (or (and (pair? delimiter+grammar) (pair? (cdr delimiter+grammar)) (cadr delimiter+grammar))
                     'infix)))
    (if (null? lst) ""
        (case grammar
         ((infix) (if (null? (cdr lst)) (car lst)
                                   (string-append (car lst) delimiter (string-join (cdr lst) delimiter))))
         ((prefix) (string-append delimiter (car lst) (apply string-join (cdr lst) delimiter+grammar)))
         ((suffix) (string-append (car lst) delimiter (apply string-join (cdr lst) delimiter+grammar)))))))

(define (string-copy s)
  (list->string (string->list s)))

(define (string=? a b)
    (eq? (string->symbol a)
         (string->symbol b)))

(define (string= a b . rest)
  (let* ((start1 (and (pair? rest) (car rest)))
         (end1 (and start1 (pair? (cdr rest)) (cadr rest)))
         (start2 (and end1 (pair? (cddr rest)) (caddr rest)))
         (end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
    (string=? (if start1 (if end1 (substring a start1 end1)
                             (substring a start1))
                  a)
              (if start2 (if end2 (substring b start2 end2)
                             (substring b start2))
                  b))))

(define (string-split s c)
  (let loop ((lst (string->list s)) (result '()))
    (let ((rest (memq c lst)))
      (if (not rest) (append result (list (list->string lst)))
          (loop (cdr rest)
                (append result
                        (list (list->string (list-head lst (- (length lst) (length rest)))))))))))

(define (string-take s n)
  (cond ((zero? n) s)
        ((> n 0) (list->string (list-head (string->list s) n)))
        (else (error "string-take: not supported: n=" n))))

(define (string-drop s n)
  (cond ((zero? n) s)
        ((> n 0) (list->string (list-tail (string->list s) n)))
        (else s (error "string-drop: not supported: (n s)=" (cons n s)))))

(define (drop-right lst n)
  (list-head lst (- (length lst) n)))

(define (string-drop-right s n)
  (cond ((zero? n) s)
        ((> n 0) ((compose list->string (lambda (o) (drop-right o n)) string->list) s))
        (else (error "string-drop-right: not supported: n=" n))))

(define (string-delete pred s)
  (let ((p (if (procedure? pred) pred
               (lambda (c) (not (eq? pred c))))))
    (list->string (filter p (string->list s)))))

(define (string-index s pred . rest)
  (let* ((start (and (pair? rest) (car rest)))
         (end (and start (pair? (cdr rest)) (cadr rest)))
         (pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
    (if start (error "string-index: not supported: start=" start))
    (if end (error "string-index: not supported: end=" end))
    (let loop ((lst (string->list s)) (i 0))
      (if (null? lst) #f
          (if (pred (car lst)) i
              (loop (cdr lst) (1+ i)))))))

(define (string-rindex s pred . rest)
  (let* ((start (and (pair? rest) (car rest)))
         (end (and start (pair? (cdr rest)) (cadr rest)))
         (pred (if (char? pred) (lambda (c) (eq? c pred)) pred)))
    (if start (error "string-rindex: not supported: start=" start))
    (if end (error "string-rindex: not supported: end=" end))
    (let loop ((lst (reverse (string->list s))) (i (1- (string-length s))))
      (if (null? lst) #f
          (if (pred (car lst)) i
              (loop (cdr lst) (1- i)))))))

(define reverse-list->string (compose list->string reverse))

(define substring/copy substring)
(define substring/shared substring)

(define string-null? (compose null? string->list))

(define (string-fold cons' nil' s . rest)
  (let* ((start (and (pair? rest) (car rest)))
         (end (and start (pair? (cdr rest)) (cadr rest))))
    (if start (error "string-fold: not supported: start=" start))
    (if end (error "string-fold: not supported: end=" end))
    (let loop ((lst (string->list s)) (prev nil'))
      (if (null? lst) prev
          (loop (cdr lst) (cons' (car lst) prev))))))

(define (string-fold-right cons' nil' s . rest)
  (let* ((start (and (pair? rest) (car rest)))
         (end (and start (pair? (cdr rest)) (cadr rest))))
    (if start (error "string-fold-right: not supported: start=" start))
    (if end (error "string-fold-right: not supported: end=" end))
    (let loop ((lst (reverse (string->list s))) (prev nil'))
      (if (null? lst) prev
          (loop (cdr lst) (cons' (car lst) prev))))))

(define (string-contains string needle)
  (let ((needle (string->list needle)))
    (let loop ((string (string->list string)) (i 0))
      (and (pair? string)
           (let match ((start string) (needle needle) (n i))
             (if (null? needle) i
                 (and (pair? start)
                      (if (eq? (car start) (car needle))
                          (or (match (cdr start) (cdr needle) (1+ n))
                              (loop (cdr string) (1+ i)))
                          (loop (cdr string) (1+ i))))))))))

(define (string-trim string . pred)
  (list->string
   (if (pair? pred) (error "string-trim: not supported: PRED=" pred)
       (let loop ((lst (string->list string)))
         (if (or (null? lst)
                 (not (char-whitespace? (car lst)))) lst
                 (loop (cdr lst)))))))

(define (string-trim-right string . pred)
  (list->string
   (reverse!
    (if (pair? pred) (error "string-trim-right: not supported: PRED=" pred)
        (let loop ((lst (reverse (string->list string))))
          (if (or (null? lst)
                  (not (char-whitespace? (car lst)))) lst
                  (loop (cdr lst))))))))

(define (string-trim-both string . pred)
  ((compose string-trim string-trim-right) string))

(define (string-map f string)
  (list->string (map f (string->list string))))

(define (string-replace string replace . rest)
  (let* ((start1 (and (pair? rest) (car rest)))
         (end1 (and start1 (pair? (cdr rest)) (cadr rest)))
         (start2 (and end1 (pair? (cddr rest)) (caddr rest)))
         (end2 (and start2 (pair? (cdddr rest)) (cadddr rest))))
    (if start2 (error "string-replace: not supported: START2=" start2))
    (if end2 (error "string-replace: not supported: END2=" end2))
    (list->string
     (append
      (string->list (string-take string (or start1 0)))
      (string->list replace)
      (string->list (string-drop string (or end1 (string-length string))))))))