Skip to content
Browse files

Support Clojure 1.4.0+, better errors (with mexpanded forms)

  • Loading branch information...
1 parent 16a5f7e commit 40d126222b4cb9b903d7b404b1f4bd8a0a8a641e @frenchy64 committed Dec 4, 2012
Showing with 114 additions and 65 deletions.
  1. +11 −6 project.clj
  2. +41 −25 src/typed/check.clj
  3. +1 −0 src/typed/core.clj
  4. +2 −3 src/typed/cs_gen.clj
  5. +48 −27 src/typed/subtype.clj
  6. +1 −1 src/typed/type_rep.clj
  7. +3 −2 test/typed/test/monads.clj
  8. +7 −1 test/typed/test/person.clj
View
17 project.clj
@@ -1,11 +1,16 @@
-(defproject typed "0.1.3"
+(defproject typed "0.1.4-SNAPSHOT"
:description "Gradual typing for Clojure"
- :dependencies [[analyze "0.2.1"]
- [net.intensivesystems/arrows "1.3.0"] ;for testing conduit, lein test wants it here?
- [trammel "0.7.0"]
- [org.clojure/math.combinatorics "0.0.2"]
+ :dependencies [[analyze "0.2.4-SNAPSHOT"]
+ [net.intensivesystems/arrows "1.3.0"
+ :exclusions [org.clojure/clojure]] ;for testing conduit, lein test wants it here?
+ [trammel "0.7.0"
+ :exclusions [org.clojure/clojure]]
+ [org.clojure/math.combinatorics "0.0.2"
+ :exclusions [org.clojure/clojure]]
[org.clojure/clojurescript "0.0-1450"]
- [org.clojure/tools.trace "0.7.3"]
+ [org.clojure/tools.trace "0.7.3"
+ :exclusions [org.clojure/clojure]]
+ [org.clojure/clojure "1.4.0"]
]
:dev-dependencies [[org.clojure/tools.macro "0.1.0"] ;for algo.monads
])
View
66 src/typed/check.clj
@@ -103,7 +103,8 @@
[{:keys [val] :as expr} & [expected]]
(let [actual-type (constant-type val)
_ (when expected
- (subtype actual-type (ret-t expected)))]
+ (binding [*current-expr* expr]
+ (subtype actual-type (ret-t expected))))]
(assoc expr
expr-type (if val
(ret actual-type
@@ -556,7 +557,7 @@
;Function TCResult^n (or nil TCResult) -> TCResult
-(defn check-funapp1 [{:keys [dom rng rest drest kws] :as ftype0} argtys expected & {:keys [check?] :or {check? true}}]
+(defn check-funapp1 [fexpr arg-exprs {:keys [dom rng rest drest kws] :as ftype0} argtys expected & {:keys [check?] :or {check? true}}]
{:pre [(Function? ftype0)
(every? TCResult? argtys)
((some-fn nil? TCResult?) expected)
@@ -603,7 +604,7 @@
:else etype)))))
; TCResult TCResult^n (U nil TCResult) -> TCResult
-(defn check-funapp [fexpr-ret-type arg-ret-types expected]
+(defn check-funapp [fexpr args fexpr-ret-type arg-ret-types expected]
{:pre [(TCResult? fexpr-ret-type)
(every? TCResult? arg-ret-types)
((some-fn nil? TCResult?) expected)]
@@ -617,12 +618,12 @@
(= 1 (count (:types fexpr-type))))
(let [argtys arg-ret-types
{[t] :types} fexpr-type]
- (check-funapp1 t argtys expected))
+ (check-funapp1 fexpr args t argtys expected))
;ordinary Function, multiple cases
(FnIntersection? fexpr-type)
(let [ftypes (:types fexpr-type)
- success-ret-type (some #(check-funapp1 % arg-ret-types expected :check? false)
+ success-ret-type (some #(check-funapp1 fexpr args % arg-ret-types expected :check? false)
(filter (fn [{:keys [dom rest] :as f}]
{:pre [(Function? f)]}
(subtypes-varargs? arg-types dom rest))
@@ -659,7 +660,7 @@
(catch Exception e
#_(prn e)))]
(do #_(prn "subst:" substitution)
- (check-funapp1 (subst-all substitution ftype)
+ (check-funapp1 fexpr args (subst-all substitution ftype)
arg-ret-types expected :check? false))
(if (or drest kws)
(throw (Exception. "Cannot infer arguments to polymorphic functions with dotted rest or kw types"))
@@ -713,7 +714,8 @@
;_ (prn "args" (map unparse-type arg-types))
]
(or (and substitution
- (check-funapp1 substituted-type arg-ret-types expected :check? false))
+ (check-funapp1 fexpr args
+ substituted-type arg-ret-types expected :check? false))
(throw (Exception. "Error applying dotted type")))))))]
;(prn "inferred-rng"inferred-rng)
(if inferred-rng
@@ -1078,9 +1080,11 @@
(let [parsed-ty (parse-type tsyn)
cty (check frm (ret parsed-ty))
checked-type (ret-t (expr-type cty))
- _ (subtype checked-type parsed-ty)
+ _ (binding [*current-expr* frm]
+ (subtype checked-type parsed-ty))
_ (when expected
- (subtype checked-type (ret-t expected)))]
+ (binding [*current-expr* frm]
+ (subtype checked-type (ret-t expected))))]
(assoc expr
expr-type (ret parsed-ty))))
@@ -1355,13 +1359,15 @@
;otherwise just make normal map if already a map, or normal vec if already a vec
is-map (ret-t
- (check-funapp (ret
+ (check-funapp target keyvals
+ (ret
(parse-type '(All [b c]
[(IPersistentMap b c) b c -> (IPersistentMap b c)])))
(mapv ret [hmap kt vt])
nil))
:else (ret-t
- (check-funapp (ret
+ (check-funapp target keyvals
+ (ret
(parse-type '(All [c]
[(IPersistentVector c) c -> (IPersistentVector c)])))
(mapv ret [hmap vt])
@@ -1417,7 +1423,7 @@
(defn check-apply
[{[fexpr & args] :args :as expr} expected]
- {:post [(TCResult? %)]}
+ {:post [((some-fn TCResult? #(= ::not-special %)) %)]}
(let [ftype (ret-t (expr-type (check fexpr)))
[fixed-args tail] [(butlast args) (last args)]]
(cond
@@ -1476,17 +1482,15 @@
(count arg-tys))
(infer-vararg (zipmap vars bbnds) {}
(cons tail-ty arg-tys)
- (cons (Un -nil (RClass-of (Class->symbol Seqable) [rest]))
- dom)
+ (cons (Un -nil (RClass-of Seqable [rest])) dom)
rest
(Result-type* rng)))
(catch IllegalArgumentException e
(throw e))
(catch Exception e
;(prn "caught failed polymorphic case")
))]
- (check-funapp1 (subst-all substitution ftype0)
- (map ret arg-tys) expected :check? false)
+ (ret (subst-all substitution (Result-type* rng)))
(recur (next fs))))))
:else ::not-special)))
@@ -1526,7 +1530,7 @@
cargs (doall (map check args))
ftype (expr-type cfexpr)
argtys (map expr-type cargs)
- actual (check-funapp ftype argtys expected)]
+ actual (check-funapp fexpr args ftype argtys expected)]
(assoc expr
:fexpr cfexpr
:args cargs
@@ -1572,6 +1576,7 @@
{:post [(-> % expr-type TCResult?)]}
(assert (:line env))
(binding [*current-env* env
+ *current-expr* expr
*check-fn-method1-checkfn* check
*check-fn-method1-rest-type* (fn [rest drest]
{:pre [(or (Type? rest)
@@ -1788,6 +1793,8 @@
exp (resolve-to-ftype (ret-t expected))
; unwrap polymorphic expected types
[fin orig-names inst-frees bnds poly?] (unwrap-poly exp)
+ ; once more to make sure
+ fin (resolve-to-ftype fin)
;ensure a function type
_ (assert (FnIntersection? fin)
(str (when *current-env*
@@ -2025,7 +2032,7 @@
(throw (Exception. (error-msg "Cannot call instance method " (Method->symbol method)
" on type " (unparse-type (ret-t (expr-type ctarget)))))))))
cargs (doall (map check args))
- result-type (check-funapp rfin-type (map expr-type cargs) expected)]
+ result-type (check-funapp expr args rfin-type (map expr-type cargs) expected)]
(assoc expr
expr-type result-type))))
@@ -2121,7 +2128,7 @@
(ret ctor-fn))
;_ (prn "Expected constructor" (unparse-type (ret-t ifn)))
cargs (mapv check args)
- res-type (check-funapp ifn (map expr-type cargs) nil)]
+ res-type (check-funapp expr args ifn (map expr-type cargs) nil)]
(assoc expr
expr-type res-type))))
@@ -2512,10 +2519,12 @@
; (set (:props *lexical-env*))
; (set (:props env-els)))))
;_ (prn idsym"env+: new-els-props" (map unparse-filter new-els-props))
- {ts :t fs2 :fl os2 :o :as then-ret} (with-lexical-env env-thn
- (tc thn @flag+))
- {us :t fs3 :fl os3 :o :as else-ret} (with-lexical-env env-els
- (tc els @flag-))]
+ {ts :t fs2 :fl os2 :o :as then-ret} (binding [*current-expr* thn]
+ (with-lexical-env env-thn
+ (tc thn @flag+)))
+ {us :t fs3 :fl os3 :o :as else-ret} (binding [*current-expr* els]
+ (with-lexical-env env-els
+ (tc els @flag-)))]
;some optimization code here, contraditions etc? omitted
@@ -2563,7 +2572,8 @@
(defmethod check :if
[{:keys [test then else] :as expr} & [expected]]
{:post [(-> % expr-type TCResult?)]}
- (let [ctest (check test)]
+ (let [ctest (binding [*current-expr* expr]
+ (check test))]
(assoc expr
expr-type (binding [*check-if-checkfn* check]
(check-if (expr-type ctest) then else)))))
@@ -2573,7 +2583,8 @@
(assert (not expected) expected)
(assert (:line env))
#_(prn "Checking" var)
- (binding [*current-env* env]
+ (binding [*current-env* env
+ *current-expr* expr]
(cond
;ignore macro definitions
(not (.isMacro ^Var var))
@@ -2724,3 +2735,8 @@
(ret type filter object))]
(assoc expr
expr-type case-result)))
+
+(comment
+ ;; error checking
+ (cf (if 1 'a 'b) Number)
+ )
View
1 src/typed/core.clj
@@ -7,6 +7,7 @@
IRef AReference ARef IDeref IReference APersistentSet PersistentHashSet Sorted
LazySeq APersistentMap))
(:require [analyze.core :refer [ast] :as analyze]
+ [analyze.emit-form :as ana-frm]
[clojure.set :as set]
[clojure.reflect :as reflect]
[clojure.string :as str]
View
5 src/typed/cs_gen.clj
@@ -550,9 +550,8 @@
(defmethod cs-gen* [HeterogeneousMap RClass ::clojure]
[V X Y S T]
- (let [[ks vs] [(apply Un (keys (:types S)))
- (apply Un (vals (:types S)))]]
- (cs-gen V X Y (RClass-of (Class->symbol APersistentMap) [ks vs]) T)))
+ ; HMaps do not record absence of fields, only subtype to (APersistentMap Any Any)
+ (cs-gen V X Y (RClass-of APersistentMap [-any -any]) T))
(defmethod cs-gen* [RClass RClass ::clojure]
[V X Y S T]
View
75 src/typed/subtype.clj
@@ -4,22 +4,25 @@
;; Subtype
(def ^:dynamic *current-env* nil)
+(def ^:dynamic *current-expr* nil)
(defn error-msg [& msg]
(apply str (when *current-env*
(str (:line *current-env*) ": "))
- msg))
+ (concat msg)))
(defn type-error [s t]
(throw (Exception. (str "Type Error"
(when *current-env*
(str ", " (:source *current-env*) ":" (:line *current-env*)))
- " - "
+ "\n\nActual type\n\t"
(or (-> s meta :source-Name)
(with-out-str (pr (unparse-type s))))
- " is not a subtype of: "
+ "\nis not a subtype of Expected type\n\t"
(or (-> t meta :source-Name)
- (with-out-str (pr (unparse-type t))))))))
+ (with-out-str (pr (unparse-type t))))
+ (when *current-expr*
+ (str "\n\nForm: " (ana-frm/map->form *current-expr*)))))))
;keeps track of currently seen subtype relations for recursive types.
;(Set [Type Type])
@@ -85,24 +88,33 @@
(subtypeA* *sub-current-seen* s (resolve-Name t))
(and (Poly? s)
- (Poly? t))
- (do
- (when-not (= (.nbound s) (.nbound t))
- (type-error s t))
- (let [names (repeatedly (.nbound s) gensym)
- b1 (Poly-body* names s)
- b2 (Poly-body* names t)]
- (subtype b1 b2)))
-
- (Poly? s)
+ (Poly? t)
+ (= (.nbound s) (.nbound t)))
+ (let [names (repeatedly (.nbound s) gensym)
+ b1 (Poly-body* names s)
+ b2 (Poly-body* names t)]
+ (subtype b1 b2))
+
+ ;use unification to see if we can use the Poly type here
+ (and (Poly? s)
+ (let [names (repeatedly (.nbound s) gensym)
+ bnds (Poly-bbnds* names s)
+ b1 (Poly-body* names s)]
+ (unify (zipmap names bnds) [b1] [t])))
(let [names (repeatedly (.nbound s) gensym)
bnds (Poly-bbnds* names s)
b1 (Poly-body* names s)]
(if (unify (zipmap names bnds) [b1] [t])
*sub-current-seen*
(type-error s t)))
- ;TODO Poly? t
+ (and (Poly? t)
+ (let [names (repeatedly (.nbound t) gensym)
+ b (Poly-body* names t)]
+ (empty? (fv t))))
+ (let [names (repeatedly (.nbound t) gensym)
+ b (Poly-body* names t)]
+ (subtype s b))
(and (TApp? s)
(not (F? (.rator s)))
@@ -542,26 +554,33 @@
(defmethod subtype* [HeterogeneousMap Type ::clojure]
[s t]
- (let [sk (apply Un (map first (:types s)))
- sv (apply Un (map second (:types s)))]
- (subtype (RClass-of (Class->symbol APersistentMap) [sk sv])
- t)))
+ ; HMaps do not record absence of fields, only subtype to (APersistentMap Any Any)
+ (subtype (RClass-of APersistentMap [-any -any]) t))
;every rtype entry must be in ltypes
;eg. {:a 1, :b 2, :c 3} <: {:a 1, :b 2}
(defmethod subtype* [HeterogeneousMap HeterogeneousMap ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
- (last (doall (map (fn [[k v]]
- (if-let [t (ltypes k)]
- (subtype t v)
- (type-error s t)))
- rtypes))))
+ (or (last (doall (map (fn [[k v]]
+ (if-let [t (ltypes k)]
+ (subtype t v)
+ (type-error s t)))
+ rtypes)))
+ #{}))
+
+(prefer-method subtype*
+ [HeterogeneousVector HeterogeneousVector ::default]
+ [HeterogeneousVector Type ::clojure])
+(prefer-method subtype*
+ [HeterogeneousMap HeterogeneousMap ::default],
+ [HeterogeneousMap Type ::clojure] )
(defmethod subtype* [HeterogeneousVector HeterogeneousVector ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
- (last (doall (map #(subtype %1 %2) ltypes rtypes))))
+ (or (last (doall (map #(subtype %1 %2) ltypes rtypes)))
+ #{}))
(defmethod subtype* [HeterogeneousVector Type ::clojure]
[s t]
@@ -573,7 +592,8 @@
(defmethod subtype* [HeterogeneousList HeterogeneousList ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
- (last (doall (map #(subtype %1 %2) ltypes rtypes))))
+ (or (last (doall (map #(subtype %1 %2) ltypes rtypes)))
+ #{}))
(defmethod subtype* [HeterogeneousList Type ::clojure]
[s t]
@@ -584,7 +604,8 @@
(defmethod subtype* [HeterogeneousSeq HeterogeneousSeq ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
- (last (doall (map #(subtype %1 %2) ltypes rtypes))))
+ (or (last (doall (map #(subtype %1 %2) ltypes rtypes)))
+ #{}))
(defmethod subtype* [HeterogeneousSeq Type ::clojure]
[s t]
View
2 src/typed/type_rep.clj
@@ -773,7 +773,7 @@
(defrecord TCResult [t fl o]
"This record represents the result of typechecking an expression"
- [(AnyType? t)
+ [(Type? t)
(FilterSet? fl)
(RObject? o)])
View
5 test/typed/test/monads.clj
@@ -567,6 +567,7 @@
(TFn [[r :variance :covariant]
[s :variance :invariant]]
[s -> '[r s]]))
+;TODO scope `s` in state-m body.
(ann state-m (All [s]
(Monad (TFn [[x :variance :covariant]]
(State x s)))))
@@ -576,14 +577,14 @@
[m-result (ann-form
(fn m-result-state [v]
(fn [s] [v s]))
- (All [r s]
+ (All [r]
[r -> (State r s)]))
m-bind (ann-form
(fn m-bind-state [mv f]
(fn [s]
(let [[v ss] (mv s)]
((f v) ss))))
- (All [s ra rb]
+ (All [ra rb]
[(State ra s) [ra -> (State rb s)] -> (State rb s)]))
])
View
8 test/typed/test/person.clj
@@ -1,6 +1,6 @@
(ns typed.test.person
(:require [typed.core
- :refer [check-ns ann-datatype
+ :refer [check-ns cf ann-datatype ann
tc-ignore ann-protocol AnyInteger]]))
(ann-protocol Age
@@ -20,3 +20,9 @@
(age (Person. "Lucy" 34))
+
+(ann my-apply (All [x y] [[x -> y] x -> y]))
+(defn my-apply [f a]
+ (f a))
+
+#_(my-apply age nil)

0 comments on commit 40d1262

Please sign in to comment.
Something went wrong with that request. Please try again.