Commit | Line | Data |
---|---|---|
97eb9b75 | 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 | ||
30a9b64a VS |
28 | (defun concat-constant-strings (list) |
29 | (reverse (reduce (lambda (optimized-list next-obj) | |
30 | (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list))) | |
31 | (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list)) | |
32 | (cons next-obj optimized-list))) | |
33 | (cons () list)))) | |
34 | ||
cc4f1551 RD |
35 | (defparameter *special-chars* |
36 | '((#\! . "Bang") | |
37 | (#\? . "What") | |
38 | (#\# . "Hash") | |
39 | (#\@ . "At") | |
40 | (#\% . "Percent") | |
41 | (#\+ . "Plus") | |
42 | (#\* . "Star") | |
93e99720 VS |
43 | (#\/ . "Slash") |
44 | (#\= . "Equals"))) | |
c67704f3 | 45 | |
cc4f1551 RD |
46 | ;;; Parenscript-style symbol -> Javascript-style symbol |
47 | ||
cc4f1551 RD |
48 | (defun constant-string-p (string) |
49 | (let ((len (length string)) | |
50 | (constant-chars '(#\+ #\*))) | |
51 | (and (> len 2) | |
52 | (member (char string 0) constant-chars) | |
53 | (member (char string (1- len)) constant-chars)))) | |
54 | ||
55 | (defun first-uppercase-p (string) | |
56 | (and (> (length string) 1) | |
57 | (member (char string 0) '(#\+ #\*)))) | |
58 | ||
59 | (defun untouchable-string-p (string) | |
60 | (and (> (length string) 1) | |
61 | (char= #\: (char string 0)))) | |
62 | ||
63 | (defun symbol-to-js (symbol) | |
c4ad06ac VS |
64 | "Given a Lisp symbol or string, produces to a valid JavaScript |
65 | identifier by following transformation heuristics case conversion. For | |
66 | example, paren-script becomes parenScript, *some-global* becomes | |
67 | SOMEGLOBAL." | |
cc4f1551 RD |
68 | (when (symbolp symbol) |
69 | (setf symbol (symbol-name symbol))) | |
e0f0d152 | 70 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
cc4f1551 | 71 | (cond ((null symbols) "") |
b508414b TC |
72 | ((= (length symbols) 1) |
73 | (let (res | |
cc4f1551 | 74 | (do-not-touch nil) |
b508414b TC |
75 | (lowercase t) |
76 | (all-uppercase nil)) | |
77 | (cond ((constant-string-p symbol) | |
78 | (setf all-uppercase t | |
79 | symbol (subseq symbol 1 (1- (length symbol))))) | |
80 | ((first-uppercase-p symbol) | |
81 | (setf lowercase nil | |
82 | symbol (subseq symbol 1))) | |
cc4f1551 RD |
83 | ((untouchable-string-p symbol) |
84 | (setf do-not-touch t | |
85 | symbol (subseq symbol 1)))) | |
b508414b TC |
86 | (flet ((reschar (c) |
87 | (push (cond | |
cc4f1551 RD |
88 | (do-not-touch c) |
89 | ((and lowercase (not all-uppercase)) | |
90 | (char-downcase c)) | |
91 | (t (char-upcase c))) | |
92 | res) | |
b508414b TC |
93 | (setf lowercase t))) |
94 | (dotimes (i (length symbol)) | |
95 | (let ((c (char symbol i))) | |
96 | (cond | |
97 | ((eql c #\-) | |
98 | (setf lowercase (not lowercase))) | |
99 | ((assoc c *special-chars*) | |
100 | (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list)) | |
101 | (reschar i))) | |
102 | (t (reschar c)))))) | |
103 | (coerce (nreverse res) 'string))) | |
104 | (t (string-join (mapcar #'symbol-to-js symbols) ""))))) | |
46f794a4 | 105 | |
45c9f9c2 | 106 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order |
cdf9ab0e | 107 | (reduce (lambda (list el) (remove el list :test test)) |
45c9f9c2 | 108 | (cons list1 list2))) |