-
Notifications
You must be signed in to change notification settings - Fork 2
/
defn.cljc
254 lines (238 loc) · 10.2 KB
/
defn.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
;; Copyright (c) Rich Hickey
;; Copyright 2016-2019 Timothy Dean
;; Copyright 2017-2018 Workiva Inc.
;; 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 morphe.impl.defn
#?(:clj (:require [clojure.tools.macro :refer [symbol-macrolet]])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFN PARSER & COMPILER ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defrecord ParsedFnDef [env wrapper namespace metadata fn-name arglists bodies aspects hofs])
(def fn-def->aspects :aspects)
;; The following was ripped out of clojure.core. It was a private fn,
;; and I needed it.
#?(:clj
(defn- ^{:dynamic true} assert-valid-fdecl
"A good fdecl looks like (([a] ...) ([a b] ...)) near the end of defn."
[fdecl]
(when (empty? fdecl) (throw (IllegalArgumentException.
"Parameter declaration missing")))
(let [argdecls (map
#(if (seq? %)
(first %)
(throw (IllegalArgumentException.
(if (seq? (first fdecl))
(format "Invalid signature \"%s\" should be a list" %)
(format "Parameter declartion \"%s\" should be a vector" %)))))
fdecl)
bad-args (seq (remove #(vector? %) argdecls))]
(when bad-args
(throw (IllegalArgumentException. (str "Parameter declaration \"" (first bad-args)
"\" should be a vector")))))))
;; The following was ripped out of clojure.core.
#?(:clj
(defn- sigs
[fdecl]
(assert-valid-fdecl fdecl)
(let [asig (fn [fdecl]
(let [arglist (first fdecl) ;;elide implicit macro args
arglist (if (clojure.lang.Util/equals '&form (first arglist))
(clojure.lang.RT/subvec arglist 2 (clojure.lang.RT/count arglist))
arglist)
body (next fdecl)]
(if-not (map? (first body))
arglist
(if-not (next body)
arglist
(with-meta arglist (conj (if (meta arglist) (meta arglist) {}) (first body)))))))
resolve-tag (fn [argvec]
(let [m (meta argvec)
^clojure.lang.Symbol tag (:tag m)]
(if-not (instance? clojure.lang.Symbol tag)
argvec
(if-not (clojure.lang.Util/equiv (.indexOf (.getName tag) ".") -1)
argvec
(if-not (clojure.lang.Util/equals nil
(clojure.lang.Compiler$HostExpr/maybeSpecialTag tag))
argvec
(let [c (clojure.lang.Compiler$HostExpr/maybeClass tag false)]
(if-not c
argvec
(with-meta argvec (assoc m :tag (clojure.lang.Symbol/intern (.getName c)))))))))))]
(if (seq? (first fdecl))
(loop [ret [] fdecls fdecl]
(if fdecls
(recur (conj ret (resolve-tag (asig (first fdecls)))) (next fdecls))
(seq ret)))
(list (resolve-tag (asig fdecl)))))))
;; The following is taken straight from clojure.core/defn (sense a
;; theme?), with modifications to output a ParsedFnDef record instead of
;; defn form.
#?(:clj
(defn parse-defn
[&form &env name & fdecl]
(when-not (symbol? name)
(throw (IllegalArgumentException. "The first argument to a def form must be a symbol.")))
(let [m (if (string? (first fdecl))
{:doc (first fdecl)}
{})
fdecl (if (string? (first fdecl))
(next fdecl)
fdecl)
m (if (map? (first fdecl))
(conj m (first fdecl))
m)
fdecl (if (map? (first fdecl))
(next fdecl)
fdecl)
fdecl (if (vector? (first fdecl))
(list fdecl)
fdecl)
m (if (map? (last fdecl))
(conj m (last fdecl))
m)
fdecl (if (map? (last fdecl))
(butlast fdecl)
fdecl)
m (conj {:arglists (list 'quote (sigs fdecl))} m)
m (let [inline (:inline m)
ifn (first inline)
iname (second inline)]
(if (and (= 'fn ifn) (not (symbol? iname)))
(->> (next inline)
(cons (clojure.lang.Symbol/intern (.concat (.getName ^clojure.lang.Symbol name) "__inliner")))
(cons ifn)
(assoc m :inline))
m))
m (conj (if (meta name) (meta name) {}) m)
params (map first fdecl)
bodies (map rest fdecl)]
(map->ParsedFnDef {:wrapper `(do ::form)
:env &env
:namespace *ns*
:metadata (dissoc m :morphe.core/aspects)
:fn-name name
:arglists params
:bodies bodies
:aspects (:morphe.core/aspects m)}))))
#?(:clj
(defn- hof-it [expr hof] `(~hof ~expr)))
#?(:clj
(defn fn-def->defn
[fn-def]
;; vvv some more bits forked out of clojure.core/defn.
(let [fn-def (cond-> fn-def
(:hofs fn-def) (assoc-in fn-def [:metadata :arglists '([& args])]))
fn-expr (with-meta (cons `fn (map cons
(:arglists fn-def)
(:bodies fn-def)))
{:rettag (:tag (:metadata fn-def))})
definiens (if-let [hofs (:hofs fn-def)]
(reduce hof-it fn-expr (reverse hofs))
fn-expr)
definition (list `def (with-meta (:fn-name fn-def) (:metadata fn-def))
definiens)]
(if (not= (:wrapper fn-def) `(do ::form))
;; vvv replaces the ::definition with the defn form, inside the wrapper form. Wrapped in do.
(clojure.walk/postwalk-replace {::form definition}
(:wrapper fn-def))
definition))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONVENIENCE UTILITIES ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
#?(:clj
(defn- ->anaphoric-binding
([fn-def anaphore]
(assert (not (or (= anaphore '&body)
(= anaphore '¶ms))))
(->anaphoric-binding fn-def nil nil anaphore))
([fn-def params anaphore]
(assert (not (= anaphore '&body)))
(->anaphoric-binding fn-def params nil anaphore))
([fn-def params body anaphore]
[anaphore
(condp = anaphore
'&body body
'¶ms params
'&ns `(:namespace ~fn-def)
'&name `(:fn-name ~fn-def)
'&meta `(:metadata ~fn-def)
'&form `(:wrapper ~fn-def)
'&env-keys `(set (keys (:env ~fn-def))))])))
#?(:clj
(defn- anaphoric-scope
([sym:fn-def anaphores expression]
`(symbol-macrolet ~(into []
(mapcat (partial ->anaphoric-binding sym:fn-def))
anaphores)
~expression))
([sym:fn-def sym:params anaphores expression]
`(symbol-macrolet ~(into []
(mapcat (partial ->anaphoric-binding sym:fn-def sym:params))
anaphores)
~expression))
([sym:fn-def sym:params sym:body anaphores expression]
`(symbol-macrolet ~(into []
(mapcat (partial ->anaphoric-binding sym:fn-def sym:params sym:body))
anaphores)
~expression))))
#?(:clj
(defmacro alter-form
[fn-def expression]
(let [sym:fn-def (gensym 'fn-def)
expression (->> expression
(anaphoric-scope sym:fn-def '#{&ns &name &env-keys &meta &form}))]
`(let [~sym:fn-def ~fn-def]
(assoc ~sym:fn-def :wrapper ~expression)))))
#?(:clj
(defmacro prefix-form
[fn-def expression]
(let [sym:fn-def (gensym 'fn-def)
expression (->> expression
(anaphoric-scope sym:fn-def '#{&ns &name &env-keys &meta}))]
`(let [~sym:fn-def ~fn-def]
(alter-form ~sym:fn-def
`(do ~~expression
~~'&form))))))
(defn alter-bodies*
[fn-def f]
(update fn-def
:bodies
(fn [bodies]
(map f (:arglists fn-def) bodies))))
#?(:clj
(defmacro alter-bodies
[fn-def expression]
(let [sym:params (gensym 'params)
sym:body (gensym 'body)
sym:fn-def (gensym 'fn-def)
anaphores '#{¶ms &body &ns &name &meta &env-keys}
expression-fn `(fn ~[sym:params sym:body]
(list ~(->> expression
(anaphoric-scope sym:fn-def sym:params sym:body anaphores))))]
`(let [~sym:fn-def ~fn-def]
(alter-bodies* ~sym:fn-def ~expression-fn)))))
(defn prefix-bodies*
[fn-def f]
(update fn-def
:bodies
(fn [bodies]
(map cons
(map f (:arglists fn-def))
bodies))))
#?(:clj
(defmacro prefix-bodies
[fn-def expression]
(let [sym:params (gensym 'params)
sym:fn-def (gensym 'fn-def)
anaphores '#{¶ms &ns &name &meta &env-keys}
expression-fn `(fn ~[sym:params]
~(->> expression
(anaphoric-scope sym:fn-def sym:params anaphores)))]
`(let [~sym:fn-def ~fn-def]
(prefix-bodies* ~sym:fn-def ~expression-fn)))))