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 (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
  35 (defparameter *special-chars*
  36   '((#\! . "Bang")
  37     (#\? . "What")
  38     (#\# . "Hash")
  39     (#\@ . "At")
  40     (#\% . "Percent")
  41     (#\+ . "Plus")
  42     (#\* . "Star")
  43     (#\/ . "Slash")
  44     (#\= . "Equals")))
  45
  46 ;;; Parenscript-style symbol -> Javascript-style symbol
  47
  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)
  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."
  68   (when (symbolp symbol)
  69     (setf symbol (symbol-name symbol)))
  70   (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
  71     (cond ((null symbols) "")
  72           ((= (length symbols) 1)
  73            (let (res
  74                  (do-not-touch nil)
  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)))
  83                    ((untouchable-string-p symbol)
  84                     (setf do-not-touch t
  85                           symbol (subseq symbol 1))))
  86              (flet ((reschar (c)
  87                       (push (cond
  88                               (do-not-touch c)
  89                               ((and lowercase (not all-uppercase))
  90                                (char-downcase c))
  91                               (t (char-upcase c)))
  92                             res)
  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) "")))))
 105
 106 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ;; because the CL set-difference may not preserve order
 107   (reduce (lambda (list el) (remove el list :test test))
 108           (cons list1 list2)))