Fixed type bug with printing slot-value with obj/slot being a non-list.

[clinton/parenscript.git] / src / utils.lisp

diff --git a/src/utils.lisp b/src/utils.lisp
index 227d0ba..ed78b81 100644 (file)
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -43,17 +43,106 @@
        ((symbolp val) (string-downcase (symbol-name val)))
        (t (princ-to-string val))))
 
-(defun string-split (string separators)
+(defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
   (do ((len (length string))
        (i 0 (1+ i))
        (last 0)
        res)
       ((= i len)
-       (nreverse (if (> i last)
+       (let ((split (if (> i last)
                     (cons (subseq string last i) res)
                     res)))
+         (nreverse (if remove-empty-subseqs
+                       (delete "" split :test #'string-equal)
+                       split))))
     (when (member (char string i) separators)
       (push (subseq string last i) res)
+      (when keep-separators (push (string (char string i)) res))
       (setf last (1+ i)))))
 
+(defparameter *special-chars*
+  '((#\! . "Bang")
+    (#\? . "What")
+    (#\# . "Hash")
+    (#\@ . "At")
+    (#\% . "Percent")
+    (#\+ . "Plus")
+    (#\* . "Star")
+    (#\/ . "Slash")))
 
+
+;;; Parenscript-style symbol -> Javascript-style symbol
+
+(defun string-chars (string)
+  (coerce string 'list))
+
+(defun constant-string-p (string)
+  (let ((len (length string))
+        (constant-chars '(#\+ #\*)))
+    (and (> len 2)
+         (member (char string 0) constant-chars)
+         (member (char string (1- len)) constant-chars))))
+
+(defun first-uppercase-p (string)
+  (and (> (length string) 1)
+       (member (char string 0) '(#\+ #\*))))
+
+(defun untouchable-string-p (string)
+  (and (> (length string) 1)
+       (char= #\: (char string 0))))
+
+(defun symbol-to-js (symbol)
+  "Changes a Parenscript-style symbol or string and converts it to a Javascript-style string.
+For example, paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
+  (when (symbolp symbol)
+    (setf symbol (symbol-name symbol)))
+  (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
+    (cond ((null symbols) "")
+         ((= (length symbols) 1)
+          (let (res
+                 (do-not-touch nil)
+                (lowercase t)
+                (all-uppercase nil))
+            (cond ((constant-string-p symbol)
+                   (setf all-uppercase t
+                         symbol (subseq symbol 1 (1- (length symbol)))))
+                  ((first-uppercase-p symbol)
+                   (setf lowercase nil
+                         symbol (subseq symbol 1)))
+                   ((untouchable-string-p symbol)
+                    (setf do-not-touch t
+                          symbol (subseq symbol 1))))
+            (flet ((reschar (c)
+                     (push (cond
+                              (do-not-touch c)
+                              ((and lowercase (not all-uppercase))
+                               (char-downcase c))
+                              (t (char-upcase c)))
+                            res)
+                     (setf lowercase t)))
+              (dotimes (i (length symbol))
+                (let ((c (char symbol i)))
+                  (cond
+                    ((eql c #\-)
+                     (setf lowercase (not lowercase)))
+                    ((assoc c *special-chars*)
+                     (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
+                       (reschar i)))
+                    (t (reschar c))))))
+            (coerce (nreverse res) 'string)))
+         (t (string-join (mapcar #'symbol-to-js symbols) "")))))
+
+(defun compose (&rest fns)
+  "(funcall (compose #'x #'y #'z) 'foo) is (x (y (z 'foo)))"
+  (if fns
+      (let ((fn1 (car (last fns)))
+           (fns (butlast fns)))
+       #'(lambda (&rest args)
+           (reduce #'funcall fns 
+                   :from-end t
+                   :initial-value (apply fn1 args))))
+      #'identity))
+
+(defun ordered-set-difference (list1 list2 &key (test #'eql))
+  (reduce (lambda (list el) (remove el list :test test))
+          (cons list1 list2)))
\ No newline at end of file