Add string-inflection library

This commit is contained in:
Lassi Kortela 2021-08-17 12:54:21 +03:00
parent 0ecb40253a
commit 6c147feb09
2 changed files with 134 additions and 0 deletions

View File

@ -0,0 +1,63 @@
;; Copyright 2020 Lassi Kortela
;; SPDX-License-Identifier: ISC
(import (scheme base) (srfi 64) (lassik string-inflection))
(test-begin "string-inflection")
(test-equal "command-output-to-string"
(string-inflection-lisp "command_output_to_string"))
(test-equal "command_output_to_string"
(string-inflection-underscore "command--output_to-string"))
(test-equal "a_single_line"
(string-inflection-underscore "ASingleLine"))
(test-equal '("PHP" "Mode")
(string-inflection-split "PHPMode"))
(test-equal '("Ends" "With" "PHP")
(string-inflection-split "EndsWithPHP"))
(test-equal '("PHP" "And" "XML" "Too")
(string-inflection-split "PHPAndXMLToo"))
(test-equal '("php" "And" "Xml" "Too")
(string-inflection-split "phpAndXmlToo"))
;; This one does not have the expected split.
(test-equal '("PH" "Pand" "XM" "Ltoo")
(string-inflection-split "PHPandXMLtoo"))
(test-equal '("list" "take" "right")
(string-inflection-split "list-take-right"))
(test-equal '("list" "null" "?")
(string-inflection-split "list-null?"))
(test-equal '("string" "=" "?")
(string-inflection-split "string=?"))
(test-equal '("string" "ci" "<=" "?")
(string-inflection-split "string-ci<=?"))
(test-equal '("what" "happened" "?" "!")
(string-inflection-split "what-happened?!"))
(test-equal '()
(string-inflection-split ""))
(test-equal ""
(string-inflection-caps-upper ""))
(test-equal "FooBarBaz"
(string-inflection-caps-upper "foo-bar-baz"))
(test-equal "fooBarBaz"
(string-inflection-caps-lower "foo-bar-baz"))
(test-equal "XmlToJson"
(string-inflection-caps-upper "XML-to-JSON"))
(test-end "string-inflection")

string-inflection.sld Normal file
View File

@ -0,0 +1,71 @@
;; 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))))))))