Commit | Line | Data |
---|---|---|
cf4cbdbd | 1 | (in-package "PARENSCRIPT") |
8e198a08 | 2 | |
c4ad06ac VS |
3 | (defun string-join (strings separator) |
4 | (format nil "~{~}" (format nil "~~a~~^~a" separator) strings)) | |
8e198a08 MB |
5 | |
6 | (defun val-to-string (val) | |
c4ad06ac VS |
7 | (if (symbolp val) |
8 | (string-downcase (symbol-name val)) | |
9 | (princ-to-string val))) | |
8e198a08 | 10 | |
e0f0d152 | 11 | (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil)) |
8e198a08 MB |
12 | (do ((len (length string)) |
13 | (i 0 (1+ i)) | |
14 | (last 0) | |
15 | res) | |
16 | ((= i len) | |
e0f0d152 | 17 | (let ((split (if (> i last) |
b508414b TC |
18 | (cons (subseq string last i) res) |
19 | res))) | |
e0f0d152 VS |
20 | (nreverse (if remove-empty-subseqs |
21 | (delete "" split :test #'string-equal) | |
22 | split)))) | |
8e198a08 MB |
23 | (when (member (char string i) separators) |
24 | (push (subseq string last i) res) | |
e0f0d152 | 25 | (when keep-separators (push (string (char string i)) res)) |
c67704f3 AL |
26 | (setf last (1+ i))))) |
27 | ||
cc4f1551 RD |
28 | (defparameter *special-chars* |
29 | '((#\! . "Bang") | |
30 | (#\? . "What") | |
31 | (#\# . "Hash") | |
32 | (#\@ . "At") | |
33 | (#\% . "Percent") | |
34 | (#\+ . "Plus") | |
35 | (#\* . "Star") | |
93e99720 VS |
36 | (#\/ . "Slash") |
37 | (#\= . "Equals"))) | |
c67704f3 | 38 | |
cc4f1551 RD |
39 | ;;; Parenscript-style symbol -> Javascript-style symbol |
40 | ||
cc4f1551 RD |
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 | ||
6274a448 | 56 | (defun symbol-to-js-string (symbol) |
c4ad06ac VS |
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." | |
cc4f1551 RD |
61 | (when (symbolp symbol) |
62 | (setf symbol (symbol-name symbol))) | |
e0f0d152 | 63 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
cc4f1551 | 64 | (cond ((null symbols) "") |
b508414b TC |
65 | ((= (length symbols) 1) |
66 | (let (res | |
cc4f1551 | 67 | (do-not-touch nil) |
b508414b TC |
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))) | |
cc4f1551 RD |
76 | ((untouchable-string-p symbol) |
77 | (setf do-not-touch t | |
78 | symbol (subseq symbol 1)))) | |
b508414b TC |
79 | (flet ((reschar (c) |
80 | (push (cond | |
cc4f1551 RD |
81 | (do-not-touch c) |
82 | ((and lowercase (not all-uppercase)) | |
83 | (char-downcase c)) | |
84 | (t (char-upcase c))) | |
85 | res) | |
b508414b TC |
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))) | |
6274a448 | 97 | (t (string-join (mapcar #'symbol-to-js-string symbols) ""))))) |
46f794a4 | 98 | |
45c9f9c2 | 99 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order |
cdf9ab0e | 100 | (reduce (lambda (list el) (remove el list :test test)) |
45c9f9c2 | 101 | (cons list1 list2))) |
cf4cbdbd VS |
102 | |
103 | (defun flatten (x &optional acc) | |
104 | (cond ((null x) acc) | |
105 | ((atom x) (cons x acc)) | |
0ce67a33 | 106 | (t (flatten (car x) (flatten (cdr x) acc))))) |
09a3438e VS |
107 | |
108 | (defmacro aif (test-form then-form &optional else-form) | |
109 | `(let ((it ,test-form)) | |
110 | (if it ,then-form ,else-form))) | |
111 | ||
112 | (defmacro once-only ((&rest names) &body body) ;; the version from PCL | |
113 | (let ((gensyms (loop for nil in names collect (gensym)))) | |
114 | `(let (,@(loop for g in gensyms collect `(,g (gensym)))) | |
115 | `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) | |
116 | ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) | |
117 | ,@body))))) |