From 6c147feb097e90f162bfd776ce43202c6735a2aa Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Tue, 17 Aug 2021 12:54:21 +0300
Subject: [PATCH] Add string-inflection library

---
 string-inflection-test.scm | 63 +++++++++++++++++++++++++++++++++
 string-inflection.sld      | 71 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 134 insertions(+)
 create mode 100644 string-inflection-test.scm
 create mode 100644 string-inflection.sld

diff --git a/string-inflection-test.scm b/string-inflection-test.scm
new file mode 100644
index 0000000..62a5cd2
--- /dev/null
+++ b/string-inflection-test.scm
@@ -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")
diff --git a/string-inflection.sld b/string-inflection.sld
new file mode 100644
index 0000000..3924600
--- /dev/null
+++ b/string-inflection.sld
@@ -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
+          string-inflection-lisp
+          string-inflection-underscore
+          string-inflection-caps-upper
+          string-inflection-caps-lower)
+  (import (scheme base) (scheme char))
+  (begin
+
+    (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)))
+                    (else
+                     (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))))))))