-
Notifications
You must be signed in to change notification settings - Fork 6
/
helper.cljc
89 lines (77 loc) · 2.31 KB
/
helper.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
(ns robertluo.fun-map.helper
"Helpers for writing wrappers"
(:require
#?(:clj [robertluo.fun-map.util :as util])))
#?(:clj
(defn let-form
"returns a pair first to let or equivalent, and the second to transformed bindings."
[fm bindings]
#_{:clj-kondo/ignore [:unresolved-symbol]}
(util/opt-require
'[manifold.deferred]
(if (:par? fm)
[`manifold.deferred/let-flow
(->> bindings
(partition 2)
(mapcat (fn [[k v]] [k `(manifold.deferred/future ~v)]))
vec)]
[`let bindings])
[`let bindings]))
:cljs
(defn let-form
[_ bindings]
[`let bindings]))
(defn destruct-map
"destruct arg-map of fw macro into different groups"
[arg-map]
(reduce
(fn [rst [k v]]
(cond
(= k :keys)
(update rst :naming into (map (fn [s] [(-> s name symbol) (keyword s)]) v))
(symbol? k)
(update rst :naming assoc k v)
(#{:as :or} k)
(update rst :normal assoc k v)
(and (keyword? k) (= "keys" (name k)))
(let [ns (namespace k)]
(update rst :naming into (map (fn [s] [s (keyword ns (name s))]) v)))
:else
(update rst :fm assoc k v)))
{:naming {} :normal {} :fm {}}
arg-map))
(comment
(destruct-map '{:keys [a b]})
)
(defn make-binding
"prepare binding for let"
[m-sym naming {:keys [or as]}]
(cond-> (mapcat
(fn [[sym k]]
(let [g `(get ~m-sym ~k)
kf (if-let [v (get or sym)] `(or ~g ~v) g)]
[sym kf]))
naming)
as (concat [as m-sym])
true vec))
(defmulti fw-impl
"returns a form for fw macro implementation"
:impl)
(defmethod fw-impl :default
[{f :f}] f)
;; Global options
(defn make-fw-wrapper
"construct fw"
[fun-wrapper default-wrappers arg-map body]
(let [{:keys [naming normal fm]} (destruct-map arg-map)
arg-map (merge naming normal)
m-sym (gensym "fmk")
[lets binding] (let-form fm (make-binding m-sym naming normal))
f `(fn [~m-sym ~'_] (~lets ~binding ~@body))]
(reduce (fn [rst wrapper]
(fw-impl {:impl wrapper :arg-map arg-map :f rst :options fm}))
`(~fun-wrapper ~f)
(or (:wrappers fm) default-wrappers))))
(comment
(make-fw-wrapper (fn [_]) [] {:keys ['a]} '[(* 2 a)])
)