Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

More CLJS

  • Loading branch information...
commit 733a2e023069f0add7dd410aab6cd05870a5827b 1 parent a783880
@frenchy64 authored
View
37 src/typed/check.clj
@@ -1560,14 +1560,31 @@
(declare check-fn)
+(def ^:dynamic *check-fn-method1-checkfn*)
+; [(U nil Type) (U nil DottedPretype) -> Type]
+; takes the current rest or drest argument (only one is non-nil) and returns
+; the type to assign the rest parameter
+(def ^:dynamic *check-fn-method1-rest-type*)
+
(defmethod check :fn-expr
[{:keys [env] :as expr} & [expected]]
{:post [(-> % expr-type TCResult?)]}
(assert (:line env))
- (binding [*current-env* env]
- (check-fn expr (or expected
- (ret (make-FnIntersection
- (make-Function [] -any -any)))))))
+ (binding [*current-env* env
+ *check-fn-method1-checkfn* check
+ *check-fn-method1-checkfn* (fn [rest drest]
+ {:pre [(some-fn #(when rest
+ (Type? rest))
+ #(when drest
+ (DottedPretype? drest)))
+ (not (and rest drest))]
+ :post [(Type? %)]}
+ (Un -nil (In (RClass-of Seqable [(or rest (.pre-type drest))])
+ (make-CountRange 1))))]
+ (assoc expr
+ expr-type (check-fn expr (or expected
+ (ret (make-FnIntersection
+ (make-Function [] -any -any))))))))
(declare check-anon-fn-method abstract-filter abo abstract-object)
@@ -1766,7 +1783,8 @@
(defn check-fn
"Check a fn to be under expected and annotate the inferred type"
[{:keys [methods variadic-method] :as fexpr} expected]
- {:pre [(TCResult? expected)]}
+ {:pre [(TCResult? expected)]
+ :post [(TCResult? %)]}
(let [; try and unwrap type enough to find function types
exp (resolve-to-ftype (ret-t expected))
; unwrap polymorphic expected types
@@ -1796,8 +1814,7 @@
[variadic-method])))))))
;rewrap in Poly or PolyDots if needed
pfni (rewrap-poly inferred-fni orig-names inst-frees bnds poly?)]
- (assoc fexpr
- expr-type (ret pfni (-FS -top -bot) -empty))))
+ (ret pfni (-FS -top -bot) -empty)))
(defn check-fn-method [{:keys [required-params rest-param] :as method} fin]
{:pre [(FnIntersection? fin)]
@@ -1851,8 +1868,8 @@
fixed-entry (map vector (map :sym required-params) (concat dom (repeat (or rest
(:pre-type drest)))))
rest-entry (when rest-param
- [[(:sym rest-param) (Un -nil (In (RClass-of Seqable [(or rest (:pre-type drest))])
- (make-CountRange 1)))]])
+ [[(:sym rest-param)
+ (*check-fn-method1-rest-type* rest drest)]])
_ (assert ((hash-c? symbol? Type?) (into {} fixed-entry)))
_ (assert ((some-fn nil? (hash-c? symbol? Type?)) (when rest-entry
(into {} rest-entry))))
@@ -1864,7 +1881,7 @@
crng-nopass
(with-lexical-env env
(with-recur-target (->RecurTarget dom rest drest nil)
- (check body expected-rng)))
+ (*check-fn-method1-checkfn* body expected-rng)))
; Apply the filters of computed rng to the environment and express
; changes to the lexical env as new filters, and conjoin with existing filters.
View
230 src/typed/check_cljs.clj
@@ -1,12 +1,120 @@
(in-ns 'typed.core)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Modify CLJS specials
+
+(def new-specials '#{defprotocol typed.core/ann-form-cljs})
+
+(.doReset #'cljs.analyzer/specials (set/union cljs/specials new-specials))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Special forms
+
+(defmacro ann-form-cljs [form tsyn]
+ `form)
+
+(defmacro cljs-ann [vname tsyn]
+ `(cljs-ann* '~vname '~tsyn))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Envs
+
+(defonce CLJS-VAR-ENV (atom {}))
+(set-validator! CLJS-VAR-ENV (hash-c? symbol? Type?))
+
+(defn cljs-ann* [vname tsyn]
+ (let [vtype (parse-type tsyn)]
+ (swap! CLJS-VAR-ENV assoc vname vtype)
+ [vname (unparse-type vtype)]))
+
+(defn type-of [vname]
+ (let [t (@CLJS-VAR-ENV vname)]
+ (if t
+ t
+ (throw (Exception. (str "Untyped var: " vname))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Types
+
+(defrecord SymbolCLJS []
+ "A type for Clojurescript symbols"
+ [])
+
+(defrecord BooleanCLJS []
+ "A type for Clojurescript boolean values"
+ [])
+
+(declare-type SymbolCLJS)
+(declare-type BooleanCLJS)
+
+
+;; Parse type
+
+(defmethod parse-type-symbol 'SymbolCLJS [_] (->SymbolCLJS))
+(defmethod parse-type-symbol 'BooleanCLJS [_] (->BooleanCLJS))
+
+(defmethod parse-type-list 'predicate-cljs
+ [[_ t-syn]]
+ (let [on-type (parse-type t-syn)]
+ (make-FnIntersection
+ (make-Function [-any] (->BooleanCLJS) nil nil
+ :filter (-FS (-filter on-type 0)
+ (-not-filter on-type 0))))))
+
+;; Unparse-type
+
+(defmethod unparse-type* SymbolCLJS
+ [_]
+ 'SymbolCLJS)
+
+(defmethod unparse-type* BooleanCLJS
+ [_]
+ 'BooleanCLJS)
+
+;; fold
+
+(add-default-fold-case BooleanCLJS ret-first)
+(add-default-fold-case SymbolCLJS ret-first)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Subtyping
+
+(defmethod subtype* [Value SymbolCLJS ::clojurescript]
+ [{:keys [val] :as s} t]
+ (if (symbol? val)
+ *current-env*
+ (type-error s t)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parsing new special forms
+
+(defmethod cljs/parse 'defprotocol
+ [op env [psym & doc+methods :as form] name]
+ {:op :defprotocol
+ :env env
+ :form form})
+
+(defmethod cljs/parse 'typed.core/ann-form-cljs
+ [op env [_ form tsyn :as as] name]
+ (assert (= 3 (count as)))
+ {:op :ann-form-cljs
+ :env env
+ :form form
+ :the-expr (cljs/analyze env form)
+ :expected (parse-type tsyn)})
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check CLJS AST
+
(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))))
+ (let [t (->Value form)
+ _ (when expected
+ (subtype t (ret-t expected)))]
+ (assoc expr
+ expr-type (ret t))))
(defmethod check-cljs :vector
[{:keys [items] :as expr} & [expected]]
@@ -27,23 +135,6 @@
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")
@@ -59,13 +150,76 @@
;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))
+;doesn't do anything right now
+(defmethod check-cljs :defprotocol
+ [{:keys [init] vname :name :as expr} & [expected]]
+ (assoc expr
+ expr-type (ret (->SymbolCLJS))))
+
+(defmethod check-cljs :ann-form-cljs
+ [{:keys [the-expr] given-type :expected :as expr} & [expected]]
+ (let [cform (check-cljs the-expr (ret given-type))
+ _ (assert (subtype? (-> cform expr-type ret-t) given-type)
+ (str "Annotation does not match actual type:"\n
+ "Expected: " (unparse-type given-type)\n
+ "Actual: " (unparse-type (-> cform expr-type ret-t))))
+ _ (when expr-type
+ (assert (subtype? given-type (ret-t expected))))]
+ (assoc expr
+ expr-type (ret given-type))))
+
+(defmethod check-cljs :invoke
+ [{fexpr :f :keys [args] :as expr} & [expected]]
+ (let [cfexpr (check-cljs fexpr)
+ cargs (mapv check-cljs args)
+ ftype (expr-type cfexpr)
+ argtys (map expr-type cargs)
+ actual (check-funapp ftype argtys expected)]
+ (assoc expr
+ expr-type actual)))
+
+(defmethod check-cljs :var
+ [{{vname :name} :info :as expr} & [expected]]
+ (assoc expr
+ expr-type (ret (type-of vname))))
+
+(defmethod check-cljs :do
+ [{:keys [ret statements] :as expr} & [expected]]
+ (let [cstatements (mapv check-cljs statements)
+ cret (check-cljs ret expected)]
+ (assoc expr
+ expr-type (expr-type cret))))
+
+
+(defmethod check-cljs :fn
+ [{:keys [name max-fixed-arity methods variadic] :as expr} & [expected]]
+ (binding [*check-fn-method1-checkfn* check-cljs]
+ (assoc expr
+ expr-type
+ (check-fn (-> ;conform to what `check-fn` expects for now
+ expr
+ (dissoc :variadic)
+ (assoc :variadic-method variadic)
+ (update-in [:methods] #(map (fn [{:keys [params max-fixed-arity variadic ret statements] :as cljs-m}]
+ {:required-params (map (fn [p] {:sym p}) params),
+ :rest-param (when variadic
+ {:sym variadic})
+ ;transform body into a `do`
+ :body {:op :do, :ret ret, :statements statements}})
+ %)))
+ (or expected
+ (ret (make-FnIntersection
+ (make-Function [] -any -any))))))))
+
+;; Debug
+
+(defn ana-cljs [env form]
+ (binding [cljs/*cljs-ns* (-> env :ns :name)]
+ (cljs/analyze env form)))
(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}})
+ (def denv {:locals {} :context :statement :ns {:name 'cljs.user}})
(cljs/analyze denv 1)
(cf-cljs 1)
@@ -82,6 +236,30 @@
(cljs/analyze denv '(def a 1))
(cf-cljs (def a 1))
-(cljs/analyze denv '(1))
-(cf-cljs (1))
+; defprotocol doesn't macroexpand because we've added 'defprotocol as a special
+(cljs/macroexpand-1 {} '(defprotocol A))
+(cljs/analyze denv '(defprotocol A))
+(cf-cljs (defprotocol A))
+
+
+(ana-cljs denv '(ns cljs.user (:require-macros [typed.core :as typ])))
+(cljs/macroexpand-1 {} '(ann-form-cljs 'a SymbolCLJS))
+(cf-cljs (ann-form-cljs 'a SymbolCLJS))
+
+ ;occurrence typing
+(cljs-ann cljs.core/symbol? (predicate-cljs SymbolCLJS))
+(ana-cljs denv 'cljs.core/symbol?)
+(cf-cljs (cljs.core/symbol? 'a))
+
+; do
+(ana-cljs denv '(do 1 2 ))
+
+; fn
+(ana-cljs denv '(fn [a] 12 1 ))
+(cf-cljs (fn []))
+(cf-cljs (fn [a]))
+(cf-cljs (fn [a b c]))
+(cf-cljs (fn [a b c]) [BooleanCLJS BooleanCLJS Any -> nil])
+
+(cf-cljs (fn [a b c] a) [BooleanCLJS BooleanCLJS Any -> BooleanCLJS])
)
View
16 src/typed/core.clj
@@ -524,6 +524,12 @@
(defn ensure-clojurescript []
(reset! TYPED-IMPL ::clojurescript))
+(defn checking-clojure? []
+ (= ::clojure @TYPED-IMPL))
+
+(defn checking-clojurescript? []
+ (= ::clojurescript @TYPED-IMPL))
+
(load "dvar_env")
(load "datatype_ancestor_env")
(load "datatype_env")
@@ -558,7 +564,13 @@
([form]
`(do (ensure-clojurescript)
(tc-ignore
- (-> (cljs/analyze {:locals {} :context :expr :ns {:name '~'user}} '~form) check-cljs expr-type unparse-TCResult)))))
+ (-> (ana-cljs {:locals {} :context :expr :ns {:name '~'cljs.user}} '~form) check-cljs expr-type unparse-TCResult))))
+ ([form expected]
+ `(do (ensure-clojure)
+ (tc-ignore
+ (-> (ana-cljs {:locals {} :context :expr :ns {:name '~'cljs.user}}
+ '(typed.core/ann-form-cljs ~form ~expected))
+ (#(check-cljs % (ret (parse-type '~expected)))) expr-type unparse-TCResult)))))
(defmacro cf
"Type check a Clojure form and return its type"
@@ -569,7 +581,7 @@
([form expected]
`(do (ensure-clojure)
(tc-ignore
- (-> (ast (ann-form ~form ~expected)) (#(check % (ret (parse-type '~expected)))) expr-type unparse-TCResult)))))
+ (-> (ast (ann-form-cljs ~form ~expected)) (#(check % (ret (parse-type '~expected)))) expr-type unparse-TCResult)))))
(defn check-ns
"Type check a namespace. If not provided default to current namespace"
View
3  src/typed/subtype.clj
@@ -159,7 +159,8 @@
(type-error s t))
;values are subtypes of their classes
- (Value? s)
+ (and (Value? s)
+ (checking-clojure?))
(if (nil? (.val s))
(type-error s t)
(subtype (RClass-of (class (.val s))) t))
Please sign in to comment.
Something went wrong with that request. Please try again.