-(in-package :js)
-
-(defun list-join (list elt)
- (let (res)
- (dolist (i list)
- (push i res)
- (push elt res))
- (pop res)
- (nreverse res)))
-
-;;; wie herrlich effizient
-(defun list-to-string (list)
- (reduce #'(lambda (str1 &optional (str2 ""))
- (concatenate 'string str1 str2))
- list))
-
-(defun append-to-last (form elt)
- (cond ((stringp form)
- (concatenate 'string form elt))
- ((consp form)
- (let ((last (last form)))
- (if (stringp (car last))
- (rplaca last (concatenate 'string (car last) elt))
- (append-to-last (car last) elt))
- form))
- (t (error "unsupported form ~S" form))))
-
-(defun prepend-to-first (form elt)
- (cond ((stringp form)
- (concatenate 'string elt form))
- ((consp form)
- (let ((first (first form)))
- (if (stringp first)
- (rplaca form (concatenate 'string elt first))
- (prepend-to-first first elt))
- form))
- (t (error "unsupported form ~S" form))))
-
-(defun string-join (strings elt)
- (list-to-string (list-join strings elt)))
-
-(defun val-to-string (val)
- (cond ((stringp val) val)
- ((symbolp val) (string-downcase (symbol-name val)))
- (t (princ-to-string val))))
-
-(defun string-split (string separators)
- (do ((len (length string))
- (i 0 (1+ i))
- (last 0)
- res)
- ((= i len)
- (nreverse (if (> i last)
- (cons (subseq string last i) res)
- res)))
- (when (member (char string i) separators)
- (push (subseq string last i) res)
- (setf last (1+ i)))))
-
-(defun compile-parenscript-file-to-string (source-file &key (log-stream nil) (comment nil))
- "Compile a parenscript file to a javascript string. (in-package ...) forms
-behave as expected and all other forms are evaluated. If the result of the
-evaluation is not nil tehn it's compiled with js:js* and written to the output."
- (with-output-to-string (output)
- (with-open-file (input source-file :direction :input)
- (flet ((read-form ()
- (read input nil))
- (log-message (&rest args)
- (when log-stream
- (apply #'format log-stream args))))
- (let ((saved-package *package*))
- (unwind-protect
- (loop for form = (read-form)
- while form do
- (if (or (not (listp form))
- (not (eq (car form) 'cl:in-package)))
- (progn
- (log-message "Processing form:~%~S~%" form)
- (when comment
- (princ "/*" output)
- (print form output)
- (terpri output)
- (princ "*/" output)
- (terpri output))
- (setf form (eval form))
- (log-message "After evaluation:~%~S~%" form)
- (when form
- (let ((compiled (js:js* form)))
- (log-message "Compiled into:~%~A~%~%" compiled)
- (write-string compiled output)
- (terpri output)
- (terpri output))))
- (when (and (listp form)
- (eq (car form) 'cl:in-package))
- (log-message "Setting package to: ~S~%" (cadr form))
- (setf *package* (find-package (cadr form))))))
- (setf *package* saved-package)))))))
-
-(defun compile-parenscript-file (source-file &key destination-file (log-stream nil) (comment nil))
- "Compile a parenscript file to a javascript file with
-compile-parenscript-file-to-string. When DESTINATION-FILE is omitted,
-then it will be named the same as the SOURCE-FILE but with js extension."
- (unless destination-file
- (setf destination-file (merge-pathnames (make-pathname :type "js")
- source-file)))
- (with-open-file (output destination-file :if-exists :supersede :direction :output)
- (write-string (compile-parenscript-file-to-string source-file :log-stream log-stream :comment comment) output)))
-
-
+(in-package :parenscript)
+
+(defun string-join (strings separator)
+ (format nil "~{~}" (format nil "~~a~~^~a" separator) strings))
+
+(defun val-to-string (val)
+ (if (symbolp val)
+ (string-downcase (symbol-name val))
+ (princ-to-string val)))
+
+(defun string-split (string separators &key (keep-separators nil) (remove-empty-subseqs nil))
+ (do ((len (length string))
+ (i 0 (1+ i))
+ (last 0)
+ res)
+ ((= i len)
+ (let ((split (if (> i last)
+ (cons (subseq string last i) res)
+ res)))
+ (nreverse (if remove-empty-subseqs
+ (delete "" split :test #'string-equal)
+ split))))
+ (when (member (char string i) separators)
+ (push (subseq string last i) res)
+ (when keep-separators (push (string (char string i)) res))
+ (setf last (1+ i)))))
+
+(defun concat-constant-strings (list)
+ (reverse (reduce (lambda (optimized-list next-obj)
+ (if (and (or (numberp next-obj) (stringp next-obj)) (stringp (car optimized-list)))
+ (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
+ (cons next-obj optimized-list)))
+ (cons () list))))
+
+(defparameter *special-chars*
+ '((#\! . "Bang")
+ (#\? . "What")
+ (#\# . "Hash")
+ (#\@ . "At")
+ (#\% . "Percent")
+ (#\+ . "Plus")
+ (#\* . "Star")
+ (#\/ . "Slash")
+ (#\= . "Equals")))
+
+;;; Parenscript-style symbol -> Javascript-style symbol
+
+(defun constant-string-p (string)
+ (let ((len (length string))
+ (constant-chars '(#\+ #\*)))
+ (and (> len 2)
+ (member (char string 0) constant-chars)
+ (member (char string (1- len)) constant-chars))))
+
+(defun first-uppercase-p (string)
+ (and (> (length string) 1)
+ (member (char string 0) '(#\+ #\*))))
+
+(defun untouchable-string-p (string)
+ (and (> (length string) 1)
+ (char= #\: (char string 0))))
+
+(defun symbol-to-js (symbol)
+ "Given a Lisp symbol or string, produces to a valid JavaScript
+identifier by following transformation heuristics case conversion. For
+example, paren-script becomes parenScript, *some-global* becomes
+SOMEGLOBAL."
+ (when (symbolp symbol)
+ (setf symbol (symbol-name symbol)))
+ (let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
+ (cond ((null symbols) "")
+ ((= (length symbols) 1)
+ (let (res
+ (do-not-touch nil)
+ (lowercase t)
+ (all-uppercase nil))
+ (cond ((constant-string-p symbol)
+ (setf all-uppercase t
+ symbol (subseq symbol 1 (1- (length symbol)))))
+ ((first-uppercase-p symbol)
+ (setf lowercase nil
+ symbol (subseq symbol 1)))
+ ((untouchable-string-p symbol)
+ (setf do-not-touch t
+ symbol (subseq symbol 1))))
+ (flet ((reschar (c)
+ (push (cond
+ (do-not-touch c)
+ ((and lowercase (not all-uppercase))
+ (char-downcase c))
+ (t (char-upcase c)))
+ res)
+ (setf lowercase t)))
+ (dotimes (i (length symbol))
+ (let ((c (char symbol i)))
+ (cond
+ ((eql c #\-)
+ (setf lowercase (not lowercase)))
+ ((assoc c *special-chars*)
+ (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
+ (reschar i)))
+ (t (reschar c))))))
+ (coerce (nreverse res) 'string)))
+ (t (string-join (mapcar #'symbol-to-js symbols) "")))))
+
+(defun ordered-set-difference (list1 list2 &key (test #'eql)) ;; because the CL set-difference may not preserve order
+ (reduce (lambda (list el) (remove el list :test test))
+ (cons list1 list2)))
\ No newline at end of file
HCoop / clinton / parenscript.git / blobdiff