Permalink
Browse files

Subtyping bugs, add more *current-expr* bindings, some anns

  • Loading branch information...
1 parent 81bf1f9 commit 62a0579550a65d9eebd2b4b825f800d533c989ae @frenchy64 committed Dec 8, 2012
Showing with 68 additions and 51 deletions.
  1. +3 −0 README.md
  2. +2 −2 project.clj
  3. +20 −8 src/typed/ann.clj
  4. +18 −9 src/typed/check.clj
  5. +16 −28 src/typed/subtype.clj
  6. +9 −4 test/typed/test/core.clj
View
3 README.md
@@ -16,6 +16,9 @@ See `LICENSE`.
# Changelog
+0.1.6-SNAPSHOT
+- Ensure `Result` is not introduced when performing type inference on drest fn apps
+
0.1.5
- Better errors for Java methods and polymorphic function applications, borrow error messages from Typed Racket
- Change `ann-datatype`, `ann-protocol`, `ann-pprotocol` syntax to be flatter
View
4 project.clj
@@ -1,6 +1,6 @@
-(defproject typed "0.1.5"
+(defproject typed "0.1.6-SNAPSHOT"
:description "Gradual typing for Clojure"
- :dependencies [[analyze "0.2.4"]
+ :dependencies [[analyze "0.2.5-SNAPSHOT"]
[net.intensivesystems/arrows "1.3.0"
:exclusions [org.clojure/clojure]] ;for testing conduit, lein test wants it here?
[trammel "0.7.0"
View
28 src/typed/ann.clj
@@ -31,6 +31,22 @@
[[x -> Any :filters {:else (is y 0)}] (Option (Seqable x)) -> (Seqable y)]))
+(ann clojure.core/take-while (All [x y]
+ [[x -> Any :filters {:then (is y 0)}] (Option (Seqable x)) -> (Seqable y)]))
+(ann clojure.core/drop-while (All [x]
+ [[x -> Any] (Option (Seqable x)) -> (Seqable x)]))
+
+(ann clojure.core/split-with
+ (All [x y z] [[x -> Any :filters {:then (is y 0), :else (is z 0)}] (tc/Option (Seqable x))
+ -> '[(Seqable y) (Seqable z)]]))
+
+
+(ann clojure.core/repeatedly
+ (All [x]
+ (Fn [[-> x] -> (LazySeq x)]
+ [[-> x] tc/AnyInteger -> (LazySeq x)])))
+
+
(ann clojure.core/some (All [x y] [[x -> y] (Option (Seqable x)) -> (Option y)]))
(ann clojure.core/concat (All [x] [(Option (Seqable x)) * -> (Seqable x)]))
@@ -42,14 +58,6 @@
(ann clojure.core/not [Any -> boolean])
(ann clojure.core/constantly (All [x y] [x -> [y * -> x]]))
-(ann clojure.core/take-while
- (All [x]
- [[x -> Any] (Option (Seqable x)) -> (Seqable x)]))
-
-(ann clojure.core/drop-while
- (All [x]
- [[x -> Any] (Option (Seqable x)) -> (Seqable x)]))
-
(ann clojure.core/disj
(All [x]
(Fn [(I (APersistentSet x) Sorted) Any Any * -> (I (APersistentSet x) Sorted)]
@@ -62,6 +70,10 @@
(Fn [(IPersistentMap b c) b c -> (IPersistentMap b c)]
[(IPersistentVector d) AnyInteger d -> (IPersistentVector d)])))
+(ann clojure.core/zipmap
+ (All [k v]
+ [(U nil (Seqable k)) (U nil (Seqable v)) -> (APersistentMap k v)]))
+
(comment
(aget my-array 0 1 2)
(aget (aget my-array 0) 1 2)
View
27 src/typed/check.clj
@@ -733,7 +733,7 @@
;; in filters/objects).
(let [substitution (cond
drest (infer-dots (zipmap fixed-vars fixed-bnds) dotted-var dotted-bnd
- arg-types dom (:pre-type drest) rng (fv rng)
+ arg-types dom (.pre-type drest) (Result-type* rng) (fv rng)
:expected (and expected (ret-t expected)))
rest (infer-vararg (zipmap fixed-vars fixed-bnds) {dotted-var dotted-bnd}
arg-types dom rest (Result-type* rng)
@@ -1341,6 +1341,7 @@
:else ::not-special)))
;assoc
+; TODO handle unions of hmaps as the target
(defmethod invoke-special #'clojure.core/assoc
[{:keys [args] :as expr} & [expected]]
{:post [(-> % expr-type TCResult?)]}
@@ -1370,6 +1371,7 @@
ckeyvals (doall (map check keyvals))
keypair-types (partition 2 (map (comp ret-t expr-type) ckeyvals))
+ ; TODO handle unions of hmaps without promoting to IPersistentMap
new-hmaps (mapv #(reduce (fn [hmap [kt vt]]
(let [is-vec (subtype? hmap (RClass-of IPersistentVector [-any]))
is-map (subtype? hmap (RClass-of IPersistentMap [-any -any]))]
@@ -1409,7 +1411,7 @@
hmaps)]
(assoc expr
expr-type (ret (apply Un new-hmaps)
- (-FS -top -bot)
+ (-FS -top -bot) ;assoc never returns nil
-empty))))
@@ -1954,8 +1956,13 @@
(defmethod check :do
[{:keys [exprs] :as expr} & [expected]]
{:post [(TCResult? (expr-type %))]}
- (let [cexprs (concat (mapv check (butlast exprs))
- [(check (last exprs) expected)])]
+ (let [cexprs (concat (doall
+ (for [stmtexpr (butlast exprs)]
+ (binding [*current-expr* stmtexpr]
+ (check stmtexpr))))
+ (let [lexpr (last exprs)]
+ (binding [*current-expr* lexpr]
+ [(check lexpr expected)])))]
(assoc expr
:exprs cexprs
expr-type (-> cexprs last expr-type)))) ;should be a ret already
@@ -2215,9 +2222,10 @@
:post [(PropEnv? env)]}
(let [{:keys [t fl o]} (->
(expr-type
- (with-lexical-env env
- (*check-let-checkfn* init (when is-loop
- (ret expected-bnd)))))
+ (binding [*current-expr* init]
+ (with-lexical-env env
+ (*check-let-checkfn* init (when is-loop
+ (ret expected-bnd))))))
;substitute previous references to sym with an empty object,
;as old binding is shadowed
(update-in [:t] subst-type sym -empty true)
@@ -2256,7 +2264,8 @@
(if is-loop
(binding [*recur-target* (->RecurTarget expected-bnds nil nil nil)]
(*check-let-checkfn* body expected))
- (*check-let-checkfn* body expected)))
+ (binding [*current-expr* body]
+ (*check-let-checkfn* body expected))))
;now we return a result to the enclosing scope, so we
;erase references to any bindings this scope introduces
@@ -2605,7 +2614,7 @@
(defmethod check :if
[{:keys [test then else] :as expr} & [expected]]
{:post [(-> % expr-type TCResult?)]}
- (let [ctest (binding [*current-expr* expr]
+ (let [ctest (binding [*current-expr* test]
(check test))]
(assoc expr
expr-type (binding [*check-if-checkfn* check]
View
44 src/typed/subtype.clj
@@ -483,37 +483,25 @@
polyl?
polyr?))))))))
-; Class -> {:up Class :down Class}
-; up : is it safe to use this primitive type in place of up
-; down : whereever down is, we can replace it with primitive
-(def primitive-coersions
- {Byte/TYPE {:up #{Byte}
- :down #{Byte}}
- Short/TYPE {:up #{Short Integer Long Float Double}
- :down #{Short Integer Long}}
- Integer/TYPE {:up #{Short Integer Long Float Double}
- :down #{Short Integer Long}}
- Long/TYPE {:up #{Short Integer Long Float Double Double/TYPE}
- :down #{Short Integer Long}}
- Float/TYPE {:up #{Float Double}
- :down #{Float Double}}
- Double/TYPE {:up #{Float Double}
- :down #{Float Double}}
- Character/TYPE {:up #{Character}
- :down #{Character}}
- Boolean/TYPE {:up #{Boolean}
- :down #{Boolean}}})
+(def boxed-primitives
+ {Byte/TYPE Byte
+ Short/TYPE Short
+ Integer/TYPE Integer
+ Long/TYPE Long
+ Float/TYPE Float
+ Double/TYPE Double
+ Character/TYPE Character
+ Boolean/TYPE Boolean})
(defn coerse-RClass-primitive
[s t]
- (let [scls (symbol->Class (:the-class s))
- tcls (symbol->Class (:the-class t))]
- (cond
- (.isPrimitive ^Class scls)
- (-> (primitive-coersions scls) :up (get tcls))
-
- (.isPrimitive ^Class tcls)
- (-> (primitive-coersions tcls) :down (get scls)))))
+ (let [spcls (symbol->Class (:the-class s))
+ tpcls (symbol->Class (:the-class t))
+ scls (or (boxed-primitives spcls)
+ spcls)
+ tcls (or (boxed-primitives tpcls)
+ tpcls)]
+ (isa? scls tcls)))
(defmethod subtype* [RClass RClass ::clojure]
[{polyl? :poly? :as s}
View
13 test/typed/test/core.clj
@@ -240,7 +240,7 @@
(is (subtype? (ety
((typed.core/fn> [[a :- (clojure.lang.IPersistentMap Any Number)] [b :- Number]]
((typed.core/inst get Number) a b))
- {:a 1} 1))
+ (zipmap [1] [2]) 1))
(parse-type '(U nil Number)))))
(deftest get-special-test
@@ -263,8 +263,8 @@
(ret (->Value 1) (-FS -top -bot) (->EmptyObject)))))
(deftest empty-fn-test
- (is (do (prn "empty-fn-test" @typed.core/TYPED-IMPL)
- (= (tc-t (fn []))
+ (is (do (prn *ns*)
+ (= (tc-t (clojure.core/fn []))
(ret (make-FnIntersection
(->Function [] (make-Result -nil
(-FS -bot -top)
@@ -733,6 +733,7 @@
(ret (-hmap {(->Value :a) (->Value :b)})
(-FS -top -bot)
-empty)))
+ ;see `invoke-special` for assoc for TODO
(is (= (-> (tc-t (-> (fn [m]
(assoc m :c 1))
(typed.core/ann-form [typed.test.core/SomeMap -> (U '{:a ':b :c '1}
@@ -932,7 +933,7 @@
(is (= (tc-t (Exception. "a"))
(ret (RClass-of Exception)
(-FS -top -bot)
- (->NoObject)))))
+ (->EmptyObject)))))
(deftest tc-throw-test
(is (= (:t (tc-t (throw (Exception. "a"))))
@@ -1063,3 +1064,7 @@
(deftest hmap-subtype
(is (cf {} (clojure.lang.APersistentMap Any Any))))
+
+(comment
+(run-tests)
+ )

0 comments on commit 62a0579

Please sign in to comment.