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 | 5 | |
e0f0d152 | 6 | (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil)) |
8e198a08 MB |
7 | (do ((len (length string)) |
8 | (i 0 (1+ i)) | |
9 | (last 0) | |
10 | res) | |
11 | ((= i len) | |
e0f0d152 | 12 | (let ((split (if (> i last) |
b508414b TC |
13 | (cons (subseq string last i) res) |
14 | res))) | |
e0f0d152 VS |
15 | (nreverse (if remove-empty-subseqs |
16 | (delete "" split :test #'string-equal) | |
17 | split)))) | |
8e198a08 MB |
18 | (when (member (char string i) separators) |
19 | (push (subseq string last i) res) | |
e0f0d152 | 20 | (when keep-separators (push (string (char string i)) res)) |
c67704f3 AL |
21 | (setf last (1+ i))))) |
22 | ||
cc4f1551 RD |
23 | (defparameter *special-chars* |
24 | '((#\! . "Bang") | |
25 | (#\? . "What") | |
26 | (#\# . "Hash") | |
27 | (#\@ . "At") | |
28 | (#\% . "Percent") | |
29 | (#\+ . "Plus") | |
30 | (#\* . "Star") | |
93e99720 | 31 | (#\/ . "Slash") |
4508ae85 VS |
32 | (#\= . "Equals") |
33 | (#\: . "Colon"))) | |
c67704f3 | 34 | |
cc4f1551 RD |
35 | ;;; Parenscript-style symbol -> Javascript-style symbol |
36 | ||
cc4f1551 RD |
37 | (defun constant-string-p (string) |
38 | (let ((len (length string)) | |
39 | (constant-chars '(#\+ #\*))) | |
40 | (and (> len 2) | |
41 | (member (char string 0) constant-chars) | |
42 | (member (char string (1- len)) constant-chars)))) | |
43 | ||
44 | (defun first-uppercase-p (string) | |
45 | (and (> (length string) 1) | |
46 | (member (char string 0) '(#\+ #\*)))) | |
47 | ||
48 | (defun untouchable-string-p (string) | |
49 | (and (> (length string) 1) | |
50 | (char= #\: (char string 0)))) | |
51 | ||
dd4442b8 | 52 | (defun symbol-name-to-js-string (symbol) |
c4ad06ac VS |
53 | "Given a Lisp symbol or string, produces to a valid JavaScript |
54 | identifier by following transformation heuristics case conversion. For | |
55 | example, paren-script becomes parenScript, *some-global* becomes | |
56 | SOMEGLOBAL." | |
cc4f1551 RD |
57 | (when (symbolp symbol) |
58 | (setf symbol (symbol-name symbol))) | |
e0f0d152 | 59 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
cc4f1551 | 60 | (cond ((null symbols) "") |
b508414b TC |
61 | ((= (length symbols) 1) |
62 | (let (res | |
cc4f1551 | 63 | (do-not-touch nil) |
b508414b TC |
64 | (lowercase t) |
65 | (all-uppercase nil)) | |
66 | (cond ((constant-string-p symbol) | |
67 | (setf all-uppercase t | |
68 | symbol (subseq symbol 1 (1- (length symbol))))) | |
69 | ((first-uppercase-p symbol) | |
70 | (setf lowercase nil | |
71 | symbol (subseq symbol 1))) | |
cc4f1551 RD |
72 | ((untouchable-string-p symbol) |
73 | (setf do-not-touch t | |
74 | symbol (subseq symbol 1)))) | |
b508414b TC |
75 | (flet ((reschar (c) |
76 | (push (cond | |
cc4f1551 RD |
77 | (do-not-touch c) |
78 | ((and lowercase (not all-uppercase)) | |
79 | (char-downcase c)) | |
80 | (t (char-upcase c))) | |
81 | res) | |
b508414b TC |
82 | (setf lowercase t))) |
83 | (dotimes (i (length symbol)) | |
84 | (let ((c (char symbol i))) | |
85 | (cond | |
86 | ((eql c #\-) | |
87 | (setf lowercase (not lowercase))) | |
88 | ((assoc c *special-chars*) | |
89 | (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list)) | |
90 | (reschar i))) | |
91 | (t (reschar c)))))) | |
92 | (coerce (nreverse res) 'string))) | |
dd4442b8 | 93 | (t (string-join (mapcar #'symbol-name-to-js-string symbols) ""))))) |
46f794a4 | 94 | |
45c9f9c2 | 95 | (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order |
cdf9ab0e | 96 | (reduce (lambda (list el) (remove el list :test test)) |
45c9f9c2 | 97 | (cons list1 list2))) |
cf4cbdbd | 98 | |
618fb209 VS |
99 | (defmacro aif (test-form then-form &optional else-form) |
100 | `(let ((it ,test-form)) | |
101 | (if it ,then-form ,else-form))) | |
102 | ||
103 | (defmacro once-only ((&rest names) &body body) ;; the version from PCL | |
104 | (let ((gensyms (loop for nil in names collect (gensym)))) | |
105 | `(let (,@(loop for g in gensyms collect `(,g (gensym)))) | |
106 | `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) | |
107 | ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) | |
108 | ,@body))))) |