Commit | Line | Data |
---|---|---|
97eb9b75 | 1 | (in-package :parenscript) |
8e198a08 MB |
2 | |
3 | (defun list-join (list elt) | |
4 | (let (res) | |
5 | (dolist (i list) | |
6 | (push i res) | |
7 | (push elt res)) | |
8 | (pop res) | |
9 | (nreverse res))) | |
10 | ||
8e198a08 | 11 | (defun list-to-string (list) |
4019ed1c AL |
12 | (with-output-to-string (str) |
13 | (dolist (el list) | |
14 | (write-string el str)))) | |
8e198a08 MB |
15 | |
16 | (defun append-to-last (form elt) | |
17 | (cond ((stringp form) | |
18 | (concatenate 'string form elt)) | |
19 | ((consp form) | |
20 | (let ((last (last form))) | |
21 | (if (stringp (car last)) | |
22 | (rplaca last (concatenate 'string (car last) elt)) | |
23 | (append-to-last (car last) elt)) | |
24 | form)) | |
25 | (t (error "unsupported form ~S" form)))) | |
26 | ||
27 | (defun prepend-to-first (form elt) | |
28 | (cond ((stringp form) | |
29 | (concatenate 'string elt form)) | |
30 | ((consp form) | |
31 | (let ((first (first form))) | |
32 | (if (stringp first) | |
33 | (rplaca form (concatenate 'string elt first)) | |
34 | (prepend-to-first first elt)) | |
35 | form)) | |
36 | (t (error "unsupported form ~S" form)))) | |
37 | ||
38 | (defun string-join (strings elt) | |
39 | (list-to-string (list-join strings elt))) | |
40 | ||
41 | (defun val-to-string (val) | |
42 | (cond ((stringp val) val) | |
43 | ((symbolp val) (string-downcase (symbol-name val))) | |
44 | (t (princ-to-string val)))) | |
45 | ||
e0f0d152 | 46 | (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil)) |
8e198a08 MB |
47 | (do ((len (length string)) |
48 | (i 0 (1+ i)) | |
49 | (last 0) | |
50 | res) | |
51 | ((= i len) | |
e0f0d152 | 52 | (let ((split (if (> i last) |
8e198a08 MB |
53 | (cons (subseq string last i) res) |
54 | res))) | |
e0f0d152 VS |
55 | (nreverse (if remove-empty-subseqs |
56 | (delete "" split :test #'string-equal) | |
57 | split)))) | |
8e198a08 MB |
58 | (when (member (char string i) separators) |
59 | (push (subseq string last i) res) | |
e0f0d152 | 60 | (when keep-separators (push (string (char string i)) res)) |
c67704f3 AL |
61 | (setf last (1+ i))))) |
62 | ||
cc4f1551 RD |
63 | (defparameter *special-chars* |
64 | '((#\! . "Bang") | |
65 | (#\? . "What") | |
66 | (#\# . "Hash") | |
67 | (#\@ . "At") | |
68 | (#\% . "Percent") | |
69 | (#\+ . "Plus") | |
70 | (#\* . "Star") | |
71 | (#\/ . "Slash"))) | |
c67704f3 | 72 | |
cc4f1551 RD |
73 | |
74 | ;;; Parenscript-style symbol -> Javascript-style symbol | |
75 | ||
76 | (defun string-chars (string) | |
77 | (coerce string 'list)) | |
78 | ||
79 | (defun constant-string-p (string) | |
80 | (let ((len (length string)) | |
81 | (constant-chars '(#\+ #\*))) | |
82 | (and (> len 2) | |
83 | (member (char string 0) constant-chars) | |
84 | (member (char string (1- len)) constant-chars)))) | |
85 | ||
86 | (defun first-uppercase-p (string) | |
87 | (and (> (length string) 1) | |
88 | (member (char string 0) '(#\+ #\*)))) | |
89 | ||
90 | (defun untouchable-string-p (string) | |
91 | (and (> (length string) 1) | |
92 | (char= #\: (char string 0)))) | |
93 | ||
94 | (defun symbol-to-js (symbol) | |
95 | "Changes a Parenscript-style symbol or string and converts it to a Javascript-style string. | |
96 | For example, paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL." | |
97 | (when (symbolp symbol) | |
98 | (setf symbol (symbol-name symbol))) | |
e0f0d152 | 99 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
cc4f1551 RD |
100 | (cond ((null symbols) "") |
101 | ((= (length symbols) 1) | |
102 | (let (res | |
103 | (do-not-touch nil) | |
104 | (lowercase t) | |
105 | (all-uppercase nil)) | |
106 | (cond ((constant-string-p symbol) | |
107 | (setf all-uppercase t | |
108 | symbol (subseq symbol 1 (1- (length symbol))))) | |
109 | ((first-uppercase-p symbol) | |
110 | (setf lowercase nil | |
111 | symbol (subseq symbol 1))) | |
112 | ((untouchable-string-p symbol) | |
113 | (setf do-not-touch t | |
114 | symbol (subseq symbol 1)))) | |
115 | (flet ((reschar (c) | |
116 | (push (cond | |
117 | (do-not-touch c) | |
118 | ((and lowercase (not all-uppercase)) | |
119 | (char-downcase c)) | |
120 | (t (char-upcase c))) | |
121 | res) | |
122 | (setf lowercase t))) | |
123 | (dotimes (i (length symbol)) | |
124 | (let ((c (char symbol i))) | |
125 | (cond | |
126 | ((eql c #\-) | |
127 | (setf lowercase (not lowercase))) | |
128 | ((assoc c *special-chars*) | |
129 | (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list)) | |
130 | (reschar i))) | |
131 | (t (reschar c)))))) | |
132 | (coerce (nreverse res) 'string))) | |
e0f0d152 | 133 | (t (string-join (mapcar #'symbol-to-js symbols) ""))))) |
46f794a4 RD |
134 | |
135 | (defun compose (&rest fns) | |
136 | "(funcall (compose #'x #'y #'z) 'foo) is (x (y (z 'foo)))" | |
137 | (if fns | |
138 | (let ((fn1 (car (last fns))) | |
139 | (fns (butlast fns))) | |
140 | #'(lambda (&rest args) | |
141 | (reduce #'funcall fns | |
142 | :from-end t | |
143 | :initial-value (apply fn1 args)))) | |
cdf9ab0e VS |
144 | #'identity)) |
145 | ||
146 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) | |
147 | (reduce (lambda (list el) (remove el list :test test)) | |
148 | (cons list1 list2))) |