src/utils.lisp

   1 (in-package :parenscript)
   2
   3 (defun string-join (strings separator)
   4   (format nil "~{~}" (format nil "~~a~~^~a" separator) strings))
   5
   6 (defun val-to-string (val)
   7   (if (symbolp val)
   8       (string-downcase (symbol-name val))
   9       (princ-to-string val)))
  10
  11 (defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
  12   (do ((len (length string))
  13        (i 0 (1+ i))
  14        (last 0)
  15        res)
  16       ((= i len)
  17        (let ((split (if (> i last)
  18                      (cons (subseq string last i) res)
  19                      res)))
  20          (nreverse (if remove-empty-subseqs
  21                        (delete "" split :test #'string-equal)
  22                        split))))
  23     (when (member (char string i) separators)
  24       (push (subseq string last i) res)
  25       (when keep-separators (push (string (char string i)) res))
  26       (setf last (1+ i)))))
  27
  28 (defparameter *special-chars*
  29   '((#\! . "Bang")
  30     (#\? . "What")
  31     (#\# . "Hash")
  32     (#\@ . "At")
  33     (#\% . "Percent")
  34     (#\+ . "Plus")
  35     (#\* . "Star")
  36     (#\/ . "Slash")))
  37
  38 ;;; Parenscript-style symbol -> Javascript-style symbol
  39
  40 (defun constant-string-p (string)
  41   (let ((len (length string))
  42         (constant-chars '(#\+ #\*)))
  43     (and (> len 2)
  44          (member (char string 0) constant-chars)
  45          (member (char string (1- len)) constant-chars))))
  46
  47 (defun first-uppercase-p (string)
  48   (and (> (length string) 1)
  49        (member (char string 0) '(#\+ #\*))))
  50
  51 (defun untouchable-string-p (string)
  52   (and (> (length string) 1)
  53        (char= #\: (char string 0))))
  54
  55 (defun symbol-to-js (symbol)
  56   "Given a Lisp symbol or string, produces to a valid JavaScript
  57 identifier by following transformation heuristics case conversion. For
  58 example, paren-script becomes parenScript, *some-global* becomes
  59 SOMEGLOBAL."
  60   (when (symbolp symbol)
  61     (setf symbol (symbol-name symbol)))
  62   (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
  63     (cond ((null symbols) "")
  64           ((= (length symbols) 1)
  65            (let (res
  66                  (do-not-touch nil)
  67                  (lowercase t)
  68                  (all-uppercase nil))
  69              (cond ((constant-string-p symbol)
  70                     (setf all-uppercase t
  71                           symbol (subseq symbol 1 (1- (length symbol)))))
  72                    ((first-uppercase-p symbol)
  73                     (setf lowercase nil
  74                           symbol (subseq symbol 1)))
  75                    ((untouchable-string-p symbol)
  76                     (setf do-not-touch t
  77                           symbol (subseq symbol 1))))
  78              (flet ((reschar (c)
  79                       (push (cond
  80                               (do-not-touch c)
  81                               ((and lowercase (not all-uppercase))
  82                                (char-downcase c))
  83                               (t (char-upcase c)))
  84                             res)
  85                       (setf lowercase t)))
  86                (dotimes (i (length symbol))
  87                  (let ((c (char symbol i)))
  88                    (cond
  89                      ((eql c #\-)
  90                       (setf lowercase (not lowercase)))
  91                      ((assoc c *special-chars*)
  92                       (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
  93                         (reschar i)))
  94                      (t (reschar c))))))
  95              (coerce (nreverse res) 'string)))
  96           (t (string-join (mapcar #'symbol-to-js symbols) "")))))
  97
  98 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ;; because the CL set-difference may not preserve order
  99   (reduce (lambda (list el) (remove el list :test test))
 100           (cons list1 list2)))