src/utils.lisp

   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))