Permalink
Browse files

Make HSequential overlap case more accurate.

Handles complex cases like (overlap '[Num Int] '[Int Num]) => false
  • Loading branch information...
1 parent 68a1d21 commit 623bfe0918036ea8aa1f5496e268d8b1dfdf0db5 @frenchy64 frenchy64 committed Jun 8, 2014
View
18 src/main/clojure/clojure/core/typed/cs_gen.clj
@@ -1253,14 +1253,6 @@
(swap!' DOTTED-VAR-STORE assoc' key all))
all))))
-(defn pad-right
- "Returns a sequence of length cnt that is s padded to the right with copies
- of v."
- [^long cnt s v]
- {:pre [(integer? cnt)]}
- (concat s
- (repeat (- cnt (count s)) v)))
-
(t/ann cs-gen-Function
[NoMentions ConstrainVars ConstrainVars Function Function -> cset])
(defn cs-gen-Function
@@ -1293,11 +1285,11 @@
;both rest args are present, so make them the same length
(and (:rest S) (:rest T))
(cs-gen-list V X Y
- (cons (:rest T) (pad-right (count (:dom S)) (:dom T) (:rest T)))
- (cons (:rest S) (pad-right (count (:dom T)) (:dom S) (:rest S))))
+ (cons (:rest T) (u/pad-right (count (:dom S)) (:dom T) (:rest T)))
+ (cons (:rest S) (u/pad-right (count (:dom T)) (:dom S) (:rest S))))
;no rest arg on the right, so just pad left and forget the rest arg
(and (:rest S) (not (:rest T)))
- (let [new-S (pad-right (count (:dom T)) (:dom S) (:rest S))]
+ (let [new-S (u/pad-right (count (:dom T)) (:dom S) (:rest S))]
; (prn "infer rest arg on left")
; (prn "left dom" (map prs/unparse-type (:dom S)))
; (prn "right dom" (map prs/unparse-type (:dom T)))
@@ -1361,7 +1353,7 @@
(fail! S T))
(if (<= (count (:dom S)) (count (:dom T)))
;; the simple case
- (let [arg-mapping (cs-gen-list V X Y (:dom T) (pad-right (count (:dom T)) (:dom S) (:rest S)))
+ (let [arg-mapping (cs-gen-list V X Y (:dom T) (u/pad-right (count (:dom T)) (:dom S) (:rest S)))
darg-mapping (move-rest-to-dmap (cs-gen V (merge X {dbound (Y dbound)}) Y t-dty (:rest S)) dbound)
ret-mapping (cg (:rng S) (:rng T))]
(cset-meet* [arg-mapping darg-mapping ret-mapping]))
@@ -1394,7 +1386,7 @@
(== (count (:dom S)) (count (:dom T)))
;the simple case
- (let [arg-mapping (cs-gen-list V X Y (pad-right (count (:dom S)) (:dom T) (:rest T)) (:dom S))
+ (let [arg-mapping (cs-gen-list V X Y (u/pad-right (count (:dom S)) (:dom T) (:rest T)) (:dom S))
darg-mapping (move-rest-to-dmap (cs-gen V (merge X {dbound (Y dbound)}) Y (:rest T) s-dty) dbound :exact true)
ret-mapping (cg (:rng S) (:rng T))]
(cset-meet* [arg-mapping darg-mapping ret-mapping]))
View
49 src/main/clojure/clojure/core/typed/type_ctors.clj
@@ -1643,35 +1643,26 @@
(and (AnyHSequential? t1)
(AnyHSequential? t2))
- (if (some :drest [t1 t2])
- true ;; Conservative result - drest not supported yet
- (let [both-rest? (every? :rest [t1 t2])
- some-rest? (some :rest [t1 t2])
- no-rest? (not-any? :rest [t1 t2])
-
- fixed-types-overlap? (every? identity (map overlap (:types t1) (:types t2)))
-
- [shorter-t longer-t] (sort-by (comp count :types) [t1 t2])
- excess-fixed-types (drop (count (:types shorter-t)) (:types longer-t))
- types-overlap? (fn [t types] (every? #(overlap t %) types))]
- (cond
- no-rest?
- (and fixed-types-overlap?
- (empty? excess-fixed-types))
-
- both-rest?
- (and fixed-types-overlap?
- (types-overlap? (:rest shorter-t) excess-fixed-types)
- (overlap (:rest shorter-t) (:rest longer-t)))
-
- some-rest?
- (and fixed-types-overlap?
- (or (empty? excess-fixed-types)
- (and (:rest shorter-t)
- (types-overlap? (:rest shorter-t) excess-fixed-types))))
-
- :else ;; Conservative result
- true)))
+ (let [rest-sub? (fn [t1 t2]
+ ; punt on drest
+ (and (not-any? :drest [t1 t2])
+ (or (== (count (:types t1))
+ (count (:types t2)))
+ (and (<= (count (:types t1))
+ (count (:types t2)))
+ (:rest t1)))
+ (every? identity
+ (map subtype?
+ ; rest type is non-nil if needed.
+ (u/pad-right (count (:types t2))
+ (:types t1)
+ (:rest t1))
+ (:types t2)))
+ (if (every? :rest [t1 t2])
+ (subtype? (:rest t1) (:rest t2))
+ true)))]
+ (or (rest-sub? t1 t2)
+ (rest-sub? t2 t1)))
:else true))) ;FIXME conservative result
View
8 src/main/clojure/clojure/core/typed/utils.clj
@@ -357,4 +357,12 @@
(flush))))
+(defn pad-right
+ "Returns a sequence of length cnt that is s padded to the right with copies
+ of v."
+ [^long cnt s v]
+ {:pre [(integer? cnt)]}
+ (concat s
+ (repeat (- cnt (count s)) v)))
+
)
View
4 src/test/clojure/clojure/core/typed/test/overlap.clj
@@ -132,3 +132,7 @@
(overlap-prs
`(HVec [Num Str ~'*])
`(HVec [Str Str ~'*])))))))
+
+(deftest hvec-complex-overlap
+ (is-clj (not (overlap-prs `(HVec [Int Num])
+ `(HVec [Num Int])))))

0 comments on commit 623bfe0

Please sign in to comment.