Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 512 lines (437 sloc) 18.146 kB
4df0ab7 @frenchy64 Performance enhancements with env update/let shadowing
frenchy64 authored
1 (set! *warn-on-reflection* true)
2
78d0985 @frenchy64 More renaming
frenchy64 authored
3 (in-ns 'clojure.core.typed)
a02cfc3 @frenchy64 Split into files
frenchy64 authored
4
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Type syntax
7
8 ;(Map Symbol F)
9 (def ^:dynamic *free-scope* {})
10 (set-validator! #'*free-scope* #((hash-c? symbol? (hmap-c? :F F? :bnds Bounds?)) %))
11
12 (defn free-with-name
13 "Find the free with the actual name name, as opposed to
14 the alias used for scoping"
15 [name]
16 {:pre [(symbol? name)]
17 :post [((some-fn nil? F?) %)]}
18 (some (fn [[_ {{fname :name :as f} :F}]]
19 (when (= name fname)
20 f))
21 *free-scope*))
22
4df0ab7 @frenchy64 Performance enhancements with env update/let shadowing
frenchy64 authored
23 (defn ^Bounds
24 free-with-name-bnds
a02cfc3 @frenchy64 Split into files
frenchy64 authored
25 "Find the bounds for the free with the actual name name, as opposed to
26 the alias used for scoping"
27 [name]
28 {:pre [(symbol? name)]
29 :post [((some-fn nil? Bounds?) %)]}
30 (some (fn [[_ {{fname :name} :F :keys [bnds]}]]
31 (when (= name fname)
32 bnds))
33 *free-scope*))
34
35 (defn free-in-scope
36 "Find the free scoped as name"
37 [name]
38 {:pre [(symbol? name)]
39 :post [((some-fn nil? F?) %)]}
40 (:F (*free-scope* name)))
41
42 (defn free-in-scope-bnds
43 "Find the bounds for the free scoped as name"
4df0ab7 @frenchy64 Performance enhancements with env update/let shadowing
frenchy64 authored
44 ^Bounds
a02cfc3 @frenchy64 Split into files
frenchy64 authored
45 [name]
46 {:pre [(symbol? name)]
47 :post [((some-fn nil? Bounds?) %)]}
48 (:bnds (*free-scope* name)))
49
50 (defmacro with-free-mappings [frees-map & body]
51 `(binding [*free-scope* (merge *free-scope* ~frees-map)]
52 ~@body))
53
54 (defmacro with-bounded-frees [bfrees & body]
55 `(with-free-mappings (into {} (for [[f# bnds#] ~bfrees]
56 [(:name f#) {:F f# :bnds bnds#}]))
57 ~@body))
58
59 (defmacro with-frees [frees & body]
60 `(with-free-mappings (into {} (for [f# ~frees]
61 [(:name f#) {:F f# :bnds no-bounds}]))
62 ~@body))
63
64 (defmulti parse-type class)
65 (defmulti parse-type-list first)
66
67 ;return a vector of [name bnds]
68 (defn parse-free [f]
69 {:post [(hvector-c? symbol? Bounds?)]}
70 (if (symbol? f)
71 [f no-bounds]
72 (let [[n & opts] f
73 {upp :<
74 low :>
75 kind :kind} (apply hash-map opts)]
76 [n (->Bounds
77 (when-not kind
78 (if upp
79 (parse-type upp)
80 (->Top)) )
81 (when-not kind
82 (if low
83 (parse-type low)
84 (Bottom)))
85 (when kind
86 (parse-type kind)))])))
87
88 (defn check-forbidden-rec [rec tbody]
89 (when (or (= rec tbody)
90 (and (Intersection? tbody)
91 (contains? (set (:types tbody)) rec))
92 (and (Union? tbody)
93 (contains? (set (:types tbody)) rec)))
94 (throw (Exception. "Recursive type not allowed here"))))
95
96 (defn parse-rec-type [[rec [free-symbol :as bnder] type]]
97 (let [_ (assert (= 1 (count bnder)) "Only one variable in allowed: Rec")
98 f (make-F free-symbol)
99 body (with-frees [f]
100 (parse-type type))
101
102 _ (check-forbidden-rec f body)]
103 (Mu* (:name f) body)))
104
105 (def ^:dynamic *parse-pretype* nil)
106
107 (defmethod parse-type-list 'DottedPretype
108 [[_ psyn bsyn]]
109 (assert *parse-pretype* "DottedPretype only allowed in Project")
110 (let [df (*dotted-scope* bsyn)]
111 (assert df bsyn)
112 (->DottedPretype (with-frees [df]
113 (parse-type psyn))
114 (:name (*dotted-scope* bsyn)))))
115
116 (defmethod parse-type-list 'Project
117 [[_ fsyn ttsyn]]
118 (let [fread (read-string (str fsyn))
119 afn (eval fread)
120 ts (binding [*parse-pretype* true]
121 (mapv parse-type ttsyn))]
122 (with-meta (->Projection afn ts)
123 {:fsyn fread})))
124
125 (defmethod parse-type-list 'CountRange
126 [[_ n u]]
127 (make-CountRange n u))
128
129 (defmethod parse-type-list 'ExactCount
130 [[_ n]]
131 (make-ExactCountRange n))
132
133 (defmethod parse-type-list 'predicate
134 [[_ t-syn]]
135 (let [on-type (parse-type t-syn)]
136 (make-FnIntersection
0c83df8 @frenchy64 Move util functions, add flow types
frenchy64 authored
137 (make-Function [-any] (RClass-of 'boolean) nil nil
a02cfc3 @frenchy64 Split into files
frenchy64 authored
138 :filter (-FS (-filter on-type 0)
139 (-not-filter on-type 0))))))
140
141 (defmethod parse-type-list 'Rec
142 [syn]
143 (parse-rec-type syn))
144
145 ;dispatch on last element of syntax in binder
146 (defmulti parse-all-type (fn [bnds type] (last bnds)))
147
148 ;(All [a b ...] type)
149 (defmethod parse-all-type '...
150 [bnds type]
151 (let [frees-with-bnds (reduce (fn [fs fsyn]
152 {:pre [(vector? fs)]
153 :post [(every? (hvector-c? symbol? Bounds?) %)]}
154 (conj fs
155 (with-bounded-frees (map (fn [[n bnd]] [(make-F n) bnd]) fs)
156 (parse-free fsyn))))
157 [] (-> bnds butlast butlast))
158 dvar (parse-free (-> bnds butlast last))]
159 (->
160 (PolyDots* (map first (concat frees-with-bnds [dvar]))
161 (map second (concat frees-with-bnds [dvar]))
162 (with-bounded-frees (map (fn [[n bnd]] [(make-F n) bnd]) frees-with-bnds)
163 (with-dotted [(make-F (first dvar))]
164 (parse-type type))))
165 (with-meta {:actual-frees (concat (map first frees-with-bnds) [(first dvar)])}))))
166
167 ;(All [a b] type)
168 (defmethod parse-all-type :default
169 [bnds type]
170 (let [frees-with-bnds
171 (reduce (fn [fs fsyn]
172 {:pre [(vector? fs)]
173 :post [(every? (hvector-c? symbol? Bounds?) %)]}
174 (conj fs
175 (with-bounded-frees (map (fn [[n bnd]] [(make-F n) bnd]) fs)
176 (parse-free fsyn))))
177 [] bnds)]
178 (Poly* (map first frees-with-bnds)
179 (map second frees-with-bnds)
180 (with-bounded-frees (map (fn [[n bnd]] [(make-F n) bnd]) frees-with-bnds)
181 (parse-type type))
182 (map first frees-with-bnds))))
183
184 (defmethod parse-type-list 'All
185 [[All bnds syn & more]]
186 (assert (not more) "Bad All syntax")
187 (parse-all-type bnds syn))
188
189 (defn parse-union-type [[u & types]]
190 (apply Un (doall (map parse-type types))))
191
192 (defmethod parse-type-list 'U
193 [syn]
194 (parse-union-type syn))
195
196 (defn parse-intersection-type [[i & types]]
197 (apply In (doall (map parse-type types))))
198
199 (defmethod parse-type-list 'I
200 [syn]
201 (parse-intersection-type syn))
202
203 (defmethod parse-type-list 'Array
204 [[_ syn & none]]
205 (assert (empty? none) "Expected 1 argument to Array")
0e3f603 @frenchy64 Work on arrays, some pseudo type sigs for typed.core
frenchy64 authored
206 (let [t (parse-type syn)
207 jtype (if (RClass? t)
208 (RClass->Class t)
209 Object)]
210 (->PrimitiveArray jtype t t)))
211
212 (defmethod parse-type-list 'ReadOnlyArray
213 [[_ osyn & none]]
214 (assert (empty? none) "Expected 1 argument to ReadOnlyArray")
215 (->PrimitiveArray Object (Bottom) (parse-type osyn)))
216
217 (defmethod parse-type-list 'Array2
218 [[_ isyn osyn & none]]
219 (assert (empty? none) "Expected 2 arguments to Array2")
220 (->PrimitiveArray Object (parse-type isyn) (parse-type osyn)))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
221
222 (defmethod parse-type-list 'Array3
223 [[_ jsyn isyn osyn & none]]
224 (assert (empty? none) "Expected 3 arguments to Array3")
0e3f603 @frenchy64 Work on arrays, some pseudo type sigs for typed.core
frenchy64 authored
225 (let [jrclass (parse-type jsyn)
226 _ (assert (RClass? jrclass) "First argument to Array3 must be a Class")]
227 (->PrimitiveArray (RClass->Class jrclass) (parse-type isyn) (parse-type osyn))))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
228
229 (declare parse-function)
230
231 (defn parse-fn-intersection-type [[Fn & types]]
16a5f7e @frenchy64 Version 0.1.3
frenchy64 authored
232 (apply make-FnIntersection (mapv parse-function types)))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
233
234 (defmethod parse-type-list 'Fn
235 [syn]
236 (parse-fn-intersection-type syn))
237
238 (declare fv-variances)
239
240 (defn parse-type-fn
241 [[_ binder bodysyn :as tfn]]
242 (assert (= 3 (count tfn)))
243 (assert (every? vector? binder))
244 (let [free-maps (for [[nme & {:keys [variance < > kind] :as opts}] binder]
245 (do
246 (assert nme)
247 {:nme nme :variance (or variance :invariant)
248 :bound (map->Bounds
249 {:upper-bound (when-not kind
250 (if (contains? opts :<)
251 (parse-type <)
252 -any))
253 :lower-bound (when-not kind
254 (if (contains? opts :>)
255 (parse-type >)
256 -nothing))
257 :higher-kind (when kind
258 (parse-type kind))})}))
259 bodyt (with-bounded-frees (map (fn [{:keys [nme bound]}] [(make-F nme) bound])
260 free-maps)
261 (parse-type bodysyn))
262 vs (with-bounded-frees (map (fn [{:keys [nme bound]}] [(make-F nme) bound])
263 free-maps)
264 (fv-variances bodyt))
265 _ (doseq [{:keys [nme variance]} free-maps]
266 (when-let [actual-v (vs nme)]
267 (assert (= (vs nme) variance)
268 (error-msg "Type variable " nme " appears in " (name actual-v) " position "
269 "when declared " (name variance)))))]
270 (with-meta (TypeFn* (map :nme free-maps) (map :variance free-maps)
271 (map :bound free-maps) bodyt)
272 {:actual-frees (map :nme free-maps)})))
273
274 (defmethod parse-type-list 'TFn
275 [syn]
276 (parse-type-fn syn))
277
278 (defmethod parse-type-list 'Seq* [syn] (->HeterogeneousSeq (mapv parse-type (rest syn))))
279 (defmethod parse-type-list 'List* [syn] (->HeterogeneousList (mapv parse-type (rest syn))))
280 (defmethod parse-type-list 'Vector* [syn] (-hvec (mapv parse-type (rest syn))))
281
282 (defn- syn-to-hmap [mandatory optional]
283 (letfn [(mapt [m]
284 (into {} (for [[k v] m]
ece26e7 @frenchy64 Remove ann-multi. Correct type for repeatedly. Work on MM support
frenchy64 authored
285 [(-val k)
a02cfc3 @frenchy64 Split into files
frenchy64 authored
286 (parse-type v)])))]
287 (let [mandatory (mapt mandatory)
288 optional (mapt optional)]
289 (make-HMap mandatory optional))))
290
291 (defmethod parse-type-list 'quote
292 [[_ syn]]
293 (cond
294 ((some-fn number? keyword? symbol?) syn) (-val syn)
295 (vector? syn) (-hvec (mapv parse-type syn))
296 (map? syn) (syn-to-hmap syn nil)
297 :else (throw (Exception. (str "Invalid use of quote:" syn)))))
298
299 (defmethod parse-type-list 'HMap
300 [[_ mandatory & {:keys [optional]}]]
301 (syn-to-hmap mandatory optional))
302
303 (defn parse-RClass [cls-sym params-syn]
304 (let [cls (resolve cls-sym)
305 _ (assert (class? cls) (str cls-sym " cannot be resolved"))
306 tparams (doall (map parse-type params-syn))]
307 (RClass-of (Class->symbol cls) tparams)))
308
309 (defmethod parse-type-list 'Value
5c1a18f @frenchy64 Progress on MM, small fixes
frenchy64 authored
310 [[_Value_ syn]]
a02cfc3 @frenchy64 Split into files
frenchy64 authored
311 (constant-type syn))
312
313 (defmethod parse-type-list 'KeywordArgs
314 [[_KeywordArgs_ & {:keys [optional mandatory]}]]
315 (assert (= #{}
316 (set/intersection (set (keys optional))
317 (set (keys mandatory)))))
318 (let [optional (into {} (for [[k v] optional]
319 (do (assert (keyword? k))
320 [(->Value k) (parse-type v)])))
321 mandatory (into {} (for [[k v] mandatory]
322 (do (assert (keyword? k))
323 [(->Value k) (parse-type v)])))]
324 (apply Un (apply concat
325 (for [opts (map #(into {} %) (comb/subsets optional))]
326 (let [m (merge mandatory opts)
327 kss (comb/permutations (keys m))]
328 (for [ks kss]
329 (->HeterogeneousSeq (mapcat #(find m %) ks)))))))))
330
331 (defmethod parse-type-list :default
332 [[n & args :as syn]]
333 (let [res (resolve n)
334 rsym (cond
335 (class? res) (Class->symbol res)
336 (var? res) (var->symbol res))]
337 (if (free-in-scope n)
4df0ab7 @frenchy64 Performance enhancements with env update/let shadowing
frenchy64 authored
338 (let [^TypeFn k (.higher-kind (free-in-scope-bnds n))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
339 _ (assert (TypeFn? k) (error-msg "Cannot invoke type variable " n))
340 _ (assert (= (.nbound k) (count args)) (error-msg "Wrong number of arguments (" (count args)
341 ") to type function " (unparse-type k)))]
342 (->TApp (free-in-scope n) (mapv parse-type args)))
343 (if-let [t ((some-fn @DATATYPE-ENV @PROTOCOL-ENV @TYPE-NAME-ENV) rsym)]
344 ;don't resolve if operator is declared
345 (if (keyword? t)
346 (cond
347 ; declared names can be TFns
348 (isa? t declared-name-type) (->TApp (->Name rsym) (mapv parse-type args))
349 ; for now use Apps for declared Classes and protocols
350 :else (->App (->Name rsym) (mapv parse-type args)))
351 (->TApp (->Name rsym) (mapv parse-type args)))
352 (cond
353 ;a Class that's not a DataType
354 (class? res) (RClass-of (Class->symbol res) (mapv parse-type args))
355 :else
356 ;unqualified declared protocols and datatypes
357 (if-let [s (let [svar (symbol (name (ns-name *ns*)) (name n))
358 scls (symbol (munge (str (ns-name *ns*) \. (name n))))]
359 (some #(and (@TYPE-NAME-ENV %)
360 %)
361 [svar scls]))]
362 (->App (->Name s) (mapv parse-type args))
363 (throw (Exception. (error-msg "Cannot parse list: " syn)))))))))
364
365 (defmethod parse-type Cons [l] (parse-type-list l))
366 (defmethod parse-type IPersistentList [l] (parse-type-list l))
367
368 (defmulti parse-type-symbol identity)
369 (defmethod parse-type-symbol 'Any [_] (->Top))
370 (defmethod parse-type-symbol 'Nothing [_] (Bottom))
371
372 ;Symbol -> Class
373 (def primitives
374 {'byte (RClass-of 'byte)
375 'short (RClass-of 'short)
376 'int (RClass-of 'int)
377 'long (RClass-of 'long)
378 'float (RClass-of 'float)
379 'double (RClass-of 'double)
380 'boolean (RClass-of 'boolean)
381 'char (RClass-of 'char)
382 'void -nil})
383
384 (defmethod parse-type-symbol :default
385 [sym]
386 (if-let [f (free-in-scope sym)]
387 f
388 (let [qsym (if (namespace sym)
389 sym
390 (symbol (-> *ns* ns-name name) (name sym)))
391 clssym (if (some #(= \. %) (str sym))
392 sym
393 (symbol (str (munge (-> *ns* ns-name name)) \. (name sym))))]
394 (cond
395 (primitives sym) (primitives sym)
396 (@TYPE-NAME-ENV qsym) (->Name qsym)
397 (@TYPE-NAME-ENV clssym) (->Name clssym)
398 ;Datatypes that are annotated in this namespace, but not yet defined
399 (@DATATYPE-ENV clssym) (@DATATYPE-ENV clssym)
400 (@PROTOCOL-ENV qsym) (resolve-protocol qsym)
401 :else (let [res (resolve sym)]
402 ;(prn *ns* "res" sym "->" res)
403 (cond
404 (class? res) (or (@DATATYPE-ENV (symbol (.getName ^Class res)))
13d9252 @frenchy64 Work with Array types and primitive types
frenchy64 authored
405 (RClass-of res))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
406 :else (if-let [t (and (var? res)
407 (@TYPE-NAME-ENV (var->symbol res)))]
408 t
409 (throw (Exception. (error-msg "Cannot resolve type: " sym))))))))))
410
411 (defmethod parse-type Symbol [l] (parse-type-symbol l))
412 (defmethod parse-type Boolean [v] (if v -true -false))
413 (defmethod parse-type nil [_] -nil)
414
8d810f4 @frenchy64 Start on multimethods, other small fixes
frenchy64 authored
415 (declare parse-path-elem parse-filter)
a02cfc3 @frenchy64 Split into files
frenchy64 authored
416
417 (defn parse-object [{:keys [id path]}]
418 (->Path (when path (mapv parse-path-elem path)) id))
419
420 (defn parse-filter-set [{:keys [then else] :as fsyn}]
421 (-FS (if then
422 (parse-filter then)
423 -top)
424 (if else
425 (parse-filter else)
426 -top)))
427
428 (defmulti parse-filter first)
429
430 (defmethod parse-filter 'is
8d810f4 @frenchy64 Start on multimethods, other small fixes
frenchy64 authored
431 [[_ & [tsyn nme psyns :as all]]]
432 (assert (#{2 3} (count all)))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
433 (let [t (parse-type tsyn)
434 p (when (= 3 (count all))
8d810f4 @frenchy64 Start on multimethods, other small fixes
frenchy64 authored
435 (mapv parse-path-elem psyns))]
a02cfc3 @frenchy64 Split into files
frenchy64 authored
436 (-filter t nme p)))
437
438 (defmethod parse-filter '!
8d810f4 @frenchy64 Start on multimethods, other small fixes
frenchy64 authored
439 [[_ & [tsyn nme psyns :as all]]]
440 (assert (#{2 3} (count all)))
a02cfc3 @frenchy64 Split into files
frenchy64 authored
441 (let [t (parse-type tsyn)
442 p (when (= 3 (count all))
8d810f4 @frenchy64 Start on multimethods, other small fixes
frenchy64 authored
443 (mapv parse-path-elem psyns))]
a02cfc3 @frenchy64 Split into files
frenchy64 authored
444 (-not-filter t nme p)))
445
446 (defmethod parse-filter '|
447 [[_ & fsyns]]
448 (apply -or (mapv parse-filter fsyns)))
449
450 (defmethod parse-filter '&
451 [[_ & fsyns]]
452 (apply -and (mapv parse-filter fsyns)))
453
454 (defmulti parse-path-elem #(cond
455 (symbol? %) %
456 :else (first %)))
457
458 (defmethod parse-path-elem 'Class [_] (->ClassPE))
459
460 (defmethod parse-path-elem 'Key
461 [[_ & [ksyn :as all]]]
462 (assert (= 1 (count all)))
463 (->KeyPE ksyn))
464
465 (defn parse-function [f]
466 (let [all-dom (take-while #(not= '-> %) f)
467 [_ rng & opts-flat :as chk] (drop-while #(not= '-> %) f) ;opts aren't used yet
468 _ (assert (<= 2 (count chk)) (str "Missing range in " f))
469
470 opts (apply hash-map opts-flat)
471
472 {ellipsis-pos '...
473 asterix-pos '*}
474 (into {} (map vector all-dom (range)))
475
476 _ (assert (not (and asterix-pos ellipsis-pos))
477 "Cannot provide both rest type and dotted rest type")
478
13d9252 @frenchy64 Work with Array types and primitive types
frenchy64 authored
479 _ (when-let [ks (seq (filter (complement #{:filters :object}) (keys opts)))]
a02cfc3 @frenchy64 Split into files
frenchy64 authored
480 (throw (Exception. (str "Invalid option/s: " ks))))
481
482 filters (when-let [[_ fsyn] (find opts :filters)]
483 (parse-filter-set fsyn))
484
485 object (when-let [[_ obj] (find opts :object)]
486 (parse-object obj))
487
488 fixed-dom (cond
489 asterix-pos (take (dec asterix-pos) all-dom)
490 ellipsis-pos (take (dec ellipsis-pos) all-dom)
491 :else all-dom)
492
493 rest-type (when asterix-pos
494 (nth all-dom (dec asterix-pos)))
495 [drest-type _ drest-bnd] (when ellipsis-pos
496 (drop (dec ellipsis-pos) all-dom))]
497 (make-Function (doall (mapv parse-type fixed-dom))
498 (parse-type rng)
499 (when asterix-pos
500 (parse-type rest-type))
501 (when ellipsis-pos
502 (->DottedPretype
503 (with-frees [(*dotted-scope* drest-bnd)] ;with dotted bound in scope as free
504 (parse-type drest-type))
505 (:name (*dotted-scope* drest-bnd))))
506 :filter filters
507 :object object)))
508
509 (defmethod parse-type IPersistentVector
510 [f]
511 (apply make-FnIntersection [(parse-function f)]))
Something went wrong with that request. Please try again.