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     (#\= . "Equals")))
  38
  39 ;;; Parenscript-style symbol -> Javascript-style symbol
  40
  41 (defun constant-string-p (string)
  42   (let ((len (length string))
  43         (constant-chars '(#\+ #\*)))
  44     (and (> len 2)
  45          (member (char string 0) constant-chars)
  46          (member (char string (1- len)) constant-chars))))
  47
  48 (defun first-uppercase-p (string)
  49   (and (> (length string) 1)
  50        (member (char string 0) '(#\+ #\*))))
  51
  52 (defun untouchable-string-p (string)
  53   (and (> (length string) 1)
  54        (char= #\: (char string 0))))
  55
  56 (defun symbol-to-js-string (symbol)
  57   "Given a Lisp symbol or string, produces to a valid JavaScript
  58 identifier by following transformation heuristics case conversion. For
  59 example, paren-script becomes parenScript, *some-global* becomes
  60 SOMEGLOBAL."
  61   (when (symbolp symbol)
  62     (setf symbol (symbol-name symbol)))
  63   (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
  64     (cond ((null symbols) "")
  65           ((= (length symbols) 1)
  66            (let (res
  67                  (do-not-touch nil)
  68                  (lowercase t)
  69                  (all-uppercase nil))
  70              (cond ((constant-string-p symbol)
  71                     (setf all-uppercase t
  72                           symbol (subseq symbol 1 (1- (length symbol)))))
  73                    ((first-uppercase-p symbol)
  74                     (setf lowercase nil
  75                           symbol (subseq symbol 1)))
  76                    ((untouchable-string-p symbol)
  77                     (setf do-not-touch t
  78                           symbol (subseq symbol 1))))
  79              (flet ((reschar (c)
  80                       (push (cond
  81                               (do-not-touch c)
  82                               ((and lowercase (not all-uppercase))
  83                                (char-downcase c))
  84                               (t (char-upcase c)))
  85                             res)
  86                       (setf lowercase t)))
  87                (dotimes (i (length symbol))
  88                  (let ((c (char symbol i)))
  89                    (cond
  90                      ((eql c #\-)
  91                       (setf lowercase (not lowercase)))
  92                      ((assoc c *special-chars*)
  93                       (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
  94                         (reschar i)))
  95                      (t (reschar c))))))
  96              (coerce (nreverse res) 'string)))
  97           (t (string-join (mapcar #'symbol-to-js-string symbols) "")))))
  98
  99 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
 100   (reduce (lambda (list el) (remove el list :test test))
 101           (cons list1 list2)))
 102
 103 (defun flatten (x &optional acc)
 104   (cond ((null x) acc)
 105         ((atom x) (cons x acc))
 106         (t (flatten (car x) (flatten (cdr x) acc)))))