X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/97eb9b754ae4cb7cae36937de3ddbc363ddd37c0..a805b30df61ee5948d349b25a1d7f100929a83a4:/src/utils.lisp

diff --git a/src/utils.lisp b/src/utils.lisp
index 227d0ba..ed78b81 100644
--- 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