/
compile.clj
148 lines (129 loc) · 3.44 KB
/
compile.clj
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
(ns contextual.impl.compile
(:require
[contextual.walk :as walk]
[contextual.impl.control :as control :refer [->if ->or ->and ->cond ->condp]]
[contextual.impl.path :as path :refer [->path ->multi-path ->pred-multi-path]]
[contextual.impl.let :as l :refer [->let]]
[contextual.impl.string :as s :refer [->str ->join]]
[contextual.impl.invoke :as i]
[contextual.impl.box :as b]
[contextual.impl.validate :as v]
[contextual.impl.collections :as c]
[contextual.impl.protocols :as p]))
(def symbols-registry
"Assembler special forms which are expanded to specially compiled classes."
(v/enrich-lookup-map
{'if #'->if
'cond #'->cond
'condp #'->condp
'or #'->or
'and #'->and
'str #'->str
'join #'->join
'path #'->path
'multi-path #'->multi-path
'pred-multi-path #'->pred-multi-path
'let #'->let
'->hashmap #'c/->map
'->vec #'c/->vector}))
(defn flatten-strings
[expr]
(walk/preserving-postwalk
(fn [expr]
(if (and (seq? expr) (s/strexpr? expr))
(s/unnest-str1* expr)
expr))
expr))
(defn maybe-resolve
[s]
(when-let [v (resolve s)]
(deref v)))
(defn expand-symbol
[registry lookup s]
(or
(and (registry s) s)
(and (l/binding-symbol? s) s)
(get lookup s (l/->lookup s))))
(defn- unvar
[v]
(if (var? v) @v v))
(defn- assembly-fn
[registry lookup]
(fn [expr]
(cond
(seq? expr)
(let [[f & args] expr]
(walk/preserving-meta
expr
(if-let [f' (unvar (registry f))]
(apply f' args)
(apply i/->fn f args))))
(symbol? expr) (walk/preserving-meta expr (unvar (expand-symbol registry lookup expr)))
(instance? clojure.lang.MapEntry expr) expr
(map? expr) ((registry '->hashmap) expr)
(vector? expr) ((registry '->vec) expr)
(or
(string? expr)
(keyword? expr)
(number? expr)
(char? expr)
(nil? expr)
) (b/->box expr)
:else expr)))
(defn assemble
"Assemble an expression `expr` with the following optional arguments:
`lookup`: A map from symbol to value. Can contain any type of value.
Usually constants, Path*s or functions.
`registry`: a symbol -> special form emitter map. See
[[symbols-registry]] as a default value."
([expr]
(assemble expr {}))
([expr lookup]
(assemble expr lookup symbols-registry))
([expr lookup registry]
(let [registry (merge symbols-registry registry)]
(walk/preserving-postwalk (assembly-fn registry lookup) expr))))
(comment
(def ctx {:x {:y false}
:a {:b 3}
:y {:z "foo"}
:u {:w "bar"}})
(def c
(assemble
'(if (path :x :y)
(+ (path :a :b) 2)
(str (path :y :z) "blah" (path :u :w)))))
(p/-invoke c ctx)
(def --p (path/->path :u :w))
(def lookup {'--p --p})
(def c (assemble
'(if (path :x :y)
(+ (path :a :b) 2)
(str (path :y :z) "blah" --p))
lookup))
(p/-invoke c ctx)
)
(defn -compile
([expr]
(-compile expr {}))
([expr lookup]
(-compile expr lookup {}))
([expr lookup registry]
(->
expr
l/ssa-bindings
flatten-strings
(assemble lookup registry))))
(comment
(def c
(-compile
'(if (path :x :y)
(let [x (path :a :b)]
(+ x 2))
(str (path :y :z) "blah" (path :u :w)))))
(def ctx {:x {:y true}
:a {:b 3}
:y {:z "foo"}
:u {:w "bar"}})
(p/-invoke c ctx)
)