src/utils.lisp

   1 ;;;; -*- encoding:utf-8 -*-
   2
   3 ;;; Copyright 2005 Manuel Odendahl
   4 ;;; Copyright 2005-2006 Edward Marco Baringer
   5 ;;; Copyright 2007 Attila Lendvai
   6 ;;; Copyright 2007 Red Daly
   7 ;;; Copyright 2007-2012 Vladimir Sedach
   8 ;;; Copyright 2008 Travis Cross
   9
  10 ;;; SPDX-License-Identifier: BSD-3-Clause
  11
  12 ;;; Redistribution and use in source and binary forms, with or
  13 ;;; without modification, are permitted provided that the following
  14 ;;; conditions are met:
  15
  16 ;;; 1. Redistributions of source code must retain the above copyright
  17 ;;; notice, this list of conditions and the following disclaimer.
  18
  19 ;;; 2. Redistributions in binary form must reproduce the above
  20 ;;; copyright notice, this list of conditions and the following
  21 ;;; disclaimer in the documentation and/or other materials provided
  22 ;;; with the distribution.
  23
  24 ;;; 3. Neither the name of the copyright holder nor the names of its
  25 ;;; contributors may be used to endorse or promote products derived
  26 ;;; from this software without specific prior written permission.
  27
  28 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  29 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  30 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  31 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  32 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  33 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  34 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  35 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  36 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  37 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  38 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  39 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  40 ;;; POSSIBILITY OF SUCH DAMAGE.
  41
  42 (in-package #:parenscript)
  43
  44 (define-condition simple-style-warning (simple-warning style-warning)
  45   ())
  46
  47 (let ((cache (make-hash-table :test 'equal)))
  48   (defun encode-js-identifier (identifier)
  49     "Given a string, produces to a valid JavaScript identifier by
  50 following transformation heuristics case conversion. For example,
  51 paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
  52     (when (and (not (string= identifier "[]"))
  53                (find #\[ identifier))
  54       (warn 'simple-style-warning
  55             :format-control
  56             "Parenscript symbol ~A contains a literal array accessor.
  57 This compound naming convention is deprecated and will be removed!
  58 Use AREF, ELT, GETPROP, @, or CHAIN instead."
  59             :format-arguments (list identifier)))
  60     (when (find #\. identifier)
  61       (warn 'simple-style-warning
  62             :format-control
  63             "Parenscript symbol ~A contains one or more dot operators.
  64 This compound naming convention is deprecated and will be removed!
  65 Use GETPROP, @, or CHAIN instead."
  66             :format-arguments (list identifier)))
  67     (or
  68      (gethash identifier cache)
  69      (setf
  70        (gethash identifier cache)
  71        (cond
  72           ((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier)
  73             (let ((lowercase     t)
  74                   (all-uppercase nil))
  75               (acond
  76                 ((nth-value 1
  77                    (cl-ppcre:scan-to-strings
  78                     "[\\*|\\+](.+)[\\*|\\+](.*)"
  79                     identifier :sharedp t))
  80                  (setf all-uppercase t
  81                        identifier (concatenate
  82                                    'string (aref it 0) (aref it 1))))
  83                 ((and (> (length identifier) 1)
  84                       (or (eql (char identifier 0) #\+)
  85                           (eql (char identifier 0) #\*)))
  86                  (setf lowercase  nil
  87                        identifier (subseq identifier 1))))
  88               (with-output-to-string (acc)
  89                 (loop
  90                    for c across identifier
  91                    do (acond
  92                        ((eql c #\-)
  93                         (setf lowercase (not lowercase)))
  94                        ((position c "!?#@%+*/=:<>^")
  95                         (write-sequence
  96                          (aref #("bang" "what" "hash" "at" "percent"
  97                                  "plus" "star" "slash" "equals" "colon"
  98                                  "lessthan" "greaterthan" "caret")
  99                                it)
 100                          acc))
 101                        (t
 102                         (write-char
 103                          (if (and lowercase (not all-uppercase))
 104                              (char-downcase c)
 105                              (char-upcase c))
 106                          acc)
 107                         (setf lowercase t)))))))
 108           (#.(eql :invert (readtable-case
 109                            (named-readtables:find-readtable :parenscript)))
 110              (cond
 111                ((every #'upper-case-p
 112                        (remove-if-not #'alpha-char-p identifier))
 113                 (string-downcase identifier))
 114                ((every #'lower-case-p
 115                        (remove-if-not #'alpha-char-p identifier))
 116                 (string-upcase identifier))
 117                (t identifier)))
 118           (t identifier))))))
 119
 120 (defun ordered-set-difference (list1 list2 &key (test #'eql))
 121   "CL set-difference may not preserve order."
 122   (reduce (lambda (list el) (remove el list :test test))
 123           (cons list1 list2)))
 124
 125 (defun flatten (x &optional acc)
 126   (cond ((null x) acc)
 127         ((atom x) (cons x acc))
 128         (t (flatten (car x) (flatten (cdr x) acc)))))
 129
 130 (defun flatten-blocks (body)
 131   (when body
 132     (if (and (listp (car body)) (eq 'ps-js:block (caar body)))
 133         (append (flatten-blocks (cdr (car body)))
 134                 (flatten-blocks (cdr body)))
 135         (cons (car body) (flatten-blocks (cdr body))))))
 136
 137 (defun tree-find (A tree)
 138   (or (equal A tree)
 139       (when (consp tree)
 140         (loop for x on tree thereis
 141               (or (tree-find A (car x))
 142                   (unless (listp (cdr x))
 143                     (equal A (cdr x))))))))
 144
 145 (defun parse-semver (semver-string)
 146   (let ((semver-list   (cl-ppcre:split "\\." semver-string))
 147         (semver-scaled 0))
 148     (dotimes (i 3)
 149       (incf semver-scaled
 150             (* (expt 1000 (- 2 i))
 151                (parse-integer (or (nth i semver-list) "0")))))
 152     semver-scaled))
 153
 154 (defun js-target-at-least (version)
 155   (>= (parse-semver *js-target-version*) (parse-semver version)))