72 lines
3.1 KiB

;; Copyright 2020 Lassi Kortela
;; SPDX-License-Identifier: ISC
;; The algorithm is based on the Emacs Lisp string-inflection package
;; by akicho8, but rewritten to use recursion instead of regular
;; expressions and expanded to recognize special characters in Lisp.
(define-library (lassik string-inflection)
(export string-inflection-split
(import (scheme base) (scheme char))
(define (string-inflection-split str)
(define (char-alphanumeric? char)
(or (char-alphabetic? char) (char-numeric? char)))
(define (split-off run runs)
(if (null? run) runs (cons (list->string (reverse run)) runs)))
(let loop ((runs '()) (run '()) (chars (string->list str)))
(if (null? chars) (reverse (split-off run runs))
(let ((char (car chars)))
(cond ((or (char=? #\- char) (char=? #\_ char))
(loop (split-off run runs) '() (cdr chars)))
((or (char=? #\! char) (char=? #\? char))
(loop (cons (string char) (split-off run runs))
'() (cdr chars)))
((and (not (null? run))
(or (and (char-upper-case? char)
(not (char-upper-case? (car run))))
(not (eqv? (char-alphanumeric? char)
(char-alphanumeric? (car run))))))
(loop (split-off run runs) (list char) (cdr chars)))
((and (not (char-upper-case? char))
(not (null? run))
(not (null? (cdr run)))
(char-upper-case? (car run))
(char-upper-case? (cadr run)))
(loop (split-off (cdr run) runs)
(list char (car run))
(cdr chars)))
(loop runs (cons char run) (cdr chars))))))))
(define (string-titlecase str)
(string-append (string (char-upcase (string-ref str 0)))
(string-downcase (substring str 1 (string-length str)))))
(define (join-between between runs)
(if (null? runs) ""
(let loop ((so-far (car runs)) (runs (cdr runs)))
(if (null? runs) so-far
(loop (string-append so-far between (car runs))
(cdr runs))))))
(define (string-inflection-lisp str)
(join-between "-" (string-inflection-split str)))
(define (string-inflection-underscore str)
(string-downcase (join-between "_" (string-inflection-split str))))
(define (string-inflection-caps-upper str)
(apply string-append
(map string-titlecase (string-inflection-split str))))
(define (string-inflection-caps-lower str)
(let ((runs (string-inflection-split str)))
(apply string-append (cons (string-downcase (car runs))
(map string-titlecase (cdr runs))))))))