Permalink
Browse files

Start with CLJS impl

  • Loading branch information...
1 parent fb60bb5 commit a78388081e2f20efddfda75ddf2b072db5e4fd17 @frenchy64 committed Nov 19, 2012
Showing with 171 additions and 41 deletions.
  1. +3 −2 project.clj
  2. +9 −6 src/typed/check.clj
  3. +87 −0 src/typed/check_cljs.clj
  4. +34 −18 src/typed/core.clj
  5. +1 −1 src/typed/cs_gen.clj
  6. +2 −1 src/typed/subtype.clj
  7. +10 −0 test/typed/test/cljs.clj
  8. +25 −13 test/typed/test/core.clj
View
@@ -4,7 +4,8 @@
[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"]
- [org.clojure/clojurescript "0.0-1450"]]
+ [org.clojure/clojurescript "0.0-1450"]
+ [org.clojure/tools.trace "0.7.3"]
+ ]
:dev-dependencies [[org.clojure/tools.macro "0.1.0"] ;for algo.monads
- [org.clojure/tools.trace "0.7.3"]
])
View
@@ -50,18 +50,21 @@
(:op expr)))
(defn check-top-level [nsym form]
+ (ensure-clojure)
(let [ast (analyze/analyze-form-in-ns nsym form)]
(check ast)))
(defmacro tc-t [form]
- `(-> (check-top-level (symbol (ns-name *ns*))
- '~form)
- expr-type))
+ `(do (ensure-clojure)
+ (-> (check-top-level (symbol (ns-name *ns*))
+ '~form)
+ expr-type)))
(defmacro tc [form]
- `(-> (check-top-level (symbol (ns-name *ns*))
- '~form)
- expr-type unparse-type))
+ `(do (ensure-clojure)
+ (-> (check-top-level (symbol (ns-name *ns*))
+ '~form)
+ expr-type unparse-type)))
(defmulti constant-type class)
View
@@ -0,0 +1,87 @@
+(in-ns 'typed.core)
+
+(defmulti check-cljs (fn [expr & [expected]] (:op expr)))
+
+(defmethod check-cljs :constant
+ [{:keys [form] :as expr} & [expected]]
+ (assert (not expected))
+ (assoc expr
+ expr-type (ret (->Value form))))
+
+(defmethod check-cljs :vector
+ [{:keys [items] :as expr} & [expected]]
+ (assert (not expected))
+ (let [citems (mapv check-cljs items)]
+ (assoc expr
+ expr-type (ret (->HeterogeneousVector (mapv (comp ret-t expr-type) citems))))))
+
+(defmethod check-cljs :map
+ [{mkeys :keys mvals :vals :as expr} & [expected]]
+ (assert (not expected))
+ (let [ckeys (mapv check-cljs mkeys)
+ cvals (mapv check-cljs mvals)
+ ;only handle keyword keys for now
+ _ (assert (every? (every-pred Value? #(keyword? (.val %)))
+ (map (comp ret-t expr-type) ckeys)))]
+ (assoc expr
+ expr-type (ret (->HeterogeneousMap (zipmap (map (comp ret-t expr-type) ckeys)
+ (map (comp ret-t expr-type) cvals)))))))
+
+(def CLJS-VAR-ENV (atom {}))
+(set-validator! CLJS-VAR-ENV (hash-c? symbol? Type?))
+
+(defn type-of [vname]
+ (let [t (@CLJS-VAR-ENV vname)]
+ (if t
+ t
+ (throw (Exception. (str "Untyped var: " vname))))))
+
+(defn cljs-ann* [vname tsyn]
+ (let [vtype (parse-type tsyn)]
+ (swap! CLJS-VAR-ENV assoc vname vtype)
+ [vname (unparse-type vtype)]))
+
+(defmacro cljs-ann [vname tsyn]
+ `(cljs-ann* '~vname '~tsyn))
+
+(defmethod check-cljs :def
+ [{:keys [init] vname :name :as expr} & [expected]]
+ (assert init "declare NYI")
+ (assert (not expected))
+ (let [ann-type (type-of vname)
+ cinit (check-cljs init expected)
+ _ (assert (subtype? (-> cinit expr-type ret-t)
+ ann-type)
+ (str "Var definition did not match annotation." \n
+ " Expected: " (unparse-type ann-type) \n
+ " Actual" (unparse-type ann-type)))]
+ (assoc expr
+ ;FIXME should really be Var, change when protocols are implemented
+ expr-type (ret -any))))
+
+;(defmethod check-cljs :invoke
+; [{:keys [f args] :as expr} & [expected]]
+; (assert (not expected))
+
+(comment
+ ;; TODO there's a bug in the docstring for cljs.analyzer/analyze: it says :ns is a symbol, when instead it's {:name nsym}
+ (def denv {:locals {} :context :expr :ns {:name 'user}})
+
+(cljs/analyze denv 1)
+ (cf-cljs 1)
+
+(cljs/analyze denv [1])
+ (cf-cljs [1])
+
+(cljs/analyze denv {:a 1})
+(cf-cljs {:a 1})
+
+(cljs-ann user/a Any)
+ (@CLJS-VAR-ENV 'user/a)
+
+(cljs/analyze denv '(def a 1))
+(cf-cljs (def a 1))
+
+(cljs/analyze denv '(1))
+(cf-cljs (1))
+ )
View
@@ -14,8 +14,10 @@
[clojure.pprint :refer [pprint]]
[trammel.core :as contracts]
[clojure.math.combinatorics :as comb]
- [cljs.analyzer :as cljs]
- #_[clojure.tools.trace :refer [trace-vars untrace-vars
+ [cljs
+ [compiler]
+ [analyzer :as cljs]]
+ [clojure.tools.trace :refer [trace-vars untrace-vars
trace-ns untrace-ns]]))
; constraint shorthands, other handy functions
@@ -175,7 +177,7 @@
"Declare a kind for an alias, similar to declare but on the kind level."
[sym ty]
`(tc-ignore
- (binding [*typed-impl* ::clojure]
+ (do (ensure-clojure)
(let [sym# '~sym
qsym# (if (namespace sym#)
sym#
@@ -200,7 +202,7 @@
"Define a type alias"
[sym type]
`(tc-ignore
- (binding [*typed-impl* ::clojure]
+ (do (ensure-clojure)
(let [sym# (if (namespace '~sym)
'~sym
(symbol (name (ns-name *ns*)) (name '~sym)))
@@ -316,7 +318,7 @@
(defmacro ann [varsym typesyn]
`(tc-ignore
- (binding [*typed-impl* ::clojure]
+ (do (ensure-clojure)
(let [t# (parse-type '~typesyn)
s# (if (namespace '~varsym)
'~varsym
@@ -330,7 +332,7 @@
[n (parse-type t)])
(defn gen-datatype* [provided-name fields variances args ancests]
- `(binding [*typed-impl* ::clojure]
+ `(do (ensure-clojure)
(let [provided-name-str# (str '~provided-name)
;_# (prn "provided-name-str" provided-name-str#)
munged-ns-str# (if (some #(= \. %) provided-name-str#)
@@ -388,7 +390,7 @@
~(gen-datatype* dname fields (map second vbnd) (map first vbnd) ancests)))
(defn gen-protocol* [local-varsym variances args mths]
- `(binding [*typed-impl* ::clojure]
+ `(do (ensure-clojure)
(let [local-vsym# '~local-varsym
s# (symbol (-> *ns* ns-name str) (str local-vsym#))
on-class# (symbol (str (munge (namespace s#)) \. local-vsym#))
@@ -431,15 +433,15 @@
(defmacro override-constructor [ctorsym typesyn]
`(tc-ignore
- (binding [*typed-impl* ::clojure]
+ (do (ensure-clojure)
(let [t# (parse-type '~typesyn)
s# '~ctorsym]
(do (add-constructor-override s# t#)
[s# (unparse-type t#)])))))
(defmacro override-method [methodsym typesyn]
`(tc-ignore
- (binding [*typed-impl* ::clojure]
+ (do (ensure-clojure)
(let [t# (parse-type '~typesyn)
s# (if (namespace '~methodsym)
'~methodsym
@@ -513,8 +515,14 @@
(derive ::clojurescript ::default)
(derive ::clojure ::default)
-(def ^:dynamic *typed-impl*)
-(set-validator! #'*typed-impl* #(isa? % ::default))
+(def TYPED-IMPL (atom ::clojure))
+(set-validator! TYPED-IMPL #(isa? % ::default))
+
+(defn ensure-clojure []
+ (reset! TYPED-IMPL ::clojure))
+
+(defn ensure-clojurescript []
+ (reset! TYPED-IMPL ::clojurescript))
(load "dvar_env")
(load "datatype_ancestor_env")
@@ -543,15 +551,23 @@
(load "alter")
(load "ann")
(load "check")
+(load "check_cljs")
+
+(defmacro cf-cljs
+ "Type check a Clojurescript form and return its type"
+ ([form]
+ `(do (ensure-clojurescript)
+ (tc-ignore
+ (-> (cljs/analyze {:locals {} :context :expr :ns {:name '~'user}} '~form) check-cljs expr-type unparse-TCResult)))))
(defmacro cf
- "Type check a form and return its type"
+ "Type check a Clojure form and return its type"
([form]
- `(binding [*typed-impl* ::clojure]
+ `(do (ensure-clojure)
(tc-ignore
(-> (ast ~form) check expr-type unparse-TCResult))))
([form expected]
- `(binding [*typed-impl* ::clojure]
+ `(do (ensure-clojure)
(tc-ignore
(-> (ast (ann-form ~form ~expected)) (#(check % (ret (parse-type '~expected)))) expr-type unparse-TCResult)))))
@@ -560,18 +576,18 @@
([] (check-ns (ns-name *ns*)))
([nsym]
(require nsym)
+ (ensure-clojure)
(with-open [pbr (analyze/pb-reader-for-ns nsym)]
(let [[_ns-decl_ & asts] (analyze/analyze-ns pbr (analyze/uri-for-ns nsym) nsym)]
- (binding [*typed-impl* ::clojure]
(doseq [ast asts]
- (check ast)))))))
+ (check ast))))))
(defn trepl []
(clojure.main/repl
:eval (fn [f]
- (let [t (binding [*typed-impl* ::clojure]
+ (let [t (do (ensure-clojure)
(-> (analyze/analyze-form f)
- check expr-type unparse-TCResult))]
+ check expr-type unparse-TCResult))]
(prn t)
(eval f)))))
View
@@ -287,7 +287,7 @@
(every? (hash-c? symbol Bounds?) [X Y])
(AnyType? S)
(AnyType? T)]}
- [(class S) (class T) *typed-impl*]))
+ [(class S) (class T) @TYPED-IMPL]))
; (see cs-gen*)
;cs-gen calls cs-gen*, remembering the current subtype for recursive types
View
@@ -43,7 +43,7 @@
;
; In short, only call subtype (or subtype?)
-(defmulti subtype* (fn [s t] [(class s) (class t) *typed-impl*]))
+(defmulti subtype* (fn [s t] [(class s) (class t) @TYPED-IMPL]))
(defn subtype? [s t]
(try
@@ -613,6 +613,7 @@
(defmethod subtype* :default
[s t]
+ #_(prn "subtype :default" @TYPED-IMPL (unparse-type s) (unparse-type t))
(if (Top? t)
*sub-current-seen*
(type-error s t)))
View
@@ -0,0 +1,10 @@
+(ns typed.test.core
+ (:refer-clojure :exclude [defrecord])
+ (:require [clojure.test :refer :all]
+ [analyze.core :refer [ast]]
+ [clojure.repl :refer [pst]]
+ [clojure.pprint :refer [pprint]]
+ [clojure.data :refer [diff]]
+ [typed.core :as tc, :refer :all, :exclude [subtype? check]]
+ [clojure.tools.trace :refer [trace-vars untrace-vars
+ trace-ns untrace-ns]]))
View
@@ -7,9 +7,19 @@
[clojure.repl :refer [pst]]
[clojure.pprint :refer [pprint]]
[clojure.data :refer [diff]]
- [typed.core :refer :all]
+ [typed.core :as tc, :refer :all, :exclude [subtype? check]]
[typed.test.rbt]
- [typed.test.deftype]))
+ [typed.test.deftype]
+ [clojure.tools.trace :refer [trace-vars untrace-vars
+ trace-ns untrace-ns]]))
+
+(defn subtype? [& rs]
+ (ensure-clojure)
+ (apply tc/subtype? rs))
+
+(defn check [& as]
+ (ensure-clojure)
+ (apply tc/check as))
;(check-ns 'typed.test.deftype)
@@ -178,7 +188,8 @@
;return type for an expression f
(defmacro ety [f]
- `(-> (ast ~f) check expr-type ret-t))
+ `(do (ensure-clojure)
+ (-> (ast ~f) check expr-type ret-t)))
(deftest tc-invoke-fn-test
(is (subtype? (ety
@@ -225,7 +236,7 @@
((typed.core/fn> [[a :- (clojure.lang.Seqable Number)] [b :- Number]]
(seq a))
[1 2 1.2] 1))
- (parse-type '(U nil (clojure.lang.ASeq Number)))))
+ (parse-type '(U nil (I (CountRange 1) (clojure.lang.ISeq Number))))))
(is (subtype? (ety
((typed.core/fn> [[a :- (clojure.lang.IPersistentMap Any Number)] [b :- Number]]
((typed.core/inst get Number) a b))
@@ -252,14 +263,15 @@
(ret (->Value 1) (-FS -top -bot) (->EmptyObject)))))
(deftest empty-fn-test
- (is (= (tc-t (fn []))
- (ret (make-FnIntersection
- (->Function [] (make-Result -nil
+ (is (do (prn "empty-fn-test" @typed.core/TYPED-IMPL)
+ (= (tc-t (fn []))
+ (ret (make-FnIntersection
+ (->Function [] (make-Result -nil
(-FS -bot -top)
(->EmptyObject))
nil nil nil))
- (-FS -top -bot)
- (->EmptyObject))))
+ (-FS -top -bot)
+ (->EmptyObject)))))
(is (= (tc-t (fn [] 1))
(ret (make-FnIntersection
(->Function [] (make-Result (->Value 1)
@@ -929,10 +941,10 @@
(deftest first-seq-test
(is (subtype? (ret-t (tc-t (first [1 1 1])))
(Un -nil (RClass-of Number))))
- (is (subtype (In (RClass-of clojure.lang.PersistentList [-any])
- (make-CountRange 1))
- (In (RClass-of Seqable [-any])
- (make-CountRange 1))))
+ (is (subtype? (In (RClass-of clojure.lang.PersistentList [-any])
+ (make-CountRange 1))
+ (In (RClass-of Seqable [-any])
+ (make-CountRange 1))))
(is (subtype? (ret-t (tc-t (let [l [1 2 3]]
(if (seq l)
(first l)

0 comments on commit a783880

Please sign in to comment.