/src/com/reasonr/scriptjure.clj

  1;;; scriptjure -- a library for generating javascript from Clojure s-exprs
  2
  3;; by Allen Rohner, http://arohner.blogspot.com
  4;;                  http://www.reasonr.com  
  5;; October 7, 2009
  6
  7;; Copyright (c) Allen Rohner, 2009. All rights reserved.  The use
  8;; and distribution terms for this software are covered by the Eclipse
  9;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
 10;; which can be found in the file epl-v10.html at the root of this
 11;; distribution.  By using this software in any fashion, you are
 12;; agreeing to be bound by the terms of this license.  You must not
 13;; remove this notice, or any other, from this software.
 14
 15;; This library generates javascript from Clojure s-exprs. To use it, 
 16;; (js (fn foo [x] (var x (+ 3 5)) (return x)))
 17;;  returns a string, "function foo (x) { var x = (3 + 5); return x; }"
 18;;
 19;; See the README and the tests for more information on what is supported.
 20;; 
 21;; The library is intended to generate javascript glue code in Clojure
 22;; webapps. One day it might become useful enough to write entirely
 23;; JS libraries in clojure, but it's not there yet.
 24;;
 25;;
 26
 27(ns #^{:author "Allen Rohner"
 28       :doc "A library for generating javascript from Clojure."}
 29       com.reasonr.scriptjure
 30       (:require [clojure.string :as str])
 31       (:require [com.reasonr.string :as rstr])
 32       (:use clojure.walk))
 33
 34(defn- throwf [& message]
 35  (throw (Exception. (apply format message))))
 36
 37(defmulti emit (fn [ expr ] (type expr)))
 38
 39(defmulti emit-special (fn [ & args] (first args)))
 40
 41(def statement-separator ";\n")
 42
 43(defn statement [expr]
 44  (if (not (= statement-separator (rstr/tail (count statement-separator) expr)))
 45    (str expr statement-separator)
 46    expr))
 47
 48(defn comma-list [coll]
 49  (str "(" (str/join ", " coll) ")"))
 50
 51(defmethod emit nil [expr]
 52  "null")
 53
 54(defmethod emit java.lang.Integer [expr]
 55  (str expr))
 56
 57(defmethod emit clojure.lang.Ratio [expr]
 58  (str (float expr)))
 59
 60(defmethod emit java.lang.String [^String expr]
 61  (str \" (.replace expr "\"" "\\\"") \"))
 62
 63(defn valid-symbol? [sym]
 64  ;;; This is incomplete, it disallows unicode
 65  (boolean (re-matches #"[_$\p{Alpha}][.\w]*" (str sym))))
 66
 67(defmethod emit clojure.lang.Keyword [expr]
 68  (when-not (valid-symbol? (name expr))
 69    (#'throwf "%s is not a valid javascript symbol" expr))
 70  (str (name expr)))
 71
 72(defmethod emit clojure.lang.Symbol [expr]
 73  (when-not (valid-symbol? (str expr))
 74    (#' throwf "%s is not a valid javascript symbol" expr))
 75  (str expr))
 76
 77(defmethod emit java.util.regex.Pattern [expr]
 78  (str \/ expr \/))
 79
 80(defmethod emit :default [expr]
 81  (str expr))
 82
 83(def special-forms (set ['var '. '.. 'if 'funcall 'fn 'quote 'set! 'return 'delete 'new 'do 'aget 'while 'doseq 'str 'inc! 'dec! 'dec 'inc 'defined? 'and 'or '? 'try 'break]))
 84
 85(def prefix-unary-operators (set ['!]))
 86
 87(def suffix-unary-operators (set ['++ '--]))
 88
 89(def infix-operators (set ['+ '+= '- '-= '/ '* '% '== '=== '< '> '<= '>= '!=
 90                           '<< '>> '<<< '>>> '!== '& '| '&& '|| '= 'not= 'instanceof]))
 91
 92(def chainable-infix-operators (set ['+ '- '* '/ '& '| '&& '||]))
 93
 94
 95(defn special-form? [expr]
 96  (contains? special-forms expr))
 97
 98
 99(defn infix-operator? [expr]
100  (contains? infix-operators expr))
101
102(defn prefix-unary? [expr]
103  (contains? prefix-unary-operators expr))
104
105(defn suffix-unary? [expr]
106  (contains? suffix-unary-operators expr))
107
108(defn emit-prefix-unary [type [operator arg]]
109  (str operator (emit arg)))
110
111(defn emit-suffix-unary [type [operator arg]]
112  (str (emit arg) operator))
113
114(defn emit-infix [type [operator & args]]
115  (when (and (not (chainable-infix-operators operator)) (> (count args) 2))
116    (throw (Exception. (str "operator " operator " supports only 2 arguments"))))
117  (let [substitutions {'= '=== '!= '!== 'not= '!==}]
118    (str "(" (str/join (str " " (or (substitutions operator) operator) " ")
119                       (map emit args)) ")")))
120
121(def ^{:dynamic true} var-declarations nil)
122
123(defmacro with-var-declarations [& body]
124  `(binding [var-declarations (atom [])]
125     ~@body))
126
127(defmethod emit-special 'var [type [var & more]]
128  (apply swap! var-declarations conj (filter identity (map (fn [name i] (when (odd? i) name)) more (iterate inc 1))))
129  (apply str (interleave (map (fn [[name expr]]
130                                (str (when-not var-declarations "var ") (emit name) " = " (emit expr)))
131                              (partition 2 more))
132                         (repeat statement-separator))))
133
134(defmethod emit-special 'funcall [type [name & args]]
135  (str (if (and (list? name) (= 'fn (first name))) ; function literal call
136         (str "(" (emit name) ")")
137         (emit name))
138       (comma-list (map emit args))))
139
140(defmethod emit-special 'str [type [str & args]]
141  (apply clojure.core/str (interpose " + " (map emit args))))
142
143(defn emit-method [obj method args]
144  (str (emit obj) "." (emit method) (comma-list (map emit args))))
145
146(defmethod emit-special '. [type [period obj method & args]]
147  (emit-method obj method args))
148
149(defmethod emit-special '.. [type [dotdot & args]]
150  (apply str (interpose "." (map emit args))))
151
152(defmethod emit-special 'if [type [if test true-form & false-form]]
153  (str "if (" (emit test) ") { \n"
154       (emit true-form)
155       "\n }"
156       (when (first false-form)
157         (str " else { \n"
158              (emit (first false-form))
159              " }"))))
160       
161(defmethod emit-special 'dot-method [type [method obj & args]]
162  (let [method (symbol (rstr/drop 1 (str method)))]
163    (emit-method obj method args)))
164
165(defmethod emit-special 'return [type [return expr]]
166  (statement (str "return " (emit expr))))
167
168(defmethod emit-special 'delete [type [return expr]]
169  (str "delete " (emit expr)))
170
171(defmethod emit-special 'set! [type [set! var val & more]]
172  (assert (or (nil? more) (even? (count more))))
173  (str (emit var) " = " (emit val) statement-separator
174       (if more (str (emit (cons 'set! more))))))
175
176(defmethod emit-special 'new [type [new class & args]]
177  (str "new " (emit class) (comma-list (map emit args))))
178
179(defmethod emit-special 'aget [type [aget var & idxs]]
180  (apply str
181         (emit var)
182         (interleave (repeat "[") (map emit idxs) (repeat "]"))))
183
184(defmethod emit-special 'inc! [type [inc var]]
185  (str (emit var) "++"))
186
187(defmethod emit-special 'dec! [type [dec var]]
188  (str (emit var) "--"))
189
190(defmethod emit-special 'dec [type [_ var]]
191  (str "(" (emit var) " - " 1 ")"))
192
193(defmethod emit-special 'inc [type [_ var]]
194  (str "(" (emit var) " + " 1 ")"))
195
196(defmethod emit-special 'defined? [type [_ var]]
197  (str "typeof " (emit var) " !== \"undefined\" && " (emit var) " !== null"))
198
199(defmethod emit-special '? [type [_ test then else]]
200  (str (emit test) " ? " (emit then) " : " (emit else)))
201
202(defmethod emit-special 'and [type [_ & more]]
203  (apply str (interpose "&&" (map emit more))))
204
205(defmethod emit-special 'or [type [_ & more]]
206  (apply str (interpose "||" (map emit more))))
207
208(defmethod emit-special 'quote [type [_ & more]]
209  (apply str more))
210
211(defn emit-do [exprs]
212  (str/join "" (map (comp statement emit) exprs)))
213
214(defmethod emit-special 'do [type [ do & exprs]]
215  (emit-do exprs))
216
217(defmethod emit-special 'while [type [while test & body]]
218  (str "while (" (emit test) ") { \n"
219       (emit-do body)
220       "\n }"))
221
222(defmethod emit-special 'doseq [type [doseq bindings & body]]
223  (str "for (" (emit (first bindings)) " in " (emit (second bindings)) ") { \n"
224       (if-let [more (nnext bindings)]
225         (emit (list* 'doseq more body))
226         (emit-do body))
227       "\n }"))
228
229(defn emit-var-declarations []
230  (when-not (empty? @var-declarations)
231    (apply str "var "
232           (str/join ", " (map emit @var-declarations))
233           statement-separator)))
234
235(defn emit-function [name sig body]
236  (assert (or (symbol? name) (nil? name)))
237  (assert (vector? sig))
238  (with-var-declarations
239    (let [body (emit-do body)]
240      (str "function " (comma-list sig) " {\n"
241           (emit-var-declarations) body " }"))))
242
243(defmethod emit-special 'fn [type [fn & expr]]
244  (let [name (when (symbol? (first expr)) (first expr))]
245    (when name
246      (swap! var-declarations conj name))
247    (if name
248      (let [signature (second expr)
249            body (rest (rest expr))]
250        (str name " = " (emit-function name signature body)))
251      (let [signature (first expr)
252            body (rest expr)]
253        (str (emit-function nil signature body))))))
254
255(defmethod emit-special 'try [type [try & body :as expression]]
256  (let [try-body (remove #(contains? #{'catch 'finally} (first %))
257                         body)
258        catch-clause (filter #(= 'catch (first %))
259                             body)
260        finally-clause (filter #(= 'finally (first %))
261                               body)]
262    (cond
263     (and (empty? catch-clause)
264          (empty? finally-clause))
265     (throw (new Exception (str "Must supply a catch or finally clause (or both) in a try statement! " expression)))
266
267     (> (count catch-clause) 1)
268     (throw (new Exception (str "Multiple catch clauses in a try statement are not currently supported! " expression)))
269
270     (> (count finally-clause) 1)
271     (throw (new Exception (str "Cannot supply more than one finally clause in a try statement! " expression)))
272
273     :true (str "try{\n"
274                (emit-do try-body)
275                "}\n"
276                (if-let [[_ exception & catch-body] (first catch-clause)]
277                  (str "catch(" (emit exception) "){\n"
278                       (emit-do catch-body)
279                       "}\n"))
280                (if-let [[_ & finally-body] (first finally-clause)]
281                  (str "finally{\n"
282                       (emit-do finally-body)
283                       "}\n"))))))
284
285(defmethod emit-special 'break [type [break]]
286  (statement "break"))
287
288(declare emit-custom custom-form?)
289
290(derive clojure.lang.Cons ::list)
291(derive clojure.lang.IPersistentList ::list)
292
293(defmethod emit ::list [expr]
294  (if (symbol? (first expr))
295    (let [head (symbol (name (first expr))) ; remove any ns resolution
296          expr (conj (rest expr) head)]
297      (cond
298       (and (= (rstr/get (str head) 0) \.)
299            (> (count (str head)) 1)
300
301            (not (= (rstr/get (str head) 1) \.))) (emit-special 'dot-method expr)
302        (custom-form? head) (emit-custom head expr)
303       (special-form? head) (emit-special head expr)
304       (infix-operator? head) (emit-infix head expr)
305        (prefix-unary? head) (emit-prefix-unary head expr)
306        (suffix-unary? head) (emit-suffix-unary head expr)
307       :else (emit-special 'funcall expr)))
308    (if (list? expr)
309      (emit-special 'funcall expr)
310      (throw (new Exception (str "invalid form: " expr))))))
311
312(defmethod emit clojure.lang.IPersistentVector [expr]
313  (str "[" (str/join ", " (map emit expr)) "]"))
314
315(defmethod emit clojure.lang.LazySeq [expr]
316  (emit (into [] expr)))
317
318(defmethod emit clojure.lang.IPersistentMap [expr]
319  (letfn [(json-pair [pair] (str (emit (key pair)) ": " (emit (val pair))))]
320    (str "{" (str/join ", " (map json-pair (seq expr))) "}")))
321
322(defn _js [forms]
323  (with-var-declarations
324       (let [code (if (> (count forms) 1)
325                    (emit-do forms)
326                    (emit (first forms)))]
327         ;;(println "js " forms " => " code)
328         (str (emit-var-declarations) code))))
329
330(defn- unquote?
331  "Tests whether the form is (unquote ...)."
332  [form]
333  (and (seq? form) (symbol? (first form)) (= (symbol (name (first form))) 'clj)))
334
335(defn handle-unquote [form]
336  (second form))
337
338(declare inner-walk outer-walk)
339
340(defn- inner-walk [form]
341  (cond 
342   (unquote? form) (handle-unquote form)
343   :else (walk inner-walk outer-walk form)))
344
345(defn- outer-walk [form]
346  (cond
347    (symbol? form) (list 'quote form)
348    (seq? form) (list* 'list form)
349    :else form))
350
351(defmacro quasiquote [form]
352  (let [post-form (walk inner-walk outer-walk form)]
353    post-form))
354
355(defmacro js*
356  "returns a fragment of 'uncompiled' javascript. Compile to a string using js."
357  [& forms]
358  (if (= (count forms) 1)
359    `(quasiquote ~(first forms))
360    (let [do-form `(do ~@forms)]
361      `(quasiquote ~do-form))))
362
363(defmacro cljs*
364  "equivalent to (js* (clj form))"
365  [form]
366  `(js* (~'clj ~form)))
367
368(defmacro cljs
369  "equivalent to (js (clj form))"
370  [form]
371  `(js (clj ~form)))
372
373(defmacro js 
374  "takes one or more forms. Returns a string of the forms translated into javascript"
375  [& forms]
376  `(_js (quasiquote ~forms)))
377
378
379;;**********************************************************
380;; Custom forms
381;;**********************************************************
382
383(defonce custom-forms (atom {}))
384
385(defmacro defjsmacro [nme params & body]
386  `(do
387     (defn ~nme ~params
388       (js*
389         ~@body))
390     (add-custom-form '~nme ~nme)))
391
392(defn add-custom-form [form func]
393  (swap! custom-forms assoc form func))
394
395(defn get-custom [form]
396  (get @custom-forms form))
397
398(defn custom-form? [expr]
399  (get-custom expr))
400
401(defn emit-custom [head expr]
402  (when-let [func (get-custom head)]
403    (let [v (apply func (next expr))]
404      (emit v))))
405