-(in-package :parenscript)
-
-(defun list-join (list elt)
- (let (res)
- (dolist (i list)
- (push i res)
- (push elt res))
- (pop res)
- (nreverse res)))
-
-(defun list-to-string (list)
- (with-output-to-string (str)
- (dolist (el list)
- (write-string el str))))
-
-(defun append-to-last (form elt)
- (cond ((stringp form)
- (concatenate 'string form elt))
- ((consp form)
- (let ((last (last form)))
- (if (stringp (car last))
- (rplaca last (concatenate 'string (car last) elt))
- (append-to-last (car last) elt))
- form))
- (t (error "unsupported form ~S" form))))
-
-(defun prepend-to-first (form elt)
- (cond ((stringp form)
- (concatenate 'string elt form))
- ((consp form)
- (let ((first (first form)))
- (if (stringp first)
- (rplaca form (concatenate 'string elt first))
- (prepend-to-first first elt))
- form))
- (t (error "unsupported form ~S" form))))
-
-(defun string-join (strings elt)
- (list-to-string (list-join strings elt)))
-
-(defun val-to-string (val)
- (cond ((stringp val) val)
- ((symbolp val) (string-downcase (symbol-name val)))
- (t (princ-to-string val))))
-
-(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)
- (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))
\ No newline at end of file
+(in-package "PARENSCRIPT")
+
+(defun string-join (strings separator)
+ (format nil "~{~}" (format nil "~~a~~^~a" separator) strings))
+
+(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)
+ (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")
+ (#\= . "Equals")
+ (#\: . "Colon")))
+
+;;; Parenscript-style symbol -> Javascript-style symbol
+
+(defun special-symbol-delimiter? (char)
+ (or (eql char #\+) (eql char #\*)))
+
+(defun special-symbol-name? (string)
+ (nth-value 1 (cl-ppcre:scan-to-strings "[\\*|\\+](.*)[\\*|\\+]([0-9]*)" string)))
+
+(defun first-uppercase-p (string)
+ (and (> (length string) 1)
+ (special-symbol-delimiter? (char string 0))))
+
+(defun untouchable-string-p (string)
+ (and (> (length string) 1)
+ (char= #\: (char string 0))))
+
+(defun symbol-name-to-js-string (symbol)
+ "Given a Lisp symbol or string, produces to a valid JavaScript
+identifier by following transformation heuristics case conversion. For
+example, paren-script becomes parenScript, *some-global* becomes
+SOMEGLOBAL."
+ (let ((sym-name (string symbol))
+ res
+ (do-not-touch nil)
+ (lowercase t)
+ (all-uppercase nil))
+ (when (and (not (eq symbol '[]))
+ (find-if (lambda (x) (member x '(#\. #\[ #\]))) sym-name))
+ (warn "Symbol ~A contains one of '.[]' - this compound naming convention is no longer supported by Parenscript!"
+ symbol))
+ (cond ((special-symbol-name? sym-name)
+ (setf all-uppercase t
+ sym-name (let ((parts (special-symbol-name? sym-name)))
+ (concatenate 'string (aref parts 0) (aref parts 1)))))
+ ((first-uppercase-p sym-name)
+ (setf lowercase nil
+ sym-name (subseq sym-name 1)))
+ ((untouchable-string-p sym-name)
+ (setf do-not-touch t
+ sym-name (subseq sym-name 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 sym-name))
+ (let ((c (char sym-name 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)))
+
+(defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
+ (reduce (lambda (list el) (remove el list :test test))
+ (cons list1 list2)))
+
+(defmacro once-only ((&rest names) &body body) ;; the version from PCL
+ (let ((gensyms (loop for nil in names collect (gensym))))
+ `(let (,@(loop for g in gensyms collect `(,g (gensym))))
+ `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
+ ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
+ ,@body)))))
HCoop / clinton / parenscript.git / blobdiff