Skip to content
Permalink
70a33f2046
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
4535 lines (4147 sloc) 177 KB
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.
(ns cljs.analyzer
#?(:clj (:refer-clojure :exclude [macroexpand-1 ensure])
:cljs (:refer-clojure :exclude [macroexpand-1 ns-interns ensure js-reserved]))
#?(:cljs (:require-macros
[cljs.analyzer.macros
:refer [no-warn wrapping-errors
disallowing-recur allowing-redef disallowing-ns*]]
[cljs.env.macros :refer [ensure]]))
#?(:clj (:require [cljs.util :as util :refer [ns->relpath topo-sort]]
[clojure.java.io :as io]
[clojure.string :as string]
[clojure.set :as set]
[cljs.env :as env :refer [ensure]]
[cljs.js-deps :as deps]
[cljs.tagged-literals :as tags]
[clojure.tools.reader :as reader]
[clojure.tools.reader.reader-types :as readers]
[clojure.edn :as edn])
:cljs (:require [goog.string :as gstring]
[clojure.string :as string]
[clojure.set :as set]
[cljs.env :as env]
[cljs.tagged-literals :as tags]
[cljs.tools.reader :as reader]
[cljs.tools.reader.reader-types :as readers]
[cljs.reader :as edn]))
#?(:clj (:import [java.io File Reader PushbackReader FileOutputStream FileInputStream]
[java.util.regex Pattern]
[java.net URL]
[java.lang Throwable]
[clojure.lang Namespace Var LazySeq ArityException]
[cljs.tagged_literals JSValue])))
#?(:clj (set! *warn-on-reflection* true))
;; User file-local compiler flags
#?(:clj (def ^:dynamic *unchecked-if* false))
#?(:clj (def ^:dynamic *unchecked-arrays* false))
;; Compiler dynamic vars
(def ^:dynamic *cljs-ns* 'cljs.user)
(def ^:dynamic *cljs-file* nil)
(def ^:dynamic *checked-arrays* false)
(def ^:dynamic *check-alias-dupes* true)
(def ^:dynamic *cljs-static-fns* false)
(def ^:dynamic *fn-invoke-direct* false)
(def ^:dynamic *cljs-macros-path* "/cljs/core")
(def ^:dynamic *cljs-macros-is-classpath* true)
(def ^:dynamic *cljs-dep-set* (with-meta #{} {:dep-path []}))
(def ^:dynamic *analyze-deps* true)
(def ^:dynamic *load-tests* true)
(def ^:dynamic *load-macros* true)
(def ^:dynamic *reload-macros* false)
(def ^:dynamic *macro-infer* true)
(def ^:dynamic *passes* nil)
(def ^:dynamic *file-defs* nil)
(def ^:dynamic *private-var-access-nowarn* false)
(def constants-ns-sym
"The namespace of the constants table as a symbol."
'cljs.core.constants)
(def ^:private identity-counter (atom 0))
(defn- add-identity [m]
(assoc m :identity (swap! identity-counter inc)))
#?(:clj
(def transit-read-opts
(try
(require '[cognitect.transit])
(when-some [ns (find-ns 'cognitect.transit)]
(let [read-handler @(ns-resolve ns 'read-handler)
read-handler-map @(ns-resolve ns 'read-handler-map)]
{:handlers
(read-handler-map
{"cljs/js" (read-handler (fn [v] (JSValue. v)))
"cljs/regex" (read-handler (fn [v] (Pattern/compile v)))})}))
(catch Throwable t
nil))))
#?(:clj
(def transit-write-opts
(try
(require '[cognitect.transit])
(when-some [ns (find-ns 'cognitect.transit)]
(let [write-handler @(ns-resolve ns 'write-handler)
write-handler-map @(ns-resolve ns 'write-handler-map)]
{:handlers
(write-handler-map
{JSValue
(write-handler
(fn [_] "cljs/js")
(fn [js] (.val ^JSValue js)))
Pattern
(write-handler
(fn [_] "cljs/regex")
(fn [pat] (.pattern ^Pattern pat)))})}))
(catch Throwable t
nil))))
#?(:clj
(def transit
(delay
(try
(require '[cognitect.transit])
(when-some [ns (find-ns 'cognitect.transit)]
{:writer @(ns-resolve ns 'writer)
:reader @(ns-resolve ns 'reader)
:write @(ns-resolve ns 'write)
:read @(ns-resolve ns 'read)})
(catch Throwable t
nil)))))
;; log compiler activities
(def ^:dynamic *verbose* false)
(def -cljs-macros-loaded (atom false))
(def ^:dynamic *cljs-warnings*
{:preamble-missing true
:unprovided true
:undeclared-var true
:private-var-access true
:undeclared-ns true
:undeclared-ns-form true
:redef true
:redef-in-file true
:dynamic true
:fn-var true
:fn-arity true
:fn-deprecated true
:declared-arglists-mismatch true
:protocol-deprecated true
:undeclared-protocol-symbol true
:invalid-protocol-symbol true
:multiple-variadic-overloads true
:variadic-max-arity true
:overload-arity true
:extending-base-js-type true
:invoke-ctor true
:invalid-arithmetic true
:invalid-array-access true
:protocol-invalid-method true
:protocol-duped-method true
:protocol-multiple-impls true
:protocol-with-variadic-method true
:protocol-impl-with-variadic-method true
:protocol-impl-recur-with-target true
:single-segment-namespace true
:munged-namespace true
:ns-var-clash true
:non-dynamic-earmuffed-var true
:extend-type-invalid-method-shape true
:unsupported-js-module-type true
:unsupported-preprocess-value true
:js-shadowed-by-local true
:infer-warning false})
(defn unchecked-arrays? []
*unchecked-arrays*)
(defn checked-arrays
"Returns false-y, :warn, or :error based on configuration and the
current value of *unchecked-arrays*."
[]
(when (and (not (-> @env/*compiler* :options :advanced))
(not *unchecked-arrays*))
*checked-arrays*))
(def js-reserved
#{"arguments" "abstract" "await" "boolean" "break" "byte" "case"
"catch" "char" "class" "const" "continue"
"debugger" "default" "delete" "do" "double"
"else" "enum" "export" "extends" "final"
"finally" "float" "for" "function" "goto" "if"
"implements" "import" "in" "instanceof" "int"
"interface" "let" "long" "native" "new"
"package" "private" "protected" "public"
"return" "short" "static" "super" "switch"
"synchronized" "this" "throw" "throws"
"transient" "try" "typeof" "var" "void"
"volatile" "while" "with" "yield" "methods"
"null" "constructor"})
(def es5-allowed
#{"default"})
#?(:clj (def SENTINEL (Object.))
:cljs (def SENTINEL (js-obj)))
(defn gets
([m k0 k1]
(let [m (get m k0 SENTINEL)]
(when-not (identical? m SENTINEL)
(get m k1))))
([m k0 k1 k2]
(let [m (get m k0 SENTINEL)]
(when-not (identical? m SENTINEL)
(let [m (get m k1 SENTINEL)]
(when-not (identical? m SENTINEL)
(get m k2))))))
([m k0 k1 k2 k3]
(let [m (get m k0 SENTINEL)]
(when-not (identical? m SENTINEL)
(let [m (get m k1 SENTINEL)]
(when-not (identical? m SENTINEL)
(let [m (get m k2 SENTINEL)]
(when-not (identical? m SENTINEL)
(get m k3)))))))))
#?(:cljs
(def CLJ_NIL_SYM 'clj-nil))
#?(:cljs
(def NUMBER_SYM 'number))
#?(:cljs
(def STRING_SYM 'string))
(def BOOLEAN_SYM 'boolean)
#?(:cljs
(def JS_STAR_SYM 'js*))
#?(:cljs
(def DOT_SYM '.))
#?(:cljs
(def NEW_SYM 'new))
#?(:cljs
(def CLJS_CORE_SYM 'cljs.core))
#?(:cljs
(def CLJS_CORE_MACROS_SYM 'cljs.core$macros))
(def IGNORE_SYM 'ignore)
(def ANY_SYM 'any)
#?(:cljs
(defn ^boolean cljs-seq? [x]
(implements? ISeq x)))
#?(:cljs
(defn ^boolean cljs-map? [x]
(implements? IMap x)))
#?(:cljs
(defn ^boolean cljs-vector? [x]
(implements? IVector x)))
#?(:cljs
(defn ^boolean cljs-set? [x]
(implements? ISet x)))
#?(:cljs
(defn munge-path [ss]
(munge (str ss))))
#?(:cljs
(defn ns->relpath
"Given a namespace as a symbol return the relative path. May optionally
provide the file extension, defaults to :cljs."
([ns] (ns->relpath ns :cljs))
([ns ext]
(str (string/replace (munge-path ns) \. \/) "." (name ext)))))
#?(:cljs
(defn topo-sort
([x get-deps]
(topo-sort x 0 (atom (sorted-map)) (memoize get-deps)))
([x depth state memo-get-deps]
(let [deps (memo-get-deps x)]
(swap! state update-in [depth] (fnil into #{}) deps)
(doseq [dep deps]
(topo-sort dep (inc depth) state memo-get-deps))
(doseq [[<depth _] (subseq @state < depth)]
(swap! state update-in [<depth] set/difference deps))
(when (= depth 0)
(distinct (apply concat (vals @state))))))))
(declare message namespaces)
(defn ast?
#?(:cljs {:tag boolean})
[x]
(and (map? x) (contains? x :op)))
(defmulti error-message (fn [warning-type & _] warning-type))
(defmethod error-message :preamble-missing
[warning-type info]
(str "Preamble resource file not found: " (string/join " " (:missing info))))
(defmethod error-message :unprovided
[warning-type info]
(str "Required namespace not provided for " (string/join " " (:unprovided info))))
(defmethod error-message :undeclared-var
[warning-type info]
(str (if (:macro-present? info)
"Can't take value of macro "
"Use of undeclared Var ")
(:prefix info) "/" (:suffix info)))
(defmethod error-message :private-var-access
[warning-type info]
(str "var: " (:sym info) " is not public"))
(defmethod error-message :undeclared-ns
[warning-type {:keys [ns-sym js-provide] :as info}]
(str "No such namespace: " ns-sym
", could not locate " (ns->relpath ns-sym :cljs)
", " (ns->relpath ns-sym :cljc)
", or JavaScript source providing \"" js-provide "\""
(when (string/includes? (ns->relpath ns-sym) "_")
" (Please check that namespaces with dashes use underscores in the ClojureScript file name)")))
(defmethod error-message :undeclared-macros-ns
[warning-type {:keys [ns-sym js-provide] :as info}]
(str "No such macros namespace: " ns-sym
", could not locate " (ns->relpath ns-sym :clj)
" or " (ns->relpath ns-sym :cljc)))
(defmethod error-message :dynamic
[warning-type info]
(str (:name info) " not declared ^:dynamic"))
(defmethod error-message :redef
[warning-type info]
(str (:sym info) " already refers to: " (symbol (str (:ns info)) (str (:sym info)))
" being replaced by: " (symbol (str (:ns-name info)) (str (:sym info)))))
(defmethod error-message :redef-in-file
[warning-type info]
(str (:sym info) " at line " (:line info) " is being replaced"))
(defmethod error-message :fn-var
[warning-type info]
(str (symbol (str (:ns-name info)) (str (:sym info)))
" no longer fn, references are stale"))
(defmethod error-message :fn-arity
[warning-type info]
(str "Wrong number of args (" (:argc info) ") passed to "
(or (:ctor info)
(:name info))))
(defmethod error-message :fn-deprecated
[warning-type info]
(str (-> info :fexpr :info :name) " is deprecated"))
(defmethod error-message :declared-arglists-mismatch
[warning-type info]
(str (symbol (str (:ns-name info)) (str (:sym info)))
" declared arglists " (:declared info)
" mismatch defined arglists " (:defined info)))
(defmethod error-message :undeclared-ns-form
[warning-type info]
(str "Invalid :refer, " (:type info) " " (:lib info) "/" (:sym info) " does not exist"))
(defmethod error-message :protocol-deprecated
[warning-type info]
(str "Protocol " (:protocol info) " is deprecated"))
(defmethod error-message :undeclared-protocol-symbol
[warning-type info]
(str "Can't resolve protocol symbol " (:protocol info)))
(defmethod error-message :invalid-protocol-symbol
[warning-type info]
(str "Symbol " (:protocol info) " is not a protocol"))
(defmethod error-message :protocol-invalid-method
[warning-type info]
(if (:no-such-method info)
(str "Bad method signature in protocol implementation, "
(:protocol info) " does not declare method called " (:fname info))
(str "Bad method signature in protocol implementation, "
(:protocol info) " " (:fname info) " does not declare arity " (:invalid-arity info))))
(defmethod error-message :protocol-duped-method
[warning-type info]
(str "Duplicated methods in protocol implementation " (:protocol info) " " (:fname info)))
(defmethod error-message :protocol-multiple-impls
[warning-type info]
(str "Protocol " (:protocol info) " implemented multiple times"))
(defmethod error-message :protocol-with-variadic-method
[warning-type info]
(str "Protocol " (:protocol info) " declares method "
(:name info) " with variadic signature (&)"))
(defmethod error-message :protocol-impl-with-variadic-method
[warning-type info]
(str "Protocol " (:protocol info) " implements method "
(:name info) " with variadic signature (&)"))
(defmethod error-message :protocol-impl-recur-with-target
[warning-type info]
(str "Ignoring target object \"" (pr-str (:form info)) "\" passed in recur to protocol method head"))
(defmethod error-message :multiple-variadic-overloads
[warning-type info]
(str (:name info) ": Can't have more than 1 variadic overload"))
(defmethod error-message :variadic-max-arity
[warning-type info]
(str (:name info) ": Can't have fixed arity function with more params than variadic function"))
(defmethod error-message :overload-arity
[warning-type info]
(str (:name info) ": Can't have 2 overloads with same arity"))
(defmethod error-message :extending-base-js-type
[warning-type info]
(str "Extending an existing JavaScript type - use a different symbol name "
"instead of " (:current-symbol info) " e.g " (:suggested-symbol info)))
(defmethod error-message :invalid-arithmetic
[warning-type info]
(str (:js-op info) ", all arguments must be numbers, got " (:types info) " instead"))
(defmethod error-message :invalid-array-access
[warning-type {:keys [name types]}]
(case name
(cljs.core/checked-aget cljs.core/checked-aget')
(str "cljs.core/aget, arguments must be an array followed by numeric indices, got " types " instead"
(when (or (= 'object (first types))
(every? #{'string} (rest types)))
(str " (consider "
(if (== 2 (count types))
"goog.object/get"
"goog.object/getValueByKeys")
" for object access)")))
(cljs.core/checked-aset cljs.core/checked-aset')
(str "cljs.core/aset, arguments must be an array, followed by numeric indices, followed by a value, got " types " instead"
(when (or (= 'object (first types))
(every? #{'string} (butlast (rest types))))
" (consider goog.object/set for object access)"))))
(defmethod error-message :invoke-ctor
[warning-type info]
(str "Cannot invoke type constructor " (-> info :fexpr :info :name) " as function "))
(defmethod error-message :single-segment-namespace
[warning-type info]
(str (:name info) " is a single segment namespace"))
(defmethod error-message :munged-namespace
[warning-type {:keys [name] :as info}]
(let [munged (->> (string/split (clojure.core/name name) #"\.")
(map #(if (js-reserved %) (str % "$") %))
(string/join ".")
(munge))]
(str "Namespace " name " contains a reserved JavaScript keyword,"
" the corresponding Google Closure namespace will be munged to " munged)))
(defmethod error-message :ns-var-clash
[warning-type {:keys [ns var] :as info}]
(str "Namespace " ns " clashes with var " var))
(defmethod error-message :non-dynamic-earmuffed-var
[warning-type {:keys [var] :as info}]
(str var " not declared dynamic and thus is not dynamically rebindable, but its name "
"suggests otherwise. Please either indicate ^:dynamic " var " or change the name"))
(defmethod error-message :extend-type-invalid-method-shape
[warning-type {:keys [protocol method] :as info}]
(str "Bad extend-type method shape for protocol " protocol " method " method
", method arities must be grouped together"))
(defmethod error-message :unsupported-js-module-type
[warning-type {:keys [module-type file] :as info}]
(str "Unsupported JavaScript module type " module-type " for foreign library "
file "."))
(defmethod error-message :unsupported-preprocess-value
[warning-type {:keys [preprocess file]}]
(str "Unsupported preprocess value " preprocess " for foreign library "
file "."))
(defmethod error-message :js-shadowed-by-local
[warning-type {:keys [name]}]
(str name " is shadowed by a local"))
(defmethod error-message :infer-warning
[warning-type {:keys [warn-type form type property]}]
(case warn-type
:target (str "Cannot infer target type in expression " form "")
:property (str "Cannot resolve property " property
" for inferred type " type " in expression " form)
:object (str "Adding extern to Object for property " property " due to "
"ambiguous expression " form)))
(defn default-warning-handler [warning-type env extra]
(when (warning-type *cljs-warnings*)
(when-let [s (error-message warning-type extra)]
#?(:clj (binding [*out* *err*]
(println (message env (str "WARNING: " s))))
:cljs (binding [*print-fn* *print-err-fn*]
(println (message env (str "WARNING: " s))))))))
(def ^:dynamic *cljs-warning-handlers*
[default-warning-handler])
#?(:clj
(defmacro with-warning-handlers [handlers & body]
`(binding [*cljs-warning-handlers* ~handlers]
~@body)))
(defn- repeat-char [c n]
(loop [ret c n n]
(if (pos? n)
(recur (str ret c) (dec n))
ret)))
(defn- hex-format [s pad]
#?(:clj (str "_u" (format (str "%0" pad "x") (int (first s))) "_")
:cljs (let [hex (.toString (.charCodeAt s 0) 16)
len (. hex -length)
hex (if (< len pad)
(str (repeat-char "0" (- pad len)) hex)
hex)]
(str "_u" hex "_"))))
(defn gen-constant-id [value]
(let [prefix (cond
(keyword? value) "cst$kw$"
(symbol? value) "cst$sym$"
:else
(throw
#?(:clj (Exception. (str "constant type " (type value) " not supported"))
:cljs (js/Error. (str "constant type " (type value) " not supported")))))
name (if (keyword? value)
(subs (str value) 1)
(str value))
name (if (= "." name)
"_DOT_"
(-> name
(string/replace "-" "_DASH_")
(munge)
(string/replace "." "$")
(string/replace #"(?i)[^a-z0-9$_]" #(hex-format % 4))))]
(symbol (str prefix name))))
(defn- register-constant!
([val] (register-constant! nil val))
([env val]
(swap! env/*compiler*
(fn [cenv]
(cond->
(-> cenv
(update-in [::constant-table]
(fn [table]
(if (get table val)
table
(assoc table val (gen-constant-id val))))))
env (update-in [::namespaces (-> env :ns :name) ::constants]
(fn [{:keys [seen order] :or {seen #{} order []} :as constants}]
(cond-> constants
(not (contains? seen val))
(assoc
:seen (conj seen val)
:order (conj order val))))))))))
(def default-namespaces '{cljs.core {:name cljs.core}
cljs.user {:name cljs.user}})
;; this exists solely to support read-only namespace access from macros.
;; External tools should look at the authoritative ::namespaces slot in the
;; compiler-env atoms/maps they're using already; this value will yield only
;; `default-namespaces` when accessed outside the scope of a
;; compilation/analysis call
(def namespaces
#?(:clj
(reify clojure.lang.IDeref
(deref [_]
(if (some? env/*compiler*)
(::namespaces @env/*compiler*)
default-namespaces)))
:cljs
(reify IDeref
(-deref [_]
(if (some? env/*compiler*)
(::namespaces @env/*compiler*)
default-namespaces)))))
(defn get-namespace
([key]
(get-namespace env/*compiler* key))
([cenv key]
(if-some [ns (get-in @cenv [::namespaces key])]
ns
(when (= 'cljs.user key)
{:name 'cljs.user}))))
#?(:clj
(defmacro no-warn [& body]
(let [no-warnings (zipmap (keys *cljs-warnings*) (repeat false))]
`(binding [*cljs-warnings* ~no-warnings]
~@body))))
#?(:clj
(defmacro all-warn [& body]
(let [all-warnings (zipmap (keys *cljs-warnings*) (repeat true))]
`(binding [*cljs-warnings* ~all-warnings]
~@body))))
(defn get-line [x env]
(or (-> x meta :line) (:line env)))
(defn get-col [x env]
(or (-> x meta :column) (:column env)))
(defn intern-macros
"Given a Clojure namespace intern all macros into the ambient ClojureScript
analysis environment."
([ns] (intern-macros ns false))
([ns reload]
(when (or (nil? (gets @env/*compiler* ::namespaces ns :macros))
reload)
(swap! env/*compiler* assoc-in [::namespaces ns :macros]
(->> #?(:clj (ns-interns ns) :cljs (ns-interns* ns))
(filter (fn [[_ ^Var v]] (.isMacro v)))
(map (fn [[k v]]
[k (as-> (meta v) vm
(let [ns (.getName ^Namespace (:ns vm))]
(assoc vm
:ns ns
:name (symbol (str ns) (str k))
:macro true)))]))
(into {}))))))
#?(:clj
(def load-mutex (Object.)))
#?(:clj
(defn load-core []
(when (not @-cljs-macros-loaded)
(reset! -cljs-macros-loaded true)
(if *cljs-macros-is-classpath*
(locking load-mutex
(load *cljs-macros-path*))
(locking load-mutex
(load-file *cljs-macros-path*))))
(intern-macros 'cljs.core)))
#?(:clj
(defmacro with-core-macros
[path & body]
`(do
(when (not= *cljs-macros-path* ~path)
(reset! -cljs-macros-loaded false))
(binding [*cljs-macros-path* ~path]
~@body))))
#?(:clj
(defmacro with-core-macros-file
[path & body]
`(do
(when (not= *cljs-macros-path* ~path)
(reset! -cljs-macros-loaded false))
(binding [*cljs-macros-path* ~path
*cljs-macros-is-classpath* false]
~@body))))
(defn empty-env
"Construct an empty analysis environment. Required to analyze forms."
[]
(ensure
{:ns (get-namespace *cljs-ns*)
:context :statement
:locals {}
:fn-scope []
:js-globals (into {}
(map #(vector % {:op :js-var :name % :ns 'js})
'(alert window document console escape unescape
screen location navigator history location
global process require module exports)))}))
(defn source-info
([env]
(when (:line env)
(source-info nil env)))
([name env]
(cond-> {:file (if (= (-> env :ns :name) 'cljs.core)
"cljs/core.cljs"
*cljs-file*)
:line (get-line name env)
:column (get-col name env)}
(:root-source-info env)
(merge (select-keys env [:root-source-info])))))
(defn message [env s]
(str s
(if (:line env)
(str " at line " (:line env) " " *cljs-file*)
(when *cljs-file*
(str " in file " *cljs-file*)))))
(defn warning [warning-type env extra]
(doseq [handler *cljs-warning-handlers*]
(handler warning-type env extra)))
(defn error
([env msg]
(error env msg nil))
([env msg cause]
(ex-info (message env msg)
(assoc (source-info env) :tag :cljs/analysis-error)
cause)))
(defn analysis-error?
#?(:cljs {:tag boolean})
[ex]
(= :cljs/analysis-error (:tag (ex-data ex))))
#?(:clj
(defmacro wrapping-errors [env & body]
`(try
~@body
(catch Throwable err#
(if (analysis-error? err#)
(throw err#)
(throw (error ~env (.getMessage err#) err#)))))))
;; namespaces implicit to the inclusion of cljs.core
(def implicit-nses '#{goog goog.object goog.string goog.array Math String})
(defn implicit-import?
#?(:cljs {:tag boolean})
[env prefix suffix]
(contains? implicit-nses prefix))
(declare get-expander)
(defn confirm-var-exist-warning [env prefix suffix]
(fn [env prefix suffix]
(warning :undeclared-var env
{:prefix prefix
:suffix suffix
:macro-present? (not (nil? (get-expander (symbol (str prefix) (str suffix)) env)))})))
(defn loaded-js-ns?
"Check if a JavaScript namespace has been loaded. JavaScript vars are
not currently checked."
#?(:cljs {:tag boolean})
[env prefix]
(when-not (gets @env/*compiler* ::namespaces prefix)
(let [ns (:ns env)]
(or (some? (get (:requires ns) prefix))
(some? (get (:imports ns) prefix))))))
(defn- internal-js-module-exists?
[js-module-index module]
;; we need to check both keys and values of the JS module index, because
;; macroexpansion will be looking for the provided name - António Monteiro
(contains?
(into #{}
(mapcat (fn [[k v]]
[k (:name v)]))
js-module-index)
(str module)))
(def js-module-exists?* (memoize internal-js-module-exists?))
(defn js-module-exists?
[module]
(js-module-exists?* (get-in @env/*compiler* [:js-module-index]) module))
(defn node-module-dep?
#?(:cljs {:tag boolean})
[module]
#?(:clj (contains?
(get-in @env/*compiler* [:node-module-index])
(str module))
:cljs (try
(and (= *target* "nodejs")
(boolean (js/require.resolve (str module))))
(catch :default _
false))))
(defn dep-has-global-exports?
[module]
(let [global-exports (get-in @env/*compiler* [:js-dependency-index (str module) :global-exports])]
(or (contains? global-exports (symbol module))
(contains? global-exports (name module)))))
(defn confirm-var-exists
([env prefix suffix]
(let [warn (confirm-var-exist-warning env prefix suffix)]
(confirm-var-exists env prefix suffix warn)))
([env prefix suffix missing-fn]
(let [sufstr (str suffix)
suffix-str (if (and #?(:clj (not= ".." sufstr)
:cljs (not (identical? ".." sufstr))) ;; leave cljs.core$macros/.. alone
#?(:clj (re-find #"\." sufstr)
:cljs ^boolean (.test #"\." sufstr)))
(first (string/split sufstr #"\."))
suffix)
suffix (symbol suffix-str)]
(when (and (not (implicit-import? env prefix suffix))
(not (loaded-js-ns? env prefix))
(not (and (= 'cljs.core prefix) (= 'unquote suffix)))
(nil? (gets @env/*compiler* ::namespaces prefix :defs suffix))
(not (js-module-exists? prefix)))
(missing-fn env prefix suffix)))))
(defn confirm-var-exists-throw []
(fn [env prefix suffix]
(confirm-var-exists env prefix suffix
(fn [env prefix suffix]
(throw (error env (str "Unable to resolve var: " suffix " in this context")))))))
(defn resolve-ns-alias
([env name]
(resolve-ns-alias env name (symbol name)))
([env name not-found]
(let [sym (symbol name)]
(get (:requires (:ns env)) sym not-found))))
(defn resolve-macro-ns-alias
([env name]
(resolve-macro-ns-alias env name (symbol name)))
([env name not-found]
(let [sym (symbol name)]
(get (:require-macros (:ns env)) sym not-found))))
(defn confirm-ns
"Given env, an analysis environment, and ns-sym, a symbol identifying a
namespace, confirm that the namespace exists. Warn if not found."
[env ns-sym]
(when (and (not= 'cljs.core ns-sym)
(nil? (get implicit-nses ns-sym))
(nil? (get (-> env :ns :requires) ns-sym))
;; something else may have loaded the namespace, i.e. load-file
(nil? (gets @env/*compiler* ::namespaces ns-sym))
;; macros may refer to namespaces never explicitly required
;; confirm that the library at least exists
#?(:clj (nil? (util/ns->source ns-sym)))
(not (js-module-exists? ns-sym)))
(warning :undeclared-ns env {:ns-sym ns-sym :js-provide ns-sym})))
(defn core-name?
"Is sym visible from core in the current compilation namespace?"
#?(:cljs {:tag boolean})
[env sym]
(and (or (some? (gets @env/*compiler* ::namespaces 'cljs.core :defs sym))
(if-some [mac (get-expander sym env)]
(let [^Namespace ns (-> mac meta :ns)]
(= (.getName ns) #?(:clj 'cljs.core :cljs 'cljs.core$macros)))
false))
(not (contains? (-> env :ns :excludes) sym))))
(defn public-name?
"Is sym public?"
#?(:cljs {:tag boolean})
[ns sym]
(let [var-ast (or (gets @env/*compiler* ::namespaces ns :defs sym)
#?(:clj (gets @env/*compiler* ::namespaces ns :macros sym)
:cljs (gets @env/*compiler* ::namespaces (symbol (str (name ns) "$macros")) :defs sym)))]
(and (some? var-ast)
(not (or (:private var-ast)
(:anonymous var-ast))))))
(defn js-tag? [x]
(and (symbol? x)
(or (= 'js x)
(= "js" (namespace x)))))
(defn normalize-js-tag [x]
;; if not 'js, assume constructor
(if-not (= 'js x)
(with-meta 'js
{:prefix (conj (->> (string/split (name x) #"\.")
(map symbol) vec)
'prototype)})
x))
(def alias->type
'{object Object
string String
number Number
array Array
function Function
boolean Boolean
symbol Symbol})
(defn has-extern?*
([pre externs]
(let [pre (if-some [me (find
(get-in externs '[Window prototype])
(first pre))]
(if-some [tag (-> me first meta :tag)]
(into [tag 'prototype] (next pre))
pre)
pre)]
(has-extern?* pre externs externs)))
([pre externs top]
(cond
(empty? pre) true
:else
(let [x (first pre)
me (find externs x)]
(cond
(not me) false
:else
(let [[x' externs'] me
xmeta (meta x')]
(if (and (= 'Function (:tag xmeta)) (:ctor xmeta))
(or (has-extern?* (into '[prototype] (next pre)) externs' top)
(has-extern?* (next pre) externs' top))
(recur (next pre) externs' top))))))))
(defn has-extern?
([pre]
(has-extern? pre (get @env/*compiler* ::externs)))
([pre externs]
(or (has-extern?* pre externs)
(when (= 1 (count pre))
(let [x (first pre)]
(or (get-in externs (conj '[Window prototype] x))
(get-in externs (conj '[Number] x)))))
(-> (last pre) str (string/starts-with? "cljs$")))))
(defn js-tag
([pre]
(js-tag pre :tag))
([pre tag-type]
(js-tag pre tag-type (get @env/*compiler* ::externs)))
([pre tag-type externs]
(js-tag pre tag-type externs externs))
([pre tag-type externs top]
(when-let [[p externs' :as me] (find externs (first pre))]
(let [tag (-> p meta tag-type)]
(if (= (count pre) 1)
(when tag (symbol "js" (str (alias->type tag tag))))
(or (js-tag (next pre) tag-type externs' top)
(js-tag (into '[prototype] (next pre)) tag-type (get top tag) top)))))))
(defn dotted-symbol? [sym]
(let [s (str sym)]
#?(:clj (and (.contains s ".")
(not (.contains s "..")))
:cljs (and ^boolean (goog.string/contains s ".")
(not ^boolean (goog.string/contains s ".."))))))
(defn munge-node-lib [name]
(str "node$module$" (munge (string/replace (str name) #"[.\/]" #?(:clj "\\$"
:cljs "$$")))))
(defn munge-global-export [name]
(str "global$module$" (munge (string/replace (str name) #"[.\/]" #?(:clj "\\$"
:cljs "$$")))))
(defn resolve-alias
"Takes a namespace and an unqualified symbol and potentially returns a new
symbol to be used in lieu of the original."
[ns sym]
;; Conditionally alias aget/aset fns to checked variants
(if (and (= 'cljs.core ns)
('#{aget aset} sym)
(checked-arrays))
(get-in '{:warn {aget checked-aget
aset checked-aset}
:error {aget checked-aget'
aset checked-aset'}}
[(checked-arrays) sym])
sym))
(defn ns->module-type [ns]
(cond
(js-module-exists? ns) :js
(node-module-dep? ns) :node
(dep-has-global-exports? ns) :global))
(defmulti resolve* (fn [env sym full-ns current-ns] (ns->module-type full-ns)))
(defmethod resolve* :js
[env sym full-ns current-ns]
{:name (symbol (str full-ns) (str (name sym)))
:op :js-var
:ns full-ns})
(defmethod resolve* :node
[env sym full-ns current-ns]
{:name (symbol (str current-ns) (str (munge-node-lib full-ns) "." (name sym)))
:op :js-var
:ns current-ns})
(defmethod resolve* :global
[env sym full-ns current-ns]
(let [pre (into '[Object] (->> (string/split (name sym) #"\.") (map symbol) vec))]
(when-not (has-extern? pre)
(swap! env/*compiler* update-in
(into [::namespaces current-ns :externs] pre) merge {}))
{:name (symbol (str current-ns) (str (munge-global-export full-ns) "." (name sym)))
:op :js-var
:ns current-ns
:tag (with-meta 'js {:prefix pre})}))
(def ^:private private-var-access-exceptions
"Specially-treated symbols for which we don't trigger :private-var-access warnings."
'#{cljs.core/checked-aget
cljs.core/checked-aset
cljs.core/checked-aget'
cljs.core/checked-aset'})
(defmethod resolve* :default
[env sym full-ns current-ns]
(let [sym-ast (gets @env/*compiler* ::namespaces full-ns :defs (symbol (name sym)))
sym-name (symbol (str full-ns) (str (name sym)))]
(when (and (not= current-ns full-ns)
(:private sym-ast)
(not *private-var-access-nowarn*)
(not (contains? private-var-access-exceptions sym-name)))
(warning :private-var-access env
{:sym sym-name}))
(merge sym-ast
{:name sym-name
:op :var
:ns full-ns})))
(defn required? [ns env]
(or (contains? (set (vals (gets env :ns :requires))) ns)
(contains? (set (vals (gets env :ns :uses))) ns)))
(defn invokeable-ns?
"Returns true if ns is a required namespace and a JavaScript module that
might be invokeable as a function."
[ns env]
(let [ns (resolve-ns-alias env ns)]
(and (required? ns env)
(or (js-module-exists? ns)
(node-module-dep? ns)
(dep-has-global-exports? ns)))))
(defn resolve-invokeable-ns [ns current-ns env]
(let [ns (resolve-ns-alias env ns)
module-type (ns->module-type ns)]
(case module-type
:js {:name (symbol
(or (gets @env/*compiler* :js-module-index ns :name)
(resolve-ns-alias env ns)))
:op :js-var
:ns 'js}
:node {:name (symbol (str current-ns)
(munge-node-lib (resolve-ns-alias env ns)))
:op :js-var
:ns current-ns}
:global {:name (symbol (str current-ns)
(munge-global-export (resolve-ns-alias env ns)))
:op :js-var
:ns current-ns})))
;; core.async calls `macroexpand-1` manually with an ill-formed
;; :locals map. Normally :locals maps symbols maps, but
;; core.async adds entries mapping symbols to symbols. We work
;; around that specific case here. This is called defensively
;; every time we lookup the :locals map.
(defn handle-symbol-local [sym lb]
(if (symbol? lb)
{:name sym}
lb))
(defn resolve-var
"Resolve a var. Accepts a side-effecting confirm fn for producing
warnings about unresolved vars."
([env sym] (resolve-var env sym nil))
([env sym confirm]
(let [locals (:locals env)]
(if #?(:clj (= "js" (namespace sym))
:cljs (identical? "js" (namespace sym)))
(let [symn (-> sym name symbol)
shadowed-by-local (handle-symbol-local symn (get locals symn))]
(cond
(some? shadowed-by-local)
(do (warning :js-shadowed-by-local env {:name sym})
(assoc shadowed-by-local :op :local))
:else
(let [pre (->> (string/split (name sym) #"\.") (map symbol) vec)]
(when (and (not (has-extern? pre))
;; ignore exists? usage
(not (-> sym meta ::no-resolve)))
(swap! env/*compiler* update-in
(into [::namespaces (-> env :ns :name) :externs] pre) merge {}))
(merge
{:name sym
:op :js-var
:ns 'js
:tag (with-meta (or (js-tag pre) (:tag (meta sym)) 'js) {:prefix pre})}
(when-let [ret-tag (js-tag pre :ret-tag)]
{:js-fn-var true
:ret-tag ret-tag})))))
(let [s (str sym)
lb (handle-symbol-local sym (get locals sym))
current-ns (-> env :ns :name)]
(cond
(some? lb) (assoc lb :op :local)
(some? (namespace sym))
(let [ns (namespace sym)
ns (if #?(:clj (= "clojure.core" ns)
:cljs (identical? "clojure.core" ns))
"cljs.core"
ns)
full-ns (resolve-ns-alias env ns
(or (and (js-module-exists? ns)
(gets @env/*compiler* :js-module-index ns :name))
(symbol ns)))]
(when (some? confirm)
(when (not= current-ns full-ns)
(confirm-ns env full-ns))
(confirm env full-ns (symbol (name sym))))
(resolve* env sym full-ns current-ns))
(dotted-symbol? sym)
(let [idx (.indexOf s ".")
prefix (symbol (subs s 0 idx))
suffix (subs s (inc idx))]
(if-some [lb (handle-symbol-local prefix (get locals prefix))]
{:op :local
:name (symbol (str (:name lb) "." suffix))}
(if-some [full-ns (gets @env/*compiler* ::namespaces current-ns :imports prefix)]
{:op :js-var
:name (symbol (str full-ns) suffix)}
(if-some [info (gets @env/*compiler* ::namespaces current-ns :defs prefix)]
(merge info
{:name (symbol (str current-ns) (str sym))
:op :var
:ns current-ns})
(merge (gets @env/*compiler* ::namespaces prefix :defs (symbol suffix))
{:name (if (= "" prefix) (symbol suffix) (symbol (str prefix) suffix))
:op :var
:ns prefix})))))
(some? (gets @env/*compiler* ::namespaces current-ns :uses sym))
(let [full-ns (gets @env/*compiler* ::namespaces current-ns :uses sym)]
(resolve* env sym full-ns current-ns))
(some? (gets @env/*compiler* ::namespaces current-ns :renames sym))
(let [qualified-symbol (gets @env/*compiler* ::namespaces current-ns :renames sym)
full-ns (symbol (namespace qualified-symbol))
sym (symbol (name qualified-symbol))]
(resolve* env sym full-ns current-ns))
(some? (gets @env/*compiler* ::namespaces current-ns :imports sym))
(recur env (gets @env/*compiler* ::namespaces current-ns :imports sym) confirm)
(some? (gets @env/*compiler* ::namespaces current-ns :defs sym))
(do
(when (some? confirm)
(confirm env current-ns sym))
(merge (gets @env/*compiler* ::namespaces current-ns :defs sym)
{:name (symbol (str current-ns) (str sym))
:op :var
:ns current-ns}))
(core-name? env sym)
(do
(when (some? confirm)
(confirm env 'cljs.core sym))
(merge (gets @env/*compiler* ::namespaces 'cljs.core :defs sym)
{:name (symbol "cljs.core" (str sym))
:op :var
:ns 'cljs.core}))
(invokeable-ns? s env)
(resolve-invokeable-ns s current-ns env)
:else
(do
(when (some? confirm)
(confirm env current-ns sym))
(merge (gets @env/*compiler* ::namespaces current-ns :defs sym)
{:name (symbol (str current-ns) (str sym))
:op :var
:ns current-ns}))))))))
(defn resolve-existing-var
"Given env, an analysis environment, and sym, a symbol, resolve an existing var.
Emits a warning if no such var exists."
[env sym]
(if-not (-> sym meta ::no-resolve)
(resolve-var env sym confirm-var-exists)
(resolve-var env sym)))
(defn confirm-bindings
"Given env, an analysis environment env, and names, a list of symbols, confirm
that all correspond to declared dynamic vars."
[env names]
(doseq [name names]
(let [env (assoc env :ns (get-namespace *cljs-ns*))
ev (resolve-existing-var env name)]
(when (and ev (not (-> ev :dynamic)))
(warning :dynamic env {:ev ev :name (:name ev)})))))
(defn resolve-macro-var
"Given env, an analysis environment, and sym, a symbol, resolve a macro."
[env sym]
(let [ns (-> env :ns :name)
namespaces (get @env/*compiler* ::namespaces)]
(cond
(some? (namespace sym))
(let [ns (namespace sym)
ns (if (= "clojure.core" ns) "cljs.core" ns)
full-ns (resolve-macro-ns-alias env ns)
#?@(:cljs [full-ns (if-not (string/ends-with? (str full-ns) "$macros")
(symbol (str full-ns "$macros"))
full-ns)])]
#?(:clj (get-in namespaces [full-ns :macros (symbol (name sym))])
:cljs (get-in namespaces [full-ns :defs (symbol (name sym))])))
(some? (get-in namespaces [ns :use-macros sym]))
(let [full-ns (get-in namespaces [ns :use-macros sym])]
(get-in namespaces [full-ns :macros sym]))
(some? (get-in namespaces [ns :rename-macros sym]))
(let [qualified-symbol (get-in namespaces [ns :rename-macros sym])
full-ns (symbol (namespace qualified-symbol))
sym (symbol (name qualified-symbol))]
(get-in namespaces [full-ns :macros sym]))
:else
(let [ns (cond
(some? (get-in namespaces [ns :macros sym])) ns
(core-name? env sym) #?(:clj 'cljs.core
:cljs CLJS_CORE_MACROS_SYM))]
(when (some? ns)
#?(:clj (get-in namespaces [ns :macros sym])
:cljs (get-in namespaces [ns :defs sym])))))))
(declare analyze analyze-symbol analyze-seq)
;; Note: This is the set of parse multimethod dispatch values,
;; along with '&, and differs from cljs.core/special-symbol?
(def specials '#{if def fn* do let* loop* letfn* throw try recur new set!
ns deftype* defrecord* . js* & quote case* var ns*})
(def ^:dynamic *recur-frames* nil)
(def ^:dynamic *loop-lets* ())
(def ^:dynamic *allow-redef* false)
(def ^:dynamic *allow-ns* true)
#?(:clj
(defmacro disallowing-recur [& body]
`(binding [*recur-frames* (cons nil *recur-frames*)] ~@body)))
#?(:clj
(defmacro allowing-redef [& body]
`(binding [*allow-redef* true] ~@body)))
#?(:clj
(defmacro disallowing-ns* [& body]
`(binding [*allow-ns* false] ~@body)))
;; TODO: move this logic out - David
(defn analyze-keyword
[env sym]
(register-constant! env sym)
{:op :const :val sym :env env :form sym :tag 'cljs.core/Keyword})
(defn get-tag [e]
(if-some [tag (-> e :form meta :tag)]
tag
(if-some [tag (-> e :tag)]
tag
(-> e :info :tag))))
(defn find-matching-method [f params]
;; if local fn, need to look in :info
(let [methods (or (:methods f) (-> f :info :methods))
c (count params)]
(some
(fn [m]
(and (or (== (:fixed-arity m) c)
(:variadic? m))
m))
methods)))
(defn type?
#?(:cljs {:tag boolean})
[env t]
;; don't use resolve-existing-var to avoid warnings
(when (and (some? t) (symbol? t))
(let [var (resolve-var env t)]
(if-some [type (:type var)]
type
(if-some [type (-> var :info :type)]
type
(if-some [proto (:protocol-symbol var)]
proto
(get '#{cljs.core/PersistentHashMap cljs.core/List} t)))))))
(declare infer-tag)
(def NOT_NATIVE '#{clj not-native})
(def BOOLEAN_OR_SEQ '#{boolean seq})
(defn unwrap-quote [{:keys [op] :as expr}]
(if #?(:clj (= op :quote)
:cljs (keyword-identical? op :quote))
(:expr expr)
expr))
(defn infer-if [env e]
(let [{:keys [op form]} (unwrap-quote (:test e))
then-tag (infer-tag env (:then e))]
(if (and #?(:clj (= op :const)
:cljs (keyword-identical? op :const))
(not (nil? form))
(not (false? form)))
then-tag
(let [else-tag (infer-tag env (:else e))]
(cond
(or #?(:clj (= then-tag else-tag)
:cljs (symbol-identical? then-tag else-tag))
#?(:clj (= else-tag IGNORE_SYM)
:cljs (symbol-identical? else-tag IGNORE_SYM))) then-tag
#?(:clj (= then-tag IGNORE_SYM)
:cljs (symbol-identical? then-tag IGNORE_SYM)) else-tag
;; TODO: temporary until we move not-native -> clj - David
(and (or (some? (get NOT_NATIVE then-tag)) (type? env then-tag))
(or (some? (get NOT_NATIVE else-tag)) (type? env else-tag)))
'clj
:else
(if (and (some? (get BOOLEAN_OR_SEQ then-tag))
(some? (get BOOLEAN_OR_SEQ else-tag)))
'seq
(let [then-tag (if #?(:clj (set? then-tag)
:cljs (cljs-set? then-tag))
then-tag #{then-tag})
else-tag (if #?(:clj (set? else-tag)
:cljs (cljs-set? else-tag))
else-tag #{else-tag})]
(into then-tag else-tag))))))))
(defn infer-invoke [env {f :fn :keys [args] :as e}]
(let [me (assoc (find-matching-method f args) :op :fn-method)]
(if-some [ret-tag (infer-tag env me)]
ret-tag
(let [{:keys [info]} f]
(if-some [ret-tag (if (or (true? (:fn-var info))
(true? (:js-fn-var info)))
(:ret-tag info)
(when (= 'js (:ns info)) 'js))]
ret-tag
ANY_SYM)))))
(defn infer-tag
"Given env, an analysis environment, and e, an AST node, return the inferred
type of the node"
[env e]
(if-some [tag (get-tag e)]
tag
(case (:op e)
:recur IGNORE_SYM
:throw IGNORE_SYM
:let (infer-tag env (:body e))
:loop (infer-tag env (:body e))
:do (infer-tag env (:ret e))
:fn-method (infer-tag env (:body e))
:def (infer-tag env (:init e))
:invoke (infer-invoke env e)
:if (infer-if env e)
:const (case (:form e)
true BOOLEAN_SYM
false BOOLEAN_SYM
ANY_SYM)
:quote (infer-tag env (:expr e))
(:var :local :js-var :binding)
(if-some [init (:init e)]
(infer-tag env init)
(infer-tag env (:info e)))
(:host-field :host-call) ANY_SYM
:js ANY_SYM
nil)))
(defmulti parse (fn [op & rest] op))
(defn var-meta
([var]
(var-meta var nil))
([var expr-env]
(let [sym (:name var)
ks [:ns :doc :file :line :column]
m (merge
(let [user-meta (:meta var)
uks (keys user-meta)]
(zipmap uks
(map #(list 'quote (get user-meta %)) uks)))
(assoc (zipmap ks (map #(list 'quote (get var %)) ks))
:name `(quote ~(symbol (name (:name var))))
:test `(when ~sym (.-cljs$lang$test ~sym))
:arglists (let [arglists (:arglists var)
arglists' (if (= 'quote (first arglists))
(second arglists)
arglists)]
(list 'quote
(doall (map with-meta arglists'
(:arglists-meta var)))))))]
(if expr-env
(analyze expr-env m)
m))))
(defn var-ast
[env sym]
;; we need to dissoc locals for the `(let [x 1] (def x x))` case, because we
;; want the var's AST and `resolve-var` will check locals first. - António Monteiro
(binding [*private-var-access-nowarn* true]
(let [env (dissoc env :locals)
var (resolve-var env sym (confirm-var-exists-throw))
expr-env (assoc env :context :expr)]
(when-some [var-ns (:ns var)]
{:var (analyze expr-env sym)
:sym (analyze expr-env `(quote ~(symbol (name var-ns) (name (:name var)))))
:meta (var-meta var expr-env)}))))
(defmethod parse 'var
[op env [_ sym :as form] _ _]
(when (not= 2 (count form))
(throw (error env "Wrong number of args to var")))
(when-not (symbol? sym)
(throw (error env "Argument to var must be symbol")))
(merge
{:env env
:op :the-var
:children [:var :sym :meta]
:form form}
(var-ast env sym)))
(def ^:private predicate->tag
'{
;; Base values
cljs.core/nil? clj-nil
cljs.core/undefined? clj-nil
cljs.core/false? boolean
cljs.core/true? boolean
cljs.core/zero? number
cljs.core/infinite? number
;; Base types
cljs.core/boolean? boolean
cljs.core/string? string
cljs.core/char? string
cljs.core/number? number
cljs.core/integer? number
cljs.core/float? number
cljs.core/double? number
cljs.core/array? array
cljs.core/seq? seq
;; JavaScript types
cljs.core/regexp? js/RegExp
;; Types
cljs.core/keyword? cljs.core/Keyword
cljs.core/var? cljs.core/Var
cljs.core/symbol? cljs.core/Symbol
cljs.core/volatile? cljs.core/Volatile
cljs.core/delay? cljs.core/Delay
cljs.core/reduced? cljs.core/Reduced
;; Protocols
cljs.core/map-entry? cljs.core/IMapEntry
cljs.core/reversible? cljs.core/IReversible
cljs.core/uuid? cljs.core/IUUID
cljs.core/tagged-literal? cljs.core/ITaggedLiteral
cljs.core/iterable? cljs.core/IIterable
cljs.core/cloneable? cljs.core/ICloneable
cljs.core/inst? cljs.core/Inst
cljs.core/counted? cljs.core/ICounted
cljs.core/indexed? cljs.core/IIndexed
cljs.core/coll? cljs.core/ICollection
cljs.core/set? cljs.core/ISet
cljs.core/associative? cljs.core/IAssociative
cljs.core/ifind? cljs.core/IFind
cljs.core/sequential? cljs.core/ISequential
cljs.core/sorted? cljs.core/ISorted
cljs.core/reduceable cljs.core/IReduce
cljs.core/map? cljs.core/IMap
cljs.core/list? cljs.core/IList
cljs.core/record? cljs.core/IRecord
cljs.core/vector? cljs.core/IVector
cljs.core/chunked-seq? cljs.core/IChunkedSeq
cljs.core/ifn? cljs.core/IFn
;; Composites
cljs.core/seqable? #{cljs.core/ISeqable array string}
cljs.core/ident? #{cljs.core/Keyword cljs.core/Symbol}
})
(defn- simple-predicate-induced-tag
"Look for a predicate-induced tag when the test expression is a simple
application of a predicate to a local, as in (string? x)."
[env test]
(when (and (list? test)
(== 2 (count test))
(every? symbol? test))
(let [analyzed-fn (no-warn (analyze (assoc env :context :expr) (first test)))]
(when (= :var (:op analyzed-fn))
(when-let [tag (predicate->tag (:name analyzed-fn))]
(let [sym (last test)]
(when (and (nil? (namespace sym))
(get-in env [:locals sym]))
[sym tag])))))))
(defn- type-check-induced-tag
"Look for a type-check-induced tag when the test expression is the use of
instance? on a local, as in (instance? ICounted x)."
[env test]
(when (and (list? test)
(== 3 (count test))
(every? symbol? test))
(let [analyzed-fn (no-warn (analyze (assoc env :context :expr) (first test)))]
(when (= :var (:op analyzed-fn))
(when ('#{cljs.core/instance?} (:name analyzed-fn))
(let [analyzed-type (no-warn (analyze (assoc env :context :expr) (second test)))
tag (:name analyzed-type)
sym (last test)]
(when (and (= :var (:op analyzed-type))
(nil? (namespace sym))
(get-in env [:locals sym]))
[sym tag])))))))
(defn- add-predicate-induced-tags
"Looks at the test and adds any tags which are induced by virtue
of the predicate being satisfied. For example in (if (string? x) x :bar)
the local x in the then branch must be of string type."
[env test]
(let [[local tag] (or (simple-predicate-induced-tag env test)
(type-check-induced-tag env test))]
(cond-> env
local (update-in [:locals local :tag] (fn [prev-tag]
(if (or (nil? prev-tag)
(= 'any prev-tag))
tag
prev-tag))))))
(defmethod parse 'if
[op env [_ test then else :as form] name _]
(when (< (count form) 3)
(throw (error env "Too few arguments to if")))
(when (> (count form) 4)
(throw (error env "Too many arguments to if")))
(let [test-expr (disallowing-recur (analyze (assoc env :context :expr) test))
then-expr (allowing-redef (analyze (add-predicate-induced-tags env test) then))
else-expr (allowing-redef (analyze env else))]
{:env env :op :if :form form
:test test-expr :then then-expr :else else-expr
:unchecked *unchecked-if*
:children [:test :then :else]}))
(defmethod parse 'case*
[op env [_ sym tests thens default :as form] name _]
(assert (symbol? sym) "case* must switch on symbol")
(assert (every? vector? tests) "case* tests must be grouped in vectors")
(let [expr-env (assoc env :context :expr)
v (disallowing-recur (analyze expr-env sym))
tests (mapv #(mapv (fn [t] (analyze expr-env t)) %) tests)
thens (mapv #(analyze env %) thens)
nodes (mapv (fn [tests then]
{:op :case-node
;synthetic node, no :form
:env env
:tests (mapv (fn [test]
{:op :case-test
:form (:form test)
:env expr-env
:test test
:children [:test]})
tests)
:then {:op :case-then
:form (:form then)
:env env
:then then
:children [:then]}
:children [:tests :then]})
tests
thens)
default (analyze env default)]
(assert (every? (fn [t]
(or
(-> t :info :const)
(and (= :const (:op t))
((some-fn number? string? char?) (:form t)))))
(apply concat tests))
"case* tests must be numbers, strings, or constants")
{:env env :op :case :form form
:test v :nodes nodes :default default
:children [:test :nodes :default]}))
(defmethod parse 'throw
[op env [_ throw-form :as form] name _]
(cond
(= 1 (count form))
(throw
(error env "Too few arguments to throw, throw expects a single Error instance"))
(< 2 (count form))
(throw
(error env "Too many arguments to throw, throw expects a single Error instance")))
(let [throw-expr (disallowing-recur (analyze (assoc env :context :expr) throw-form))]
{:env env :op :throw :form form
:exception throw-expr
:children [:exception]}))
(defmethod parse 'try
[op env [_ & body :as form] name _]
(let [catchenv (update-in env [:context] #(if (= :expr %) :return %))
catch? (every-pred seq? #(= (first %) 'catch))
default? (every-pred catch? #(= (second %) :default))
finally? (every-pred seq? #(= (first %) 'finally))
{:keys [body cblocks dblock fblock]}
(loop [parser {:state :start :forms body
:body [] :cblocks [] :dblock nil :fblock nil}]
(if (seq? (:forms parser))
(let [[form & forms*] (:forms parser)
parser* (assoc parser :forms forms*)]
(case (:state parser)
:start (cond
(catch? form) (recur (assoc parser :state :catches))
(finally? form) (recur (assoc parser :state :finally))
:else (recur (update-in parser* [:body] conj form)))
:catches (cond
(default? form) (recur (assoc parser* :dblock form :state :finally))
(catch? form) (recur (update-in parser* [:cblocks] conj form))
(finally? form) (recur (assoc parser :state :finally))
:else (throw (error env "Invalid try form")))
:finally (recur (assoc parser* :fblock form :state :done))
:done (throw (error env "Unexpected form after finally"))))
parser))
finally (when (seq fblock)
(-> (disallowing-recur (analyze (assoc env :context :statement) `(do ~@(rest fblock))))
(assoc :body? true)))
e (when (or (seq cblocks) dblock) (gensym "e"))
default (if-let [[_ _ name & cb] dblock]
`(cljs.core/let [~name ~e] ~@cb)
`(throw ~e))
cblock (if (seq cblocks)
`(cljs.core/cond
~@(mapcat
(fn [[_ type name & cb]]
(when name (assert (not (namespace name)) "Can't qualify symbol in catch"))
`[(cljs.core/instance? ~type ~e)
(cljs.core/let [~name ~e] ~@cb)])
cblocks)
:else ~default)
default)
locals (:locals catchenv)
locals (if e
(assoc locals e
{:name e
:line (get-line e env)
:column (get-col e env)})
locals)
catch (when cblock
(disallowing-recur (analyze (assoc catchenv :locals locals) cblock)))
try (disallowing-recur (analyze (if (or e finally) catchenv env) `(do ~@body)))]
{:env env :op :try :form form
:body (assoc try :body? true)
:finally finally
:name e
:catch catch
:children (vec
(concat [:body]
(when catch
[:catch])
(when finally
[:finally])))}))
(defn valid-proto [x]
(when (symbol? x) x))
(defn elide-env [env ast opts]
(dissoc ast :env))
(defn replace-env-pass [new-env]
(fn [env ast opts]
(assoc ast :env new-env)))
(defn ast-children [ast]
(mapcat (fn [c]
(let [g (get ast c)]
(cond
(vector? g) g
g [g])))
(:children ast)))
(defn constant-value?
[{:keys [op] :as ast}]
(or (#{:quote :const} op)
(and (#{:map :set :vector} op)
(every? constant-value? (ast-children ast)))))
(defn const-expr->constant-value [{:keys [op] :as e}]
(case op
:quote (const-expr->constant-value (:expr e))
:const (:val e)
:map (zipmap (map const-expr->constant-value (:keys e))
(map const-expr->constant-value (:vals e)))
:set (into #{} (map const-expr->constant-value (:items e)))
:vector (into [] (map const-expr->constant-value (:items e)))))
(defn- earmuffed? [sym]
(let [s (name sym)]
(and (> (count s) 2)
(string/starts-with? s "*")
(string/ends-with? s "*"))))
(defn- core-ns? [ns-sym]
(let [s (name ns-sym)]
(and (not= 'cljs.user ns-sym)
(or (string/starts-with? s "cljs.")
(string/starts-with? s "clojure.")))))
(defmethod parse 'def
[op env form _ _]
(when (> (count form) 4)
(throw (error env "Too many arguments to def")))
(let [pfn (fn
([_ sym] {:sym sym})
([_ sym init] {:sym sym :init init})
([_ sym doc init] {:sym sym :doc doc :init init}))
args (apply pfn form)
sym (:sym args)
const? (-> sym meta :const)
sym-meta (meta sym)
tag (-> sym meta :tag)
protocol (-> sym meta :protocol valid-proto)
dynamic (-> sym meta :dynamic)
ns-name (-> env :ns :name)
locals (:locals env)
clash-ns (symbol (str ns-name "." sym))
sym-ns (namespace sym)
sym (cond
(and sym-ns (not #?(:clj (= (symbol sym-ns) ns-name)
:cljs (symbol-identical? (symbol sym-ns) ns-name))))
(throw (error env (str "Can't def ns-qualified name in namespace " sym-ns)))
(some? sym-ns)
(symbol (name sym))
:else sym)]
(when (some? (get-in @env/*compiler* [::namespaces clash-ns]))
(warning :ns-var-clash env
{:ns (symbol (str ns-name "." sym))
:var (symbol (str ns-name) (str sym))}))
(when (some? (:const (resolve-var (dissoc env :locals) sym)))
(throw (error env "Can't redefine a constant")))
(when-some [doc (:doc args)]
(when-not (string? doc)
(throw (error env "Too many arguments to def"))))
(when (and (not dynamic)
(earmuffed? sym)
(not (core-ns? ns-name)))
(warning :non-dynamic-earmuffed-var env
{:var (str sym)}))
(when-some [v (get-in @env/*compiler* [::namespaces ns-name :defs sym])]
(when (and (not *allow-redef*)
(not (:declared v))
(not (:declared sym-meta))
*file-defs*
(get @*file-defs* sym))
(warning :redef-in-file env {:sym sym :line (:line v)}))
(when (and (:declared v)
(:arglists v)
(not= (:arglists v) (:arglists sym-meta)))
(warning :declared-arglists-mismatch env {:ns-name ns-name :sym sym
:declared (second (:arglists v))
:defined (second (:arglists sym-meta))})))
(let [env (if (or (and (not= ns-name 'cljs.core)
(core-name? env sym))
(some? (get-in @env/*compiler* [::namespaces ns-name :uses sym])))
(let [ev (resolve-existing-var (dissoc env :locals)
;; ::no-resolve true is to suppress "can't take value
;; of macro warning" when sym resolves to a macro
(with-meta sym {::no-resolve true}))
conj-to-set (fnil conj #{})]
(when (public-name? (:ns ev) sym)
(warning :redef env {:sym sym :ns (:ns ev) :ns-name ns-name}))
(swap! env/*compiler* update-in [::namespaces ns-name :excludes]
conj-to-set sym)
(update-in env [:ns :excludes] conj-to-set sym))
env)
var-name (:name (resolve-var (dissoc env :locals) sym))
init-expr (when (contains? args :init)
(swap! env/*compiler* assoc-in [::namespaces ns-name :defs sym]
(merge
{:name var-name}
sym-meta
(when (true? dynamic) {:dynamic true})
(source-info var-name env)))
(disallowing-recur
(disallowing-ns*
(analyze (assoc env :context :expr) (:init args) sym))))
fn-var? (and (some? init-expr) (= (:op init-expr) :fn))
tag (if fn-var?
(or (:ret-tag init-expr) tag (:inferred-ret-tag init-expr))
(or tag (:tag init-expr)))
export-as (when-let [export-val (-> sym meta :export)]
(if (= true export-val) var-name export-val))
doc (or (:doc args) (-> sym meta :doc))]
(when-some [v (get-in @env/*compiler* [::namespaces ns-name :defs sym])]
(when (and (not (-> sym meta :declared))
(and (true? (:fn-var v)) (not fn-var?)))
(warning :fn-var env {:ns-name ns-name :sym sym})))
;; declare must not replace any analyzer data of an already def'd sym
(when (or (nil? (get-in @env/*compiler* [::namespaces ns-name :defs sym]))
(not (:declared sym-meta)))
(when *file-defs*
(swap! *file-defs* conj sym))
(swap! env/*compiler* assoc-in [::namespaces ns-name :defs sym]
(merge
{:name var-name}
;; remove actual test metadata, as it includes non-valid EDN and
;; cannot be present in analysis cached to disk - David
(cond-> sym-meta
(:test sym-meta) (assoc :test true))
{:meta (-> sym-meta
(dissoc :test)
(update-in [:file]
(fn [f]
(if (= (-> env :ns :name) 'cljs.core)
"cljs/core.cljs"
f))))}
(when doc {:doc doc})
(when const?
(let [const-expr
(binding [*passes* (conj *passes* (replace-env-pass {:context :expr}))]
(analyze env (:init args)))]
(when (constant-value? const-expr)
{:const-expr const-expr})))
(when (true? dynamic) {:dynamic true})
(source-info var-name env)
;; the protocol a protocol fn belongs to
(when protocol
{:protocol protocol})
;; symbol for reified protocol
(when-let [protocol-symbol (-> sym meta :protocol-symbol)]
{:protocol-symbol protocol-symbol
:info (-> protocol-symbol meta :protocol-info)
:impls #{}})
(when fn-var?
(let [params (map #(vec (map :name (:params %))) (:methods init-expr))]
(merge
{:fn-var (not (:macro sym-meta))
;; protocol implementation context
:protocol-impl (:protocol-impl init-expr)
;; inline protocol implementation context
:protocol-inline (:protocol-inline init-expr)}
(if-some [top-fn-meta (:top-fn sym-meta)]
top-fn-meta
{:variadic? (:variadic? init-expr)
:max-fixed-arity (:max-fixed-arity init-expr)
:method-params params
:arglists (:arglists sym-meta)
:arglists-meta (doall (map meta (:arglists sym-meta)))}))))
(when (and (:declared sym-meta)
(:arglists sym-meta))
{:declared true
:fn-var true
:method-params (second (:arglists sym-meta))})
(if (and fn-var? (some? tag))
{:ret-tag tag}
(when tag {:tag tag})))))
(merge
{:env env
:op :def
:form form
:ns ns-name
:name var-name
:var (assoc
(analyze
(-> env (dissoc :locals)
(assoc :context :expr)
(assoc :def-var true))
sym)
:op :var)
:doc doc
:jsdoc (:jsdoc sym-meta)}
(when (true? (:def-emits-var env))
{:var-ast (var-ast env sym)})
(when-some [test (:test sym-meta)]
{:test (analyze (assoc env :context :expr) test)})
(when (some? tag)
(if fn-var?
{:ret-tag tag}
{:tag tag}))
(when (true? dynamic) {:dynamic true})
(when (some? export-as) {:export export-as})
(if (some? init-expr)
{:init init-expr
:children [:var :init]}
{:children [:var]})))))
(defn analyze-fn-method-param [env]
(fn [[locals params] [arg-id name]]
(when (namespace name)
(throw (error env (str "Can't use qualified name as parameter: " name))))
(let [line (get-line name env)
column (get-col name env)
nmeta (meta name)
tag (:tag nmeta)
shadow (when (some? locals)
(handle-symbol-local name (locals name)))
env (merge (select-keys env [:context])
{:line line :column column})
param {:op :binding
:name name
:line line
:column column
:tag tag
:shadow shadow
:local :arg
:arg-id arg-id
;; Give the fn params the same shape
;; as a :var, so it gets routed
;; correctly in the compiler
:env env
:info {:name name :shadow shadow}
:binding-form? true}]
[(assoc locals name param) (conj params param)])))
(defn analyze-fn-method-body [env form recur-frames]
(binding [*recur-frames* recur-frames]
(analyze env form)))
(defn- analyze-fn-method [env locals form type analyze-body?]
(let [param-names (first form)
variadic (boolean (some '#{&} param-names))
param-names (vec (remove '#{&} param-names))
body (next form)
step (analyze-fn-method-param env)
step-init [locals []]
[locals params] (reduce step step-init (map-indexed vector param-names))
params' (if (true? variadic)
(butlast params)
params)
fixed-arity (count params')
recur-frame {:protocol-impl (:protocol-impl env)
:params params
:flag (atom nil)}
recur-frames (cons recur-frame *recur-frames*)
body-env (assoc env :context :return :locals locals)
body-form `(do ~@body)
expr (when analyze-body?
(analyze-fn-method-body body-env body-form recur-frames))
recurs @(:flag recur-frame)]
(merge
{:env env
:op :fn-method
:variadic? variadic
:params params
:fixed-arity fixed-arity
:type type
:form form
:recurs recurs}
(if (some? expr)
{:body (assoc expr :body? true)
:children [:params :body]}
{:children [:params]}))))
(declare analyze-wrap-meta)
(defn fn-name-var [env locals name]
(when (some? name)
(let [ns (-> env :ns :name)
shadow (handle-symbol-local name (get locals name))
shadow (when (nil? shadow)
(get-in env [:js-globals name]))
fn-scope (:fn-scope env)
name-var {:name name
:op :binding
:local :fn
:info {:fn-self-name true
:fn-scope fn-scope
:ns ns
:shadow shadow}}
tag (-> name meta :tag)
ret-tag (when (some? tag)
{:ret-tag tag})]
(merge name-var ret-tag))))
(defn analyze-fn-methods-pass2* [menv locals type meths]
(mapv #(analyze-fn-method menv locals % type true) meths))
(defn analyze-fn-methods-pass2 [menv locals type meths]
(analyze-fn-methods-pass2* menv locals type meths))
(defmethod parse 'fn*
[op env [_ & args :as form] name _]
(let [named-fn? (symbol? (first args))
[name meths] (if named-fn?
[(first args) (next args)]
[name (seq args)])
;; turn (fn [] ...) into (fn ([]...))
meths (if (vector? (first meths))
(list meths)
meths)
locals (:locals env)
name-var (fn-name-var env locals name)
env (if (some? name)
(update-in env [:fn-scope] conj name-var)
env)
locals (if (and (some? locals)
named-fn?)
(assoc locals name name-var)
locals)
form-meta (meta form)
type (::type form-meta)
proto-impl (::protocol-impl form-meta)
proto-inline (::protocol-inline form-meta)
menv (if (> (count meths) 1)
(assoc env :context :expr)
env)
menv (merge menv
{:protocol-impl proto-impl
:protocol-inline proto-inline})
methods (map #(disallowing-ns* (analyze-fn-method menv locals % type (nil? name))) meths)
mfa (transduce (map :fixed-arity) max 0 methods)
variadic (boolean (some :variadic? methods))
locals (if named-fn?
(update-in locals [name] assoc
;; TODO: can we simplify? - David
:fn-var true
:variadic? variadic
:max-fixed-arity mfa
:method-params (map :params methods))
locals)
methods (if (some? name)
;; a second pass with knowledge of our function-ness/arity
;; lets us optimize self calls
(disallowing-ns* (analyze-fn-methods-pass2 menv locals type meths))
(vec methods))
form (vary-meta form dissoc ::protocol-impl ::protocol-inline ::type)
js-doc (when (true? variadic)
"@param {...*} var_args")
children (if (some? name-var)
[:local :methods]
[:methods])
inferred-ret-tag (let [inferred-tags (map (partial infer-tag env) (map :body methods))]
(when (apply = inferred-tags)
(first inferred-tags)))
ast (merge {:op :fn
:env env
:form form
:name name-var
:methods methods
:variadic? variadic
:tag 'function
:inferred-ret-tag inferred-ret-tag
:recur-frames *recur-frames*
:loop-lets *loop-lets*
:jsdoc [js-doc]
:max-fixed-arity mfa
:protocol-impl proto-impl
:protocol-inline proto-inline
:children children}
(when (some? name-var)
{:local name-var}))]
(let [variadic-methods (into []
(comp (filter :variadic?) (take 1))
methods)
variadic-params (if (pos? (count variadic-methods))
(count (:params (nth variadic-methods 0)))
0)
param-counts (into [] (map (comp count :params)) methods)]
(when (< 1 (count variadic-methods))
(warning :multiple-variadic-overloads env {:name name-var}))
(when (not (or (zero? variadic-params) (== variadic-params (+ 1 mfa))))
(warning :variadic-max-arity env {:name name-var}))
(when (not= (distinct param-counts) param-counts)
(warning :overload-arity env {:name name-var})))
(analyze-wrap-meta ast)))
(defmethod parse 'letfn*
[op env [_ bindings & exprs :as form] name _]
(when-not (and (vector? bindings) (even? (count bindings)))
(throw (error env "bindings must be vector of even number of elements")))
(let [n->fexpr (into {} (map (juxt first second) (partition 2 bindings)))
names (keys n->fexpr)
context (:context env)
;; first pass to collect information for recursive references
[meth-env bes]
(reduce (fn [[{:keys [locals] :as env} bes] n]
(let [ret-tag (-> n meta :tag)
fexpr (no-warn (analyze env (n->fexpr n)))
be (cond->
{:name n
:op :binding
:fn-var true
:line (get-line n env)
:column (get-col n env)
:local :letfn
:shadow (handle-symbol-local n (locals n))
:variadic? (:variadic? fexpr)
:max-fixed-arity (:max-fixed-arity fexpr)
:method-params (map :params (:methods fexpr))}
ret-tag (assoc :ret-tag ret-tag))]
[(assoc-in env [:locals n] be)
(conj bes be)]))
[env []] names)
meth-env (assoc meth-env :context :expr)
;; the real pass
[meth-env bes]
(reduce (fn [[meth-env bes] {:keys [name shadow] :as be}]
(let [env (assoc-in meth-env [:locals name] shadow)
fexpr (analyze env (n->fexpr name))
be' (assoc be
:init fexpr
:variadic? (:variadic? fexpr)
:max-fixed-arity (:max-fixed-arity fexpr)
:method-params (map :params (:methods fexpr)))]
[(assoc-in env [:locals name] be')
(conj bes be')]))
[meth-env []] bes)
expr (-> (analyze (assoc meth-env :context (if (= :expr context) :return context)) `(do ~@exprs))
(assoc :body? true))]
{:env env :op :letfn :bindings bes :body expr :form form
:children [:bindings :body]}))
(defn analyze-do-statements* [env exprs]
(mapv #(analyze (assoc env :context :statement) %) (butlast exprs)))
(defn analyze-do-statements [env exprs]
(disallowing-recur (analyze-do-statements* env exprs)))
(defmethod parse 'do
[op env [_ & exprs :as form] _ _]
(let [statements (analyze-do-statements env exprs)]
(if (<= (count exprs) 1)
(let [ret (analyze env (first exprs))
children [:statements :ret]]
{:op :do
:env env
:form form
:statements statements :ret ret
:children children})
(let [ret-env (if (= :statement (:context env))
(assoc env :context :statement)
(assoc env :context :return))
ret (analyze ret-env (last exprs))
children [:statements :ret]]
{:op :do
:env env
:form form
:statements statements
:ret ret
:children children}))))
(defn analyze-let-binding-init [env init loop-lets]
(binding [*loop-lets* loop-lets]
(analyze env init)))
(defn get-let-tag [name init-expr]
(if-some [tag (-> name meta :tag)]
tag
(if-some [tag (-> init-expr :tag)]
tag
(-> init-expr :info :tag))))
(defn analyze-let-bindings* [encl-env bindings op]
(loop [bes []
env (assoc encl-env :context :expr)
bindings (seq (partition 2 bindings))]
(if-some [[name init] (first bindings)]
(let []
(when (or (some? (namespace name))
#?(:clj (.contains (str name) ".")
:cljs ^boolean (goog.string/contains (str name) ".")))
(throw (error encl-env (str "Invalid local name: " name))))
(let [init-expr (analyze-let-binding-init env init (cons {:params bes} *loop-lets*))
line (get-line name env)
col (get-col name env)
shadow (handle-symbol-local name (get-in env [:locals name]))
be {:name name
:line line
:column col
:init init-expr
:tag (get-let-tag name init-expr)
:local op
:shadow shadow
;; Give let* bindings same shape as var so
;; they get routed correctly in the compiler
:op :binding
:env {:line line :column col}
:info {:name name
:shadow shadow}
:binding-form? true}
be (if (= :fn (:op init-expr))
;; TODO: can we simplify - David
(merge be
{:fn-var true
;; copy over the :fn-method information we need for invoke type inference
:methods (into [] (map #(select-keys % [:tag :fixed-arity :variadic?]) (:methods init-expr)))
:variadic? (:variadic? init-expr)
:max-fixed-arity (:max-fixed-arity init-expr)
:method-params (map :params (:methods init-expr))})
be)
be (add-identity be)]
(recur (conj bes be)
(assoc-in env [:locals name] be)
(next bindings))))
[bes env])))
(defn analyze-let-bindings [encl-env bindings op]
(disallowing-recur (analyze-let-bindings* encl-env bindings op)))
(defn analyze-let-body* [env context exprs]
(analyze (assoc env :context (if (= :expr context) :return context)) `(do ~@exprs)))
(defn analyze-let-body [env context exprs recur-frames loop-lets]
(binding [*recur-frames* recur-frames
*loop-lets* loop-lets]
(analyze-let-body* env context exprs)))
(defn analyze-let
[encl-env [_ bindings & exprs :as form] is-loop]
(when-not (and (vector? bindings) (even? (count bindings)))
(throw (error encl-env "bindings must be vector of even number of elements")))
(let [context (:context encl-env)
op (if (true? is-loop) :loop :let)
[bes env] (analyze-let-bindings encl-env bindings op)
recur-frame (when (true? is-loop)
{:params bes :flag (atom nil)})
recur-frames (if recur-frame
(cons recur-frame *recur-frames*)
*recur-frames*)
loop-lets (cond
(true? is-loop) *loop-lets*
(some? *loop-lets*) (cons {:params bes} *loop-lets*))
expr (analyze-let-body env context exprs recur-frames loop-lets)
children [:bindings :body]]
{:op op
:env encl-env
:bindings bes
:body (assoc expr :body? true)
:form form
:children children}))
(defmethod parse 'let*
[op encl-env form _ _]
(analyze-let encl-env form false))
(defmethod parse 'loop*
[op encl-env form _ _]
(analyze-let encl-env form true))
(defmethod parse 'recur
[op env [_ & exprs :as form] _ _]
(let [context (:context env)
frame (first *recur-frames*)
;; Add dummy implicit target object if recuring to proto impl method head
add-implicit-target-object? (and (:protocol-impl frame)
(= (count exprs) (dec (count (:params frame)))))
exprs (cond->> exprs add-implicit-target-object? (cons nil))
exprs (disallowing-recur (vec (map #(analyze (assoc env :context :expr) %) exprs)))]
(when-not frame
(throw (error env "Can't recur here")))
(when-not (= (count exprs) (count (:params frame)))
(throw (error env (str "recur argument count mismatch, expected: "
(count (:params frame)) " args, got: " (count exprs)))))
(when (and (:protocol-impl frame)
(not add-implicit-target-object?))
(warning :protocol-impl-recur-with-target env {:form (:form (first exprs))}))
(reset! (:flag frame) true)
(assoc {:env env :op :recur :form form}
:frame frame
:exprs exprs
:children [:exprs])))
(defn analyze-const
[env form]
(let [;; register constants
{:keys [tag]} (analyze (assoc env :quoted? true) form)]
{:op :const
:env env
:literal? true
:val form
:tag tag
:form form}))
(defmethod parse 'quote
[_ env [_ x :as form] _ _]
(when (not= 2 (count form))
(throw (error env "Wrong number of args to quote")))
(let [expr (analyze-const env x)]
{:op :quote
:expr expr
:env env
:form form
:tag (:tag expr)
:children [:expr]}))
(defmethod parse 'new
[_ env [_ ctor & args :as form] _ _]
(disallowing-recur
(let [enve (assoc env :context :expr)
ctorexpr (analyze enve ctor)
ctor-var (when (#{:var :local :js-var} (:op ctorexpr))
(resolve-existing-var env ctor))
record-args
(when (and (:record ctor-var) (not (-> ctor meta :internal-ctor)))
(repeat 3 (analyze enve nil)))
argexprs (into (vec (map #(analyze enve %) args)) record-args)
known-num-fields (:num-fields ctor-var)
argc (count args)]
(when (and (not (-> ctor meta :internal-ctor))
(some? known-num-fields) (not= known-num-fields argc))
(warning :fn-arity env {:argc argc :ctor ctor}))
{:env env :op :new :form form :class ctorexpr :args argexprs
:children [:class :args]
:tag (let [name (-> ctorexpr :info :name)]
(or ('{js/Object object
js/String string
js/Array array
js/Number number
js/Function function
js/Boolean boolean} name)
name))})))
(defmethod parse 'set!
[_ env [_ target val alt :as form] _ _]
(let [[target val] (if alt
;; (set! o -prop val)
[`(. ~target ~val) alt]
[target val])]
(disallowing-recur
(binding [*private-var-access-nowarn* true]
(let [enve (assoc env :context :expr)
texpr (cond
(symbol? target)
(do
(cond
(and (= target '*unchecked-if*) ;; TODO: proper resolve
(or (true? val) (false? val)))
(set! *unchecked-if* val)
(and (= target '*unchecked-arrays*) ;; TODO: proper resolve
(or (true? val) (false? val)))
(set! *unchecked-arrays* val)
(and (= target '*warn-on-infer*)
(or (true? val) (false? val)))
(set! *cljs-warnings* (assoc *cljs-warnings* :infer-warning val)))
(when (some? (:const (resolve-var (dissoc env :locals) target)))
(throw (error env "Can't set! a constant")))
(let [local (handle-symbol-local target (-> env :locals target))]
(when-not (or (nil? local)
(and (:field local)
(or (:mutable local)
(:unsynchronized-mutable local)
(:volatile-mutable local))))
(throw (error env "Can't set! local var or non-mutable field"))))
(analyze-symbol enve target))
:else
(when (seq? target)
(let [texpr (analyze-seq enve target nil)]
(when (:field texpr)
texpr))))
vexpr (analyze enve val)]
;; as top level fns are decomposed for Closure cross-module code motion, we need to
;; restore their :methods information
(when (seq? target)
(let [sym (some-> target second)
meta (meta sym)]
(when-let [info (and (= :fn (:op vexpr)) (:top-fn meta))]
(swap! env/*compiler* update-in
[::namespaces (-> env :ns :name) :defs sym :methods]
(fnil conj [])
;; just use original fn meta, as the fn method is already desugared
;; only get tag from analysis
(merge
(select-keys info [:fixed-arity :variadic?])
(select-keys (-> vexpr :methods first) [:tag]))))))
(when-not texpr
(throw (error env "set! target must be a field or a symbol naming a var")))
(cond
(and (not (:def-emits-var env)) ;; non-REPL context
(some? ('#{*unchecked-if* *unchecked-arrays* *warn-on-infer*} target)))
{:env env :op :no-op}
:else
{:env env :op :set! :form form :target texpr :val vexpr
:children [:target :val]}))))))
#?(:clj (declare analyze-file))
#?(:clj
(defn locate-src
"Given a namespace return the corresponding ClojureScript (.cljs or .cljc)
resource on the classpath or file from the root of the build."
[ns]
(or (util/ns->source ns)
;; Find sources available in inputs given to cljs.closure/build - Juho Teperi
(some (fn [source]
(if (= ns (:ns source))
(:source-file source)))
(:sources @env/*compiler*))
;; Find sources in directory given to cljs.compiler/compile-root - Juho Teperi
(let [rootp (when-let [root (:root @env/*compiler*)]
(.getPath ^File root))
cljsf (io/file rootp (ns->relpath ns :cljs))
cljcf (io/file rootp (ns->relpath ns :cljc))]
(if (and (.exists cljsf) (.isFile cljsf))
cljsf
(if (and (.exists cljcf) (.isFile cljcf))
cljcf))))))
(defn foreign-dep?
#?(:cljs {:tag boolean})
[dep]
(let [js-index (:js-dependency-index @env/*compiler*)]
(if-some [[_ {:keys [foreign]}] (find js-index (name dep))]
foreign
false)))
(defn analyze-deps
"Given a lib, a namespace, deps, its dependencies, env, an analysis environment
and opts, compiler options - analyze all of the dependencies. Required to
correctly analyze usage of other namespaces."
([lib deps env]
(analyze-deps lib deps env
(when env/*compiler*
(:options @env/*compiler*))))
([lib deps env opts]
(let [compiler @env/*compiler*]
(binding [*cljs-dep-set* (vary-meta (conj *cljs-dep-set* lib) update-in [:dep-path] conj lib)]
(assert (every? #(not (contains? *cljs-dep-set* %)) deps)
(str "Circular dependency detected, "
(apply str
(interpose " -> "
(conj (-> *cljs-dep-set* meta :dep-path)
(some *cljs-dep-set* deps))))))
(doseq [dep deps]
(when-not (or (some? (get-in compiler [::namespaces dep :defs]))
(contains? (:js-dependency-index compiler) (name dep))
(node-module-dep? dep)
(js-module-exists? (name dep))
#?(:clj (deps/find-classpath-lib dep)))
#?(:clj (if-some [src (locate-src dep)]
(analyze-file src opts)
(throw
(error env
(error-message :undeclared-ns {:ns-sym dep :js-provide (name dep)}))))
:cljs (throw
(error env
(error-message :undeclared-ns {:ns-sym dep :js-provide (name dep)}))))))))))
(defn missing-use? [lib sym cenv]
(let [js-lib (get-in cenv [:js-dependency-index (name lib)])]
(and (= (get-in cenv [::namespaces lib :defs sym] ::not-found) ::not-found)
(not (= (get js-lib :group) :goog))
(not (get js-lib :closure-lib))
(not (node-module-dep? lib))
(not (dep-has-global-exports? lib)))))
(defn missing-rename? [sym cenv]
(let [lib (symbol (namespace sym))
sym (symbol (name sym))]
(missing-use? lib sym cenv)))
(defn missing-use-macro? [lib sym]
;; guard against string requires
(when (symbol? lib)
(let [the-ns #?(:clj (find-ns lib) :cljs (find-macros-ns lib))]
(or (nil? the-ns) (nil? (.findInternedVar ^clojure.lang.Namespace the-ns sym))))))
(defn missing-rename-macro? [sym]
(let [lib (symbol (namespace sym))
sym (symbol (name sym))
the-ns #?(:clj (find-ns lib) :cljs (find-macros-ns lib))]
(or (nil? the-ns) (nil? (.findInternedVar ^clojure.lang.Namespace the-ns sym)))))
;; returns (s/map-of symbol? symbol?)
(defn missing-uses
[uses env]
(let [cenv @env/*compiler*]
(into {} (filter (fn [[sym lib]] (missing-use? lib sym cenv)) uses))))
;; returns (s/map-of symbol? qualified-symbol?)
(defn missing-renames [renames env]
(let [cenv @env/*compiler*]
(into {} (filter (fn [[_ qualified-sym]] (missing-rename? qualified-sym cenv)) renames))))
;; returns (s/map-of symbol? symbol?)
(defn missing-use-macros [use-macros env]
(let [cenv @env/*compiler*]
(into {} (filter (fn [[sym lib]] (missing-use-macro? lib sym)) use-macros))))
;; returns (s/map-of symbol? symbol?)
(defn inferred-use-macros [use-macros env]
(let [cenv @env/*compiler*]
(into {} (filter (fn [[sym lib]] (not (missing-use-macro? lib sym))) use-macros))))
;; returns (s/map-of symbol? symbol?)
(defn inferred-rename-macros [rename-macros env]
(into {} (filter (fn [[_ qualified-sym]] (not (missing-rename-macro? qualified-sym))) rename-macros)))
(defn check-uses [uses env]
(let [cenv @env/*compiler*]
(doseq [[sym lib] uses]
(when (missing-use? lib sym cenv)
(throw
(error env
(error-message :undeclared-ns-form {:type "var" :lib lib :sym sym})))))))
(defn check-use-macros
([use-macros env]
(check-use-macros use-macros nil env))
([use-macros missing-uses env]
(let [cenv @env/*compiler*]
(doseq [[sym lib] use-macros]
(when (missing-use-macro? lib sym)
(throw
(error env
(error-message :undeclared-ns-form {:type "macro" :lib lib :sym sym})))))
(check-uses (missing-use-macros missing-uses env) env)
(inferred-use-macros missing-uses env))))
(defn check-use-macros-inferring-missing
[{:keys [name uses use-macros] :as ast} env]
(let [missing-uses (when (and *analyze-deps* (seq uses))
(missing-uses uses env))
maybe-macros (apply dissoc uses (keys missing-uses))
remove-missing-uses #(apply dissoc % (keys missing-uses))
ast' (-> ast
(update-in [:use-macros]
#(-> %
(merge (check-use-macros use-macros missing-uses env))
(merge (inferred-use-macros maybe-macros env))))
(update-in [:uses] remove-missing-uses))]
(swap! env/*compiler*
#(-> %
(update-in [::namespaces name :use-macros] merge (:use-macros ast'))
(update-in [::namespaces name :uses] remove-missing-uses)))
ast'))
(defn check-rename-macros-inferring-missing
[{:keys [name renames] :as ast} env]
(let [missing-renames (when (and *analyze-deps* (seq renames))
(missing-renames renames env))
maybe-macros (apply dissoc renames (keys missing-renames))
missing-rename-macros (inferred-rename-macros missing-renames env)
remove-missing-renames #(apply dissoc % (keys missing-renames))
ast' (-> ast
(update-in [:rename-macros]
#(-> %
(merge missing-rename-macros)
(merge (inferred-rename-macros maybe-macros env))))
(update-in [:renames] remove-missing-renames))]
(swap! env/*compiler*
#(-> %
(update-in [::namespaces name :rename-macros] merge (:rename-macros ast'))
(update-in [::namespaces name :renames] remove-missing-renames)))
ast'))
(defn parse-ns-error-msg [spec msg]
(str msg "; offending spec: " (pr-str spec)))
(defn basic-validate-ns-spec [env macros? spec]
(when-not (or (symbol? spec) (string? spec) (sequential? spec))
(throw
(error env
(parse-ns-error-msg spec
"Only [lib.ns & options] and lib.ns specs supported in :require / :require-macros"))))
(when (sequential? spec)
(when-not (or (symbol? (first spec)) (string? (first spec)))
(throw
(error env
(parse-ns-error-msg spec
"Library name must be specified as a symbol in :require / :require-macros"))))
(when-not (odd? (count spec))
(throw
(error env
(parse-ns-error-msg spec
"Only :as alias, :refer (names) and :rename {from to} options supported in :require"))))
(when-not (every? #{:as :refer :rename} (map first (partition 2 (next spec))))
(throw
(error env
(parse-ns-error-msg spec
"Only :as, :refer and :rename options supported in :require / :require-macros"))))
(when-not (let [fs (frequencies (next spec))]
(and (<= (fs :as 0) 1)
(<= (fs :refer 0) 1)))
(throw
(error env
(parse-ns-error-msg spec
"Each of :as and :refer options may only be specified once in :require / :require-macros"))))))
(defn parse-ns-excludes [env args]
(reduce
(fn [s [k & filters]]
(if (= k :refer-clojure)
(do
(when (seq (:excludes s))
(throw (error env "Only one :refer-clojure form is allowed per namespace definition")))
(let [valid-kws #{:exclude :rename}
xs
(loop [fs (seq filters)
ret {:excludes #{}
:renames {}}
err (not (even? (count filters)))]
(cond
(true? err)
(throw
(error env "Only [:refer-clojure :exclude (names)] and optionally `:rename {from to}` specs supported"))
(some? fs)
(let [kw (first fs)]
(if (valid-kws kw)
(let [refs (second fs)]
(cond
(not (or (and (= kw :exclude) (sequential? refs) (every? symbol? refs))
(and (= kw :rename) (map? refs) (every? #(every? symbol? %) refs))))
(recur fs ret true)
(= kw :exclude)
(recur (nnext fs) (update-in ret [:excludes] into refs) false)
(= kw :rename)
(recur (nnext fs) (update-in ret [:renames] merge refs) false)))
(recur fs ret true)))
:else ret))]
(merge-with into s xs)))
s))
{:excludes #{}
:renames {}} args))
(defn use->require [env [lib & filters :as spec]]
(when-not (and (symbol? lib) (odd? (count spec)))
(throw
(error env
(parse-ns-error-msg spec
"Only [lib.ns :only (names)] and optionally `:rename {from to}` specs supported in :use / :use-macros"))))
(loop [fs (seq filters) ret [lib] err false]
(cond
(true? err)
(throw
(error env
(parse-ns-error-msg spec
"Only [lib.ns :only (names)] and optionally `:rename {from to}` specs supported in :use / :use-macros")))
(some? fs)
(let [kw (first fs)
only? (= kw :only)]
(if (or only? (= kw :rename))
(if (some? (some #{(if only? :refer kw)} ret))
(throw
(error env
(parse-ns-error-msg spec
"Each of :only and :rename options may only be specified once in :use / :use-macros")))
(let [refs (second fs)]
(if-not (or (and only? (sequential? refs) (every? symbol? refs))
(and (= kw :rename) (map? refs) (every? #(every? symbol? %) refs)))
(recur fs ret true)
(recur (nnext fs) (into ret [(if only? :refer kw) refs]) false))))
(recur fs ret true )))
:else (if (some? (some #{:refer} ret))
ret
(recur fs ret true)))))
(defn parse-require-spec [env macros? deps aliases spec]
(if (or (symbol? spec) (string? spec))
(recur env macros? deps aliases [spec])
(do
(basic-validate-ns-spec env macros? spec)
(let [[lib & opts] spec
;; We need to load JS modules by the name that has been created by the
;; Google Closure compiler, e.g. module$resources$libs$calculator.
;; This means that we need to create an alias from the module name
;; given with :provides to the new name.
[lib js-module-provides] (if-some [js-module-name (gets @env/*compiler* :js-module-index (str lib) :name)]
[(symbol js-module-name) lib]
[lib nil])
{alias :as referred :refer renamed :rename
:or {alias (if (string? lib)
(symbol (munge lib))
lib)}}
(apply hash-map opts)
referred-without-renamed (seq (remove (set (keys renamed)) referred))
[rk uk renk] (if macros? [:require-macros :use-macros :rename-macros] [:require :use :rename])]
(when-not (or (symbol? alias) (nil? alias))
(throw
(error env
(parse-ns-error-msg spec
":as must be followed by a symbol in :require / :require-macros"))))
(when (some? alias)
(let [alias-type (if macros? :macros :fns)
lib' ((alias-type @aliases) alias)]
(when (and (some? lib') (not= lib lib'))
(throw (error env (parse-ns-error-msg spec ":as alias must be unique"))))
(swap! aliases
update-in [alias-type]
conj [alias lib] (when js-module-provides [js-module-provides lib]))))
(when-not (or (and (sequential? referred)
(every? symbol? referred))
(nil? referred))
(throw
(error env
(parse-ns-error-msg spec
":refer must be followed by a sequence of symbols in :require / :require-macros"))))
(when-not macros?
(swap! deps conj lib))
(merge
(when (some? alias)
{rk (merge {alias lib} {lib lib}
(when js-module-provides {js-module-provides lib}))})
(when (some? referred-without-renamed)
{uk (apply hash-map (interleave referred-without-renamed (repeat lib)))})
(when (some? renamed)
{renk (reduce (fn [m [original renamed]]
(when-not (some #{original} referred)
(throw (error env
(str "Renamed symbol " original " not referred"))))
(assoc m renamed (symbol (str lib) (str original))))
{} renamed)}))))))
(defn parse-import-spec [env deps spec]
(when-not (or (and (sequential? spec)
(every? symbol? spec))
(and (symbol? spec) (nil? (namespace spec))))
(throw (error env (parse-ns-error-msg spec "Only lib.ns.Ctor or [lib.ns Ctor*] spec supported in :import"))))
(let [import-map (if (sequential? spec)
(->> (rest spec)
(map #(vector % (symbol (str (first spec) "." %))))
(into {}))
{(symbol (last (string/split (str spec) #"\."))) spec})]
(doseq [[_ spec] import-map]
(swap! deps conj spec))
{:import import-map
:require import-map}))
#?(:clj (declare parse-ns))
(defn macro-autoload-ns?
"Given a spec form check whether the spec namespace requires a macro file
of the same name. If so return true."
#?(:cljs {:tag boolean})
[form]
(when *macro-infer*
(let [ns (if (sequential? form) (first form) form)
{:keys [use-macros require-macros]}
(or (get-in @env/*compiler* [::namespaces ns])
#?(:clj
(when-let [res (util/ns->source ns)]
(:ast (parse-ns res)))))]
(or (some #{ns} (vals use-macros))
(some #{ns} (vals require-macros))))))
(defn clj-ns->cljs-ns
"Given a symbol that starts with clojure as the first segment return the
same symbol with the first segment replaced with cljs"
[sym]
(let [segs (string/split (clojure.core/name sym) #"\.")]
(if (= "clojure" (first segs))
(symbol (string/join "." (cons "cljs" (next segs))))
sym)))
#?(:clj
(defn aliasable-clj-ns?
"Predicate for testing with a symbol represents an aliasable clojure namespace."
[sym]
(when-not (util/ns->source sym)
(let [[seg1 :as segs] (string/split (clojure.core/name sym) #"\.")]
(when (= "clojure" seg1)
(let [sym' (clj-ns->cljs-ns sym)]
(util/ns->source sym')))))))
#?(:clj
(defn process-rewrite-form [[k & specs :as form]]
(letfn [(process-spec [maybe-spec]
(let [[lib & xs] (if (sequential? maybe-spec)
maybe-spec
[maybe-spec])]
(if (and (symbol? lib) (aliasable-clj-ns? lib))
(let [lib' (clj-ns->cljs-ns lib)
spec (cons lib' xs)]
(into (if xs [spec] []) [(list lib' :as lib)]))
[maybe-spec])))]
(if (#{:use :require} k)
(cons k (mapcat process-spec specs))
form))))
#?(:clj
(defn rewrite-cljs-aliases
"Alias non-existing clojure.* namespaces to existing cljs.* namespaces if
possible."
[args]
(map process-rewrite-form args)))
(defn canonicalize-specs [specs]
(letfn [(canonicalize [quoted-spec-or-kw]
(if (keyword? quoted-spec-or-kw)
quoted-spec-or-kw
(as-> (second quoted-spec-or-kw) spec
(if (or (vector? spec) (map? spec)) spec [spec]))))]
(map canonicalize specs)))
(defn canonicalize-import-specs [specs]
(letfn [(canonicalize [quoted-spec-or-kw]
(if (keyword? quoted-spec-or-kw)
quoted-spec-or-kw
(second quoted-spec-or-kw)))]
(map canonicalize specs)))
(defn desugar-ns-specs
"Given an original set of ns specs desugar :include-macros and :refer-macros
usage into only primitive spec forms - :use, :require, :use-macros,
:require-macros. If a library includes a macro file of with the same name
as the namespace will also be desugared."
[args]
(let [{:keys [require] :as indexed}
(->> args
(map (fn [[k & specs]] [k (into [] specs)]))
(into {}))
sugar-keys #{:include-macros :refer-macros}
;; drop spec k and value from spec for generated :require-macros
remove-from-spec
(fn [pred spec]
(if-not (and (sequential? spec) (some pred spec))
spec
(let [[l r] (split-with (complement pred) spec)]
(recur pred (concat l (drop 2 r))))))
;; rewrite :refer-macros to :refer for generated :require-macros
replace-refer-macros
(fn [spec]
(if-not (sequential? spec)
spec
(map (fn [x] (if (= x :refer-macros) :refer x)) spec)))
reload-spec? #(#{:reload :reload-all} %)
to-macro-specs
(fn [specs]
(->> specs
(filter
(fn [x]
(or (and (sequential? x)
(some sugar-keys x))
(reload-spec? x)
(macro-autoload-ns? x))))
(map (fn [x]
(if-not (reload-spec? x)
(->> x (remove-from-spec #{:include-macros})
(remove-from-spec #{:refer})
(remove-from-spec #{:rename})
(replace-refer-macros))
x)))))
remove-sugar (partial remove-from-spec sugar-keys)]
(if-some [require-specs (seq (to-macro-specs require))]
(map (fn [x]
(if-not (reload-spec? x)
(let [[k v] x]
(cons k (map remove-sugar v)))
x))
(update-in indexed [:require-macros] (fnil into []) require-specs))
args)))
(defn find-def-clash [env ns segments]
(let [to-check (map (fn [xs]
[(symbol (string/join "." (butlast xs)))
(symbol (last xs))])
(drop 2 (reductions conj [] segments)))]
(doseq [[clash-ns name] to-check]
(when (get-in @env/*compiler* [::namespaces clash-ns :defs name])
(warning :ns-var-clash env
{:ns ns
:var (symbol (str clash-ns) (str name))})))))
(defn macro-ns-name [name]
(let [name-str (str name)]
(if-not #?(:clj (.endsWith name-str "$macros")
:cljs (gstring/endsWith name-str "$macros"))
(symbol (str name-str "$macros"))
name)))
(defmethod parse 'ns
[_ env [_ name & args :as form] _ opts]
(when-not *allow-ns*
(throw (error env "Namespace declarations must appear at the top-level.")))
(when-not (symbol? name)
(throw (error env "Namespaces must be named by a symbol.")))
(let [name (cond-> name (:macros-ns opts) macro-ns-name)]
(let [segments (string/split (clojure.core/name name) #"\.")]
(when (= 1 (count segments))
(warning :single-segment-namespace env {:name name}))
(let [segment (some js-reserved segments)]
(when (some? segment)
(warning :munged-namespace env {:name name})))
(find-def-clash env name segments)
#?(:clj
(when (some (complement util/valid-js-id-start?) segments)
(throw
(AssertionError.
(str "Namespace " name " has a segment starting with an invaild "
"JavaScript identifier"))))))
(let [docstring (when (string? (first args)) (first args))
mdocstr (-> name meta :doc)
args (if (some? docstring) (next args) args)
metadata (when (map? (first args)) (first args))
args (desugar-ns-specs
#?(:clj (rewrite-cljs-aliases
(if metadata (next args) args))
:cljs (if (some? metadata) (next args) args)))
name (vary-meta name merge metadata)
{excludes :excludes core-renames :renames} (parse-ns-excludes env args)
core-renames (reduce (fn [m [original renamed]]
(assoc m renamed (symbol "cljs.core" (str original))))
{} core-renames)
deps (atom [])
aliases (atom {:fns {} :macros {}})
spec-parsers {:require (partial parse-require-spec env false deps aliases)
:require-macros (partial parse-require-spec env true deps aliases)
:use (comp (partial parse-require-spec env false deps aliases)
(partial use->require env))
:use-macros (comp (partial parse-require-spec env true deps aliases)
(partial use->require env))
:import (partial parse-import-spec env deps)}
valid-forms (atom #{:use :use-macros :require :require-macros :import})
reload (atom {:use nil :require nil :use-macros nil :require-macros nil})
reloads (atom {})
{uses :use requires :require renames :rename
use-macros :use-macros require-macros :require-macros
rename-macros :rename-macros imports :import :as params}
(reduce
(fn [m [k & libs :as libspec]]
(when-not (#{:use :use-macros :require :require-macros :import} k)
(throw (error env (str "Only :refer-clojure, :require, :require-macros, :use, :use-macros, and :import libspecs supported. Got " libspec " instead."))))
(when-not (@valid-forms k)
(throw (error env (str "Only one " k " form is allowed per namespace definition"))))
(swap! valid-forms disj k)
;; check for spec type reloads
(when-not (= :import k)
(when (some? (some #{:reload} libs))
(swap! reload assoc k :reload))
(when (some? (some #{:reload-all} libs))
(swap! reload assoc k :reload-all)))
;; check for individual ns reloads from REPL interactions
(when-let [xs (seq (filter #(-> % meta :reload) libs))]
(swap! reloads assoc k
(zipmap (map first xs) (map #(-> % meta :reload) xs))))
(apply merge-with merge m
(map (spec-parsers k)
(remove #{:reload :reload-all} libs))))
{} (remove (fn [[r]] (= r :refer-clojure)) args))
;; patch `require-macros` and `use-macros` in Bootstrap for namespaces
;; that require their own macros
#?@(:cljs [[require-macros use-macros]
(map (fn [spec-map]
(if (:macros-ns opts)
(let [ns (symbol (subs (str name) 0 (- (count (str name)) 7)))]
(reduce (fn [m [k v]]
(cond-> m
(not (symbol-identical? v ns))
(assoc k v)))
{} spec-map))
spec-map)) [require-macros use-macros])])]
(set! *cljs-ns* name)
(let [ns-info
{:name name
:doc (or docstring mdocstr)
:excludes excludes
:use-macros use-macros
:require-macros require-macros
:rename-macros rename-macros
:uses uses
:requires requires
:renames (merge renames core-renames)
:imports imports}]
(swap! env/*compiler* update-in [::namespaces name] merge ns-info)
(merge {:op :ns
:env env
:form form
:deps (into [] (distinct @deps))
:reload @reload
:reloads @reloads}
(cond-> ns-info
(@reload :use)
(update-in [:uses]
(fn [m] (with-meta m {(@reload :use) true})))
(@reload :require)
(update-in [:requires]
(fn [m] (with-meta m {(@reload :require) true})))))))))
(defn- check-duplicate-aliases
[env old new]
(let [ns-name (:name old)]
(doseq [k [:requires :require-macros]]
(let [old-aliases (get old k)
new-aliases (get new k)]
(when-some [alias (some (set (keys new-aliases))
(->> old-aliases
(remove (fn [[k v :as entry]]
(or (= k v)
(= entry (find new-aliases k)))))
keys))]
(throw (error env
(str "Alias " alias " already exists in namespace " ns-name
", aliasing " (get old-aliases alias)))))))))
(defmethod parse 'ns*
[_ env [_ quoted-specs :as form] _ opts]
(when-let [not-quoted (->> (remove keyword? quoted-specs)
(remove #(and (seq? %) (= 'quote (first %))) )
first)]
(throw (error env (str "Arguments to " (name (first quoted-specs))
" must be quoted. Offending spec: " not-quoted))))
(when-not *allow-ns*
(throw (error env (str "Calls to `" (name (first quoted-specs))
"` must appear at the top-level."))))
(let [specs (if (= :import (first quoted-specs))
(canonicalize-import-specs quoted-specs)
(canonicalize-specs quoted-specs))
name (-> env :ns :name)
args (desugar-ns-specs
#?(:clj (list (process-rewrite-form
specs))
:cljs (list specs)))
{excludes :excludes core-renames :renames} (parse-ns-excludes env args)
core-renames (reduce (fn [m [original renamed]]
(assoc m renamed (symbol "cljs.core" (str original))))
{} core-renames)
deps (atom [])
aliases (atom {:fns {} :macros {}})
spec-parsers {:require (partial parse-require-spec env false deps aliases)
:require-macros (partial parse-require-spec env true deps aliases)
:use (comp (partial parse-require-spec env false deps aliases)
(partial use->require env))
:use-macros (comp (partial parse-require-spec env true deps aliases)
(partial use->require env))
:import (partial parse-import-spec env deps)}
reload (atom {:use nil :require nil :use-macros nil :require-macros nil})
reloads (atom {})
{uses :use requires :require renames :rename
use-macros :use-macros require-macros :require-macros
rename-macros :rename-macros imports :import :as params}
(reduce
(fn [m [k & libs]]
;; check for spec type reloads
(when-not (= :import k)
(when (some? (some #{:reload} libs))
(swap! reload assoc k :reload))
(when (some? (some #{:reload-all} libs))
(swap! reload assoc k :reload-all)))
;; check for individual ns reloads from REPL interactions
(when-some [xs (seq (filter #(-> % meta :reload) libs))]
(swap! reloads assoc k
(zipmap (map first xs) (map #(-> % meta :reload) xs))))
(apply merge-with merge m
(map (spec-parsers k)
(remove #{:reload :reload-all} libs))))
{} (remove (fn [[r]] (= r :refer-clojure)) args))]
(set! *cljs-ns* name)
(let [require-info
{:name name
:excludes excludes
:use-macros use-macros
:require-macros require-macros
:rename-macros rename-macros
:uses uses
:requires requires
:renames (merge renames core-renames)
:imports imports}
ns-info
(let [ns-info' (get-in @env/*compiler* [::namespaces name])]
(if (pos? (count ns-info'))
(let [merge-keys
[:use-macros :require-macros :rename-macros
:uses :requires :renames :imports]]
#?(:clj
(when *check-alias-dupes*
(check-duplicate-aliases env ns-info' require-info)))
(merge
ns-info'
{:excludes excludes}
(merge-with merge
(select-keys ns-info' merge-keys)
(select-keys require-info merge-keys))))
require-info))]
(swap! env/*compiler* update-in [::namespaces name] merge ns-info)
(merge {:op :ns*
:env env
:form form
:deps (into [] (distinct @deps))
:reload @reload
:reloads @reloads}
(cond-> require-info
(@reload :use)
(update-in [:uses]
(fn [m] (with-meta m {(@reload :use) true})))
(@reload :require)
(update-in [:requires]
(fn [m] (with-meta m {(@reload :require) true}))))))))
(defn parse-type
[op env [_ tsym fields pmasks body :as form]]
(let [t (:name (resolve-var (dissoc env :locals) tsym))
locals (reduce (fn [m fld]
(assoc m fld
{:name fld
:line (get-line fld env)
:column (get-col fld env)
:local :field
:field true
:mutable (-> fld meta :mutable)
:unsynchronized-mutable (-> fld meta :unsynchronized-mutable)
:volatile-mutable (-> fld meta :volatile-mutable)
:tag (-> fld meta :tag)
:shadow (m fld)}))
{} (if (= :defrecord op)
(concat fields '[__meta __extmap ^:mutable __hash])
fields))
protocols (-> tsym meta :protocols)]
(swap! env/*compiler* update-in [::namespaces (-> env :ns :name) :defs tsym]
(fn [m]
(let [m (assoc (or m {})
:name t
:tag 'function
:type true
:num-fields (count fields)
:record (= :defrecord op))]
(merge m
(dissoc (meta tsym) :protocols)
{:protocols protocols}
(source-info tsym env)))))
{:op op :env env :form form :t t :fields fields :pmasks pmasks
:tag 'function
:protocols (disj protocols 'cljs.core/Object)
:children [#_:fields :body]
:body (analyze (assoc env :locals locals) body)}))
(defmethod parse 'deftype*
[_ env form _ _]
(parse-type :deftype env form))
(defmethod parse 'defrecord*
[_ env form _ _]
(parse-type :defrecord env form) )
;; dot accessor code
(def ^:private property-symbol? #(boolean (and (symbol? %) (re-matches #"^-.*" (name %)))))
(defn- classify-dot-form
[[target member args]]
[(cond (nil? target) ::error
:default ::expr)
(cond (property-symbol? member) ::property
(symbol? member) ::symbol
(seq? member) ::list
:default ::error)
(cond (nil? args) ()
:default ::expr)])
(defmulti build-dot-form #(classify-dot-form %))
;; (. o -p)
;; (. (...) -p)
(defmethod build-dot-form [::expr ::property ()]
[[target prop _]]
{:dot-action ::access :target target :field (-> prop name (.substring 1) symbol)})
;; (. o -p <args>)
(defmethod build-dot-form [::expr ::property ::list]
[[target prop args]]
#?(:clj (throw (Error. (str "Cannot provide arguments " args " on property access " prop)))
:cljs (throw (js/Error. (str "Cannot provide arguments " args " on property access " prop)))))
(defn- build-method-call
"Builds the intermediate method call map used to reason about the parsed form during
compilation."
[target meth args]
(if (symbol? meth)
{:dot-action ::call :target target :method meth :args args}
{:dot-action ::call :target target :method (first meth) :args args}))
;; (. o m 1 2)
(defmethod build-dot-form [::expr ::symbol ::expr]
[[target meth args]]
(build-method-call target meth args))
;; (. o m)
(defmethod build-dot-form [::expr ::symbol ()]
[[target meth args]]
(build-method-call target meth args))
;; (. o (m))
;; (. o (m 1 2))
(defmethod build-dot-form [::expr ::list ()]
[[target meth-expr _]]
(build-method-call target (first meth-expr) (rest meth-expr)))
(defmethod build-dot-form :default
[dot-form]
#?(:clj (throw
(Error.
(str "Unknown dot form of "
(list* '. dot-form) " with classification "
(classify-dot-form dot-form))))
:cljs (throw
(js/Error.
(str "Unknown dot form of "
(list* '. dot-form) " with classification "
(classify-dot-form dot-form))))))
(defn analyze-dot [env target field member+ form]
(let [v [target field member+]
{:keys [dot-action target method field args]} (build-dot-form v)
enve (assoc env :context :expr)
targetexpr (analyze enve target)
form-meta (meta form)
target-tag (:tag targetexpr)
prop (or field method)
tag (or (:tag form-meta)
(and (js-tag? target-tag)
(vary-meta (normalize-js-tag target-tag)
update-in [:prefix] (fnil conj '[Object]) prop))
nil)]
(when (and (not= 'constructor prop)
(not (string/starts-with? (str prop) "cljs$")))
;; Adding to Object
(when (= 'Object (first (-> tag meta :prefix)))
(warning :infer-warning env
{:warn-type :object :form form :property prop}))
(when (not= 'js target-tag)
;; Cannot determine type of the target
(when (or (nil? target-tag) ('#{any} target-tag))
(warning :infer-warning env
{:warn-type :target :form form}))
;; Unresolveable property on existing extern
(let [[pre' pre] ((juxt butlast identity) (-> tag meta :prefix))]
(when (and (has-extern? pre') (not (has-extern? pre)))
(warning :infer-warning env
{:warn-type :property :form form
:type (symbol "js"
(string/join "."
(cond-> pre' (= 'prototype (last pre')) butlast)))
:property prop})))))
(when (js-tag? tag)
(let [pre (-> tag meta :prefix)]
(when-not (has-extern? pre)
(swap! env/*compiler* update-in
(into [::namespaces (-> env :ns :name) :externs] pre) merge {}))))
(case dot-action
::access (let [children [:target]]
{:op :host-field
:env env
:form form
:target targetexpr
:field field
:children children
:tag (if (js-tag? tag)
(or (js-tag (-> tag meta :prefix) :tag) tag)
tag)})
::call (let [argexprs (mapv #(analyze enve %) args)
children [:target :args]]
{:op :host-call
:env env
:form form
:target targetexpr
:method method
:args argexprs
:children children
:tag (if (js-tag? tag)
(or (js-tag (-> tag meta :prefix) :ret-tag) 'js)
tag)}))))
(defmethod parse '.
[_ env [_ target & [field & member+] :as form] _ _]
(disallowing-recur (analyze-dot env target field member+ form)))
(defn get-js-tag [form]
(let [form-meta (meta form)]
(if-some [tag (:tag form-meta)]
tag
(when (true? (:numeric form-meta))
'number))))
(defn js-star-interp
[env ^String s]
(let [idx (.indexOf s "~{")]
(if (== -1 idx)
(list s)
(let [end (.indexOf s "}" idx)
inner (:name (resolve-existing-var env (symbol (subs s (+ 2 idx) end))))]
(lazy-seq
(cons (subs s 0 idx)
(cons inner
(js-star-interp env (subs s (inc end))))))))))
(defn js-star-seg
[^String s]
(let [idx (.indexOf s "~{")]
(if (== -1 idx)
(list s)
(let [end (.indexOf s "}" idx)]
(lazy-seq
(cons (subs s 0 idx)
(js-star-seg (subs s (inc end)))))))))
(def NUMERIC_SET '#{any number long double})
(defn numeric-type?
#?(:cljs {:tag boolean})
[t]
;; TODO: type inference is not strong enough to detect that
;; when functions like first won't return nil, so variadic
;; numeric functions like cljs.core/< would produce a spurious
;; warning without this - David
(cond
(nil? t) true
(= 'clj-nil t) true
(js-tag? t) true ;; TODO: revisit
:else
(if (and (symbol? t) (some? (get NUMERIC_SET t)))
true
(when #?(:clj (set? t)
:cljs (cljs-set? t))
(or (contains? t 'number)
(contains? t 'long)
(contains? t 'double)
(contains? t 'any)
(contains? t 'js))))))
(def array-types
'#{array objects ints longs floats doubles chars shorts bytes boolean})
(defn array-type?
#?(:cljs {:tag boolean})
[t]
;; TODO same inference caveats as the numeric-type? fn above
(cond
(nil? t) true
(= 'clj-nil t) true
(js-tag? t) true ;; TODO: revisit
(= 'any t) true
(contains? array-types t) true
:else
(boolean
(when #?(:clj (set? t)
:cljs (cljs-set? t))
(or (contains? t 'any)