| 1 | (in-package :parenscript) |
| 2 | |
| 3 | (defun string-join (strings separator) |
| 4 | (format nil "~{~}" (format nil "~~a~~^~a" separator) strings)) |
| 5 | |
| 6 | (defun val-to-string (val) |
| 7 | (if (symbolp val) |
| 8 | (string-downcase (symbol-name val)) |
| 9 | (princ-to-string val))) |
| 10 | |
| 11 | (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil)) |
| 12 | (do ((len (length string)) |
| 13 | (i 0 (1+ i)) |
| 14 | (last 0) |
| 15 | res) |
| 16 | ((= i len) |
| 17 | (let ((split (if (> i last) |
| 18 | (cons (subseq string last i) res) |
| 19 | res))) |
| 20 | (nreverse (if remove-empty-subseqs |
| 21 | (delete "" split :test #'string-equal) |
| 22 | split)))) |
| 23 | (when (member (char string i) separators) |
| 24 | (push (subseq string last i) res) |
| 25 | (when keep-separators (push (string (char string i)) res)) |
| 26 | (setf last (1+ i))))) |
| 27 | |
| 28 | (defparameter *special-chars* |
| 29 | '((#\! . "Bang") |
| 30 | (#\? . "What") |
| 31 | (#\# . "Hash") |
| 32 | (#\@ . "At") |
| 33 | (#\% . "Percent") |
| 34 | (#\+ . "Plus") |
| 35 | (#\* . "Star") |
| 36 | (#\/ . "Slash") |
| 37 | (#\= . "Equals"))) |
| 38 | |
| 39 | ;;; Parenscript-style symbol -> Javascript-style symbol |
| 40 | |
| 41 | (defun constant-string-p (string) |
| 42 | (let ((len (length string)) |
| 43 | (constant-chars '(#\+ #\*))) |
| 44 | (and (> len 2) |
| 45 | (member (char string 0) constant-chars) |
| 46 | (member (char string (1- len)) constant-chars)))) |
| 47 | |
| 48 | (defun first-uppercase-p (string) |
| 49 | (and (> (length string) 1) |
| 50 | (member (char string 0) '(#\+ #\*)))) |
| 51 | |
| 52 | (defun untouchable-string-p (string) |
| 53 | (and (> (length string) 1) |
| 54 | (char= #\: (char string 0)))) |
| 55 | |
| 56 | (defun symbol-to-js-string (symbol) |
| 57 | "Given a Lisp symbol or string, produces to a valid JavaScript |
| 58 | identifier by following transformation heuristics case conversion. For |
| 59 | example, paren-script becomes parenScript, *some-global* becomes |
| 60 | SOMEGLOBAL." |
| 61 | (when (symbolp symbol) |
| 62 | (setf symbol (symbol-name symbol))) |
| 63 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
| 64 | (cond ((null symbols) "") |
| 65 | ((= (length symbols) 1) |
| 66 | (let (res |
| 67 | (do-not-touch nil) |
| 68 | (lowercase t) |
| 69 | (all-uppercase nil)) |
| 70 | (cond ((constant-string-p symbol) |
| 71 | (setf all-uppercase t |
| 72 | symbol (subseq symbol 1 (1- (length symbol))))) |
| 73 | ((first-uppercase-p symbol) |
| 74 | (setf lowercase nil |
| 75 | symbol (subseq symbol 1))) |
| 76 | ((untouchable-string-p symbol) |
| 77 | (setf do-not-touch t |
| 78 | symbol (subseq symbol 1)))) |
| 79 | (flet ((reschar (c) |
| 80 | (push (cond |
| 81 | (do-not-touch c) |
| 82 | ((and lowercase (not all-uppercase)) |
| 83 | (char-downcase c)) |
| 84 | (t (char-upcase c))) |
| 85 | res) |
| 86 | (setf lowercase t))) |
| 87 | (dotimes (i (length symbol)) |
| 88 | (let ((c (char symbol i))) |
| 89 | (cond |
| 90 | ((eql c #\-) |
| 91 | (setf lowercase (not lowercase))) |
| 92 | ((assoc c *special-chars*) |
| 93 | (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list)) |
| 94 | (reschar i))) |
| 95 | (t (reschar c)))))) |
| 96 | (coerce (nreverse res) 'string))) |
| 97 | (t (string-join (mapcar #'symbol-to-js-string symbols) ""))))) |
| 98 | |
| 99 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order |
| 100 | (reduce (lambda (list el) (remove el list :test test)) |
| 101 | (cons list1 list2))) |