| 1 | (in-package :parenscript) |
| 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 | |
| 11 | (defun list-to-string (list) |
| 12 | (with-output-to-string (str) |
| 13 | (dolist (el list) |
| 14 | (write-string el str)))) |
| 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 | |
| 46 | (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil)) |
| 47 | (do ((len (length string)) |
| 48 | (i 0 (1+ i)) |
| 49 | (last 0) |
| 50 | res) |
| 51 | ((= i len) |
| 52 | (let ((split (if (> i last) |
| 53 | (cons (subseq string last i) res) |
| 54 | res))) |
| 55 | (nreverse (if remove-empty-subseqs |
| 56 | (delete "" split :test #'string-equal) |
| 57 | split)))) |
| 58 | (when (member (char string i) separators) |
| 59 | (push (subseq string last i) res) |
| 60 | (when keep-separators (push (string (char string i)) res)) |
| 61 | (setf last (1+ i))))) |
| 62 | |
| 63 | (defparameter *special-chars* |
| 64 | '((#\! . "Bang") |
| 65 | (#\? . "What") |
| 66 | (#\# . "Hash") |
| 67 | (#\@ . "At") |
| 68 | (#\% . "Percent") |
| 69 | (#\+ . "Plus") |
| 70 | (#\* . "Star") |
| 71 | (#\/ . "Slash"))) |
| 72 | |
| 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))) |
| 99 | (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t))) |
| 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))) |
| 133 | (t (string-join (mapcar #'symbol-to-js symbols) ""))))) |
| 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)))) |
| 144 | #'identity)) |