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 string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
   7   (do ((len (length string))
   8        (i 0 (1+ i))
   9        (last 0)
  10        res)
  11       ((= i len)
  12        (let ((split (if (> i last)
  13                      (cons (subseq string last i) res)
  14                      res)))
  15          (nreverse (if remove-empty-subseqs
  16                        (delete "" split :test #'string-equal)
  17                        split))))
  18     (when (member (char string i) separators)
  19       (push (subseq string last i) res)
  20       (when keep-separators (push (string (char string i)) res))
  21       (setf last (1+ i)))))
  22
  23 (defparameter *special-chars*
  24   '((#\! . "Bang")
  25     (#\? . "What")
  26     (#\# . "Hash")
  27     (#\@ . "At")
  28     (#\% . "Percent")
  29     (#\+ . "Plus")
  30     (#\* . "Star")
  31     (#\/ . "Slash")
  32     (#\= . "Equals")
  33     (#\: . "Colon")))
  34
  35 ;;; Parenscript-style symbol -> Javascript-style symbol
  36
  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
  52 (defun symbol-name-to-js-string (symbol)
  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."
  57   (when (symbolp symbol)
  58     (setf symbol (symbol-name symbol)))
  59   (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
  60     (cond ((null symbols) "")
  61           ((= (length symbols) 1)
  62            (let (res
  63                  (do-not-touch nil)
  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)))
  72                    ((untouchable-string-p symbol)
  73                     (setf do-not-touch t
  74                           symbol (subseq symbol 1))))
  75              (flet ((reschar (c)
  76                       (push (cond
  77                               (do-not-touch c)
  78                               ((and lowercase (not all-uppercase))
  79                                (char-downcase c))
  80                               (t (char-upcase c)))
  81                             res)
  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)))
  93           (t (string-join (mapcar #'symbol-name-to-js-string symbols) "")))))
  94
  95 (defun ordered-set-difference (list1 list2 &key (test #'eql)) ; because the CL set-difference may not preserve order
  96   (reduce (lambda (list el) (remove el list :test test))
  97           (cons list1 list2)))
  98
  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)))))