|
| 1 | +(ns klipse.lang.clojure.env |
| 2 | + (:require-macros |
| 3 | + [cljs.env.macros :as env]) |
| 4 | + (:require [cljs.analyzer :as ana] |
| 5 | + [cljs.repl :refer [print-doc]] |
| 6 | + [clojure.string :as string] |
| 7 | + [cljs.js :as cljs])) |
| 8 | + |
| 9 | +(def st (memoize cljs/empty-state)) |
| 10 | +(defonce ^:private current-ns (atom 'cljs.user)) |
| 11 | + |
| 12 | +(defn- drop-macros-suffix |
| 13 | + [ns-name] |
| 14 | + (if (string/ends-with? ns-name "$macros") |
| 15 | + (apply str (drop-last 7 ns-name)) |
| 16 | + ns-name)) |
| 17 | + |
| 18 | +(defn- add-macros-suffix |
| 19 | + [sym] |
| 20 | + (symbol (str (name sym) "$macros"))) |
| 21 | + |
| 22 | +(defn- all-ns |
| 23 | + "Returns a sequence of all namespaces." |
| 24 | + [] |
| 25 | + (keys (::ana/namespaces @(st)))) |
| 26 | + |
| 27 | +(defn- all-macros-ns [] |
| 28 | + (->> (all-ns) |
| 29 | + (filter #(string/ends-with? (str %) "$macros")))) |
| 30 | + |
| 31 | +(defn- get-namespace |
| 32 | + "Gets the AST for a given namespace." |
| 33 | + [ns] |
| 34 | + {:pre [(symbol? ns)]} |
| 35 | + (get-in @(st) [::ana/namespaces ns])) |
| 36 | + |
| 37 | +(defn- resolve-var |
| 38 | + "Given an analysis environment resolve a var. Analogous to |
| 39 | + clojure.core/resolve" |
| 40 | + [env sym] |
| 41 | + {:pre [(map? env) (symbol? sym)]} |
| 42 | + (try |
| 43 | + (ana/resolve-var env sym |
| 44 | + (ana/confirm-var-exists-throw)) |
| 45 | + (catch :default _ |
| 46 | + (ana/resolve-macro-var env sym)))) |
| 47 | + |
| 48 | +(defn- get-macro-var |
| 49 | + [env sym macros-ns] |
| 50 | + {:pre [(symbol? macros-ns)]} |
| 51 | + (when-let [macro-var (env/with-compiler-env (st) |
| 52 | + (resolve-var env (symbol macros-ns (name sym))))] |
| 53 | + (assoc macro-var :ns macros-ns))) |
| 54 | + |
| 55 | +(defn- get-var |
| 56 | + [env sym] |
| 57 | + (binding [ana/*cljs-warning-handlers* nil] |
| 58 | + (let [var (or (env/with-compiler-env (st) (resolve-var env sym)) |
| 59 | + (some #(get-macro-var env sym %) (all-macros-ns)))] |
| 60 | + (when var |
| 61 | + (-> (cond-> var |
| 62 | + (not (:ns var)) |
| 63 | + (assoc :ns (symbol (namespace (:name var)))) |
| 64 | + (= (namespace (:name var)) (str (:ns var))) |
| 65 | + (update :name #(symbol (name %)))) |
| 66 | + (update :ns (comp symbol drop-macros-suffix str))))))) |
| 67 | + |
| 68 | +(defn- get-aenv [] |
| 69 | + (assoc (ana/empty-env) |
| 70 | + :ns (get-namespace @current-ns) |
| 71 | + :context :expr)) |
| 72 | + |
| 73 | +(defn- undo-reader-conditional-spacing |
| 74 | + "Undoes the effect that wrapping a reader conditional around |
| 75 | + a defn has on a docstring." |
| 76 | + [s] |
| 77 | + ;; We look for five spaces (or six, in case that the docstring |
| 78 | + ;; is not aligned under the first quote) after the first newline |
| 79 | + ;; (or two, in case the doctring has an unpadded blank line |
| 80 | + ;; after the first), and then replace all five (or six) spaces |
| 81 | + ;; after newlines with two. |
| 82 | + (when-not (nil? s) |
| 83 | + (if (re-find #"[^\n]*\n\n?\s{5,6}\S.*" s) |
| 84 | + (string/replace-all s #"\n ?" "\n ") |
| 85 | + s))) |
| 86 | + |
| 87 | +(defn- doc* [name] |
| 88 | + (if-let [special-name ('{& fn catch try finally try} name)] |
| 89 | + (doc* special-name) |
| 90 | + (cond |
| 91 | + ;(special-doc-map name) |
| 92 | + ;(cljs.repl/print-doc (special-doc-map name)) |
| 93 | + |
| 94 | + ;(repl-special-doc-map name) |
| 95 | + ;(cljs.repl/print-doc (repl-special-doc name)) |
| 96 | + |
| 97 | + ;(get-namespace name) |
| 98 | + ;(cljs.repl/print-doc (select-keys (get-namespace name) [:name :doc])) |
| 99 | + |
| 100 | + (get-var (get-aenv) name) |
| 101 | + (symbol (with-out-str (print-doc (let [aenv (get-aenv) |
| 102 | + var (get-var aenv name) |
| 103 | + m (-> (select-keys var |
| 104 | + [:ns :name :doc :forms :arglists :macro :url]) |
| 105 | + (update-in [:doc] undo-reader-conditional-spacing) |
| 106 | + (merge |
| 107 | + {:forms (-> var :meta :forms second) |
| 108 | + :arglists (-> var :meta :arglists second)}))] |
| 109 | + (cond-> (update-in m [:name] clojure.core/name) |
| 110 | + (:protocol-symbol var) |
| 111 | + (assoc :protocol true |
| 112 | + :methods |
| 113 | + (->> (get-in var [:protocol-info :methods]) |
| 114 | + (map (fn [[fname sigs]] |
| 115 | + [fname {:doc (:doc |
| 116 | + (get-var aenv |
| 117 | + (symbol (str (:ns var)) (str fname)))) |
| 118 | + :arglists (seq sigs)}])) |
| 119 | + (into {}))))))))))) |
| 120 | + |
0 commit comments