Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add ns to refactored files. Prepare for CLJS

  • Loading branch information...
commit fb60bb55589c6f2b3c381631ce4195af1783f859 1 parent 1dd6589
@frenchy64 authored
Showing with 158 additions and 94 deletions.
  1. +1 −0  notes/filter_ops.clj
  2. +2 −1  project.clj
  3. +1 −0  src/typed/alter.clj
  4. +1 −0  src/typed/ann.clj
  5. +3 −1 src/typed/check.clj
  6. +69 −51 src/typed/core.clj
  7. +15 −13 src/typed/cs_gen.clj
  8. +1 −0  src/typed/ctor_override_env.clj
  9. +1 −0  src/typed/datatype_ancestor_env.clj
  10. +1 −0  src/typed/datatype_env.clj
  11. +1 −0  src/typed/declared_kind_env.clj
  12. +1 −0  src/typed/dvar_env.clj
  13. +2 −0  src/typed/filter_rep.clj
  14. +1 −0  src/typed/fold.clj
  15. +1 −0  src/typed/frees.clj
  16. +1 −0  src/typed/infer.clj
  17. +1 −0  src/typed/inst.clj
  18. +4 −0 src/typed/method_override_env.clj
  19. +1 −0  src/typed/method_param_nilables.clj
  20. +1 −0  src/typed/method_return_nilables.clj
  21. +1 −0  src/typed/name_env.clj
  22. +1 −0  src/typed/object_rep.clj
  23. +1 −0  src/typed/parse.clj
  24. +1 −0  src/typed/path_rep.clj
  25. +1 −0  src/typed/promote_demote.clj
  26. +1 −0  src/typed/protocol_env.clj
  27. +1 −0  src/typed/rclass_env.clj
  28. +1 −0  src/typed/subst.clj
  29. +3 −0  src/typed/subst_dots.clj
  30. +29 −28 src/typed/subtype.clj
  31. +1 −0  src/typed/trans.clj
  32. +1 −0  src/typed/tvar_rep.clj
  33. +1 −0  src/typed/type_ops.clj
  34. +1 −0  src/typed/type_rep.clj
  35. +1 −0  src/typed/unparse.clj
  36. +1 −0  src/typed/utils.clj
  37. +3 −0  test/typed/test/monads.clj
View
1  notes/filter_ops.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
(declare subtype? compact)
View
3  project.clj
@@ -3,7 +3,8 @@
:dependencies [[analyze "0.2"]
[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/math.combinatorics "0.0.2"]
+ [org.clojure/clojurescript "0.0-1450"]]
:dev-dependencies [[org.clojure/tools.macro "0.1.0"] ;for algo.monads
[org.clojure/tools.trace "0.7.3"]
])
View
1  src/typed/alter.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Altered Classes
View
1  src/typed/ann.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type annotations
View
4 src/typed/check.clj
@@ -1,3 +1,5 @@
+(in-ns 'typed.core)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Checker
@@ -1945,7 +1947,7 @@
(if-let [typ (or (primitives sym)
(symbol->PArray sym nilable?)
(when-let [cls (resolve sym)]
- (prn (class cls) cls)
+ #_(prn (class cls) cls)
(apply Un (RClass-of (Class->symbol cls) nil)
(when nilable?
[-nil]))))]
View
120 src/typed/core.clj
@@ -14,10 +14,11 @@
[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
trace-ns untrace-ns]]))
-;load constraint shorthands, other handy functions
+; constraint shorthands, other handy functions
(load "utils")
;Note: defrecord is now trammel's defconstrainedrecord
@@ -174,15 +175,16 @@
"Declare a kind for an alias, similar to declare but on the kind level."
[sym ty]
`(tc-ignore
- (let [sym# '~sym
- qsym# (if (namespace sym#)
- sym#
- (symbol (name (ns-name *ns*)) (name sym#)))
- ty# (parse-type '~ty)]
- (assert (not (namespace sym#)) (str "Cannot declare qualified name " sym#))
- (declare ~sym)
- (declare-names ~sym)
- (declare-alias-kind* qsym# ty#))))
+ (binding [*typed-impl* ::clojure]
+ (let [sym# '~sym
+ qsym# (if (namespace sym#)
+ sym#
+ (symbol (name (ns-name *ns*)) (name sym#)))
+ ty# (parse-type '~ty)]
+ (assert (not (namespace sym#)) (str "Cannot declare qualified name " sym#))
+ (declare ~sym)
+ (declare-names ~sym)
+ (declare-alias-kind* qsym# ty#)))))
(defmacro declare-names
"Declare names, similar to declare but on the type level."
@@ -198,16 +200,17 @@
"Define a type alias"
[sym type]
`(tc-ignore
- (let [sym# (if (namespace '~sym)
- '~sym
- (symbol (name (ns-name *ns*)) (name '~sym)))
- ty# (parse-type '~type)]
- (add-type-name sym# ty#)
- (declare ~sym)
- (when-let [tfn# (@DECLARED-KIND-ENV sym#)]
- (assert (subtype? ty# tfn#) (error-msg "Declared kind " (unparse-type tfn#)
- " does not match actual kind " (unparse-type ty#))))
- [sym# (unparse-type ty#)])))
+ (binding [*typed-impl* ::clojure]
+ (let [sym# (if (namespace '~sym)
+ '~sym
+ (symbol (name (ns-name *ns*)) (name '~sym)))
+ ty# (parse-type '~type)]
+ (add-type-name sym# ty#)
+ (declare ~sym)
+ (when-let [tfn# (@DECLARED-KIND-ENV sym#)]
+ (assert (subtype? ty# tfn#) (error-msg "Declared kind " (unparse-type tfn#)
+ " does not match actual kind " (unparse-type ty#))))
+ [sym# (unparse-type ty#)]))))
(defn into-array>* [javat cljt coll]
(into-array (resolve javat) coll))
@@ -313,12 +316,13 @@
(defmacro ann [varsym typesyn]
`(tc-ignore
- (let [t# (parse-type '~typesyn)
- s# (if (namespace '~varsym)
- '~varsym
- (symbol (-> *ns* ns-name str) (str '~varsym)))]
- (do (add-var-type s# t#)
- [s# (unparse-type t#)]))))
+ (binding [*typed-impl* ::clojure]
+ (let [t# (parse-type '~typesyn)
+ s# (if (namespace '~varsym)
+ '~varsym
+ (symbol (-> *ns* ns-name str) (str '~varsym)))]
+ (do (add-var-type s# t#)
+ [s# (unparse-type t#)])))))
(declare parse-type alter-class*)
@@ -326,18 +330,19 @@
[n (parse-type t)])
(defn gen-datatype* [provided-name fields variances args ancests]
- `(let [provided-name-str# (str '~provided-name)
- _# (prn "provided-name-str" provided-name-str#)
+ `(binding [*typed-impl* ::clojure]
+ (let [provided-name-str# (str '~provided-name)
+ ;_# (prn "provided-name-str" provided-name-str#)
munged-ns-str# (if (some #(= \. %) provided-name-str#)
(apply str (butlast (apply concat (butlast (partition-by #(= \. %) provided-name-str#)))))
(str (munge (-> *ns* ns-name))))
- _# (prn "munged-ns-str" munged-ns-str#)
+ ;_# (prn "munged-ns-str" munged-ns-str#)
demunged-ns-str# (str (clojure.repl/demunge munged-ns-str#))
- _# (prn "demunged-ns-str" demunged-ns-str#)
+ ;_# (prn "demunged-ns-str" demunged-ns-str#)
local-name# (if (some #(= \. %) provided-name-str#)
(symbol (apply str (last (partition-by #(= \. %) (str provided-name-str#)))))
provided-name-str#)
- _# (prn "local-name" local-name#)
+ ;_# (prn "local-name" local-name#)
s# (symbol (str munged-ns-str# \. local-name#))
fs# (apply array-map (apply concat (with-frees (mapv make-F '~args)
(mapv parse-field '~fields))))
@@ -366,7 +371,7 @@
(add-datatype s# dt#)
(add-var-type pos-ctor-name# pos-ctor#)
[[s# (unparse-type dt#)]
- [pos-ctor-name# (unparse-type pos-ctor#)]])))
+ [pos-ctor-name# (unparse-type pos-ctor#)]]))))
(defmacro ann-datatype [dname fields & {ancests :unchecked-ancestors rplc :replace}]
(assert (not rplc) "Replace NYI")
@@ -383,7 +388,8 @@
~(gen-datatype* dname fields (map second vbnd) (map first vbnd) ancests)))
(defn gen-protocol* [local-varsym variances args mths]
- `(let [local-vsym# '~local-varsym
+ `(binding [*typed-impl* ::clojure]
+ (let [local-vsym# '~local-varsym
s# (symbol (-> *ns* ns-name str) (str local-vsym#))
on-class# (symbol (str (munge (namespace s#)) \. local-vsym#))
; add a Name so the methods can be parsed
@@ -407,7 +413,7 @@
;qualify method names when adding methods as vars
(let [kq# (symbol (-> *ns* ns-name str) (str kuq#))]
(add-var-type kq# mt#)))
- [s# (unparse-type t#)])))
+ [s# (unparse-type t#)]))))
(defmacro ann-protocol [local-varsym & {mths :methods}]
(assert (not (or (namespace local-varsym)
@@ -425,19 +431,21 @@
(defmacro override-constructor [ctorsym typesyn]
`(tc-ignore
- (let [t# (parse-type '~typesyn)
- s# '~ctorsym]
- (do (add-constructor-override s# t#)
- [s# (unparse-type t#)]))))
+ (binding [*typed-impl* ::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
- (let [t# (parse-type '~typesyn)
- s# (if (namespace '~methodsym)
- '~methodsym
- (throw (Exception. "Method name must be a qualified symbol")))]
- (do (add-method-override s# t#)
- [s# (unparse-type t#)]))))
+ (binding [*typed-impl* ::clojure]
+ (let [t# (parse-type '~typesyn)
+ s# (if (namespace '~methodsym)
+ '~methodsym
+ (throw (Exception. "Method name must be a qualified symbol")))]
+ (do (add-method-override s# t#)
+ [s# (unparse-type t#)])))))
(defn add-var-type [sym type]
(swap! VAR-ANNOTATIONS #(assoc % sym type))
@@ -502,6 +510,12 @@
:else (lookup-Var sym)))
+(derive ::clojurescript ::default)
+(derive ::clojure ::default)
+
+(def ^:dynamic *typed-impl*)
+(set-validator! #'*typed-impl* #(isa? % ::default))
+
(load "dvar_env")
(load "datatype_ancestor_env")
(load "datatype_env")
@@ -533,11 +547,13 @@
(defmacro cf
"Type check a form and return its type"
([form]
- `(tc-ignore
- (-> (ast ~form) check expr-type unparse-TCResult)))
+ `(binding [*typed-impl* ::clojure]
+ (tc-ignore
+ (-> (ast ~form) check expr-type unparse-TCResult))))
([form expected]
- `(tc-ignore
- (-> (ast (ann-form ~form ~expected)) (#(check % (ret (parse-type '~expected)))) expr-type unparse-TCResult))))
+ `(binding [*typed-impl* ::clojure]
+ (tc-ignore
+ (-> (ast (ann-form ~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"
@@ -546,14 +562,16 @@
(require nsym)
(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 (-> (analyze/analyze-form f)
- check expr-type unparse-TCResult)]
+ (let [t (binding [*typed-impl* ::clojure]
+ (-> (analyze/analyze-form f)
+ check expr-type unparse-TCResult))]
(prn t)
(eval f)))))
View
28 src/typed/cs_gen.clj
@@ -1,3 +1,5 @@
+(in-ns 'typed.core)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Constraint Generation
@@ -285,7 +287,7 @@
(every? (hash-c? symbol Bounds?) [X Y])
(AnyType? S)
(AnyType? T)]}
- [(class S) (class T)]))
+ [(class S) (class T) *typed-impl*]))
; (see cs-gen*)
;cs-gen calls cs-gen*, remembering the current subtype for recursive types
@@ -468,13 +470,13 @@
(declare cs-gen-Function)
-(defmethod cs-gen* [TApp TApp]
+(defmethod cs-gen* [TApp TApp ::default]
[V X Y S T]
(assert (= (.rator S) (.rator T)) (type-error S T))
(cset-meet*
(mapv #(cs-gen V X Y %1 %2) (.rands S) (.rands T))))
-(defmethod cs-gen* [FnIntersection FnIntersection]
+(defmethod cs-gen* [FnIntersection FnIntersection ::default]
[V X Y S T]
(cset-meet*
(doall
@@ -496,21 +498,21 @@
(type-error S T))
(cset-combine results))))))
-(defmethod cs-gen* [Result Result]
+(defmethod cs-gen* [Result Result ::default]
[V X Y S T]
(cset-meet* [(cs-gen V X Y (Result-type* S) (Result-type* T))
(cs-gen-filter-set V X Y (Result-filter* S) (Result-filter* T))
(cs-gen-object V X Y (Result-object* S) (Result-object* T))]))
-(defmethod cs-gen* [Value AnyValue]
+(defmethod cs-gen* [Value AnyValue ::default]
[V X Y S T]
(empty-cset X Y))
-(defmethod cs-gen* [Type Top]
+(defmethod cs-gen* [Type Top ::default]
[V X Y S T]
(empty-cset X Y))
-(defmethod cs-gen* [HeterogeneousVector RClass]
+(defmethod cs-gen* [HeterogeneousVector RClass ::clojure]
[V X Y S T]
(cs-gen V X Y
(In (RClass-of APersistentVector [(apply Un (:types S))])
@@ -519,18 +521,18 @@
(declare cs-gen-list)
-(defmethod cs-gen* [DataType DataType]
+(defmethod cs-gen* [DataType DataType ::default]
[V X Y S T]
(assert (= (:the-class S) (:the-class T)) (type-error S T))
(if (seq (:poly? S))
(cs-gen-list V X Y (:poly? S) (:poly? T))
(empty-cset X Y)))
-(defmethod cs-gen* [HeterogeneousVector HeterogeneousVector]
+(defmethod cs-gen* [HeterogeneousVector HeterogeneousVector ::default]
[V X Y S T]
(cs-gen-list V X Y (:types S) (:types T)))
-(defmethod cs-gen* [HeterogeneousMap HeterogeneousMap]
+(defmethod cs-gen* [HeterogeneousMap HeterogeneousMap ::default]
[V X Y S T]
(let [Skeys (set (keys (:types S)))
Tkeys (set (keys (:types T)))]
@@ -546,13 +548,13 @@
Tvals (map second STvals)]
(cs-gen-list V X Y Svals Tvals))))
-(defmethod cs-gen* [HeterogeneousMap RClass]
+(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)))
-(defmethod cs-gen* [RClass RClass]
+(defmethod cs-gen* [RClass RClass ::clojure]
[V X Y S T]
(let [relevant-S (some #(and (= (:the-class %) (:the-class T))
%)
@@ -849,7 +851,7 @@
:else
(throw (IllegalArgumentException. (pr-str "NYI Function inference " (unparse-type S) (unparse-type T)))))))
-(defmethod cs-gen* [Function Function]
+(defmethod cs-gen* [Function Function ::default]
[V X Y S T]
#_(prn "cs-gen* [Function Function]")
(cs-gen-Function V X Y S T))
View
1  src/typed/ctor_override_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Constructor Override Env
View
1  src/typed/datatype_ancestor_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
View
1  src/typed/datatype_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Datatype Env
View
1  src/typed/declared_kind_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Declared kind Env
View
1  src/typed/dvar_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dotted Variable Environment
View
2  src/typed/filter_rep.clj
@@ -1,3 +1,5 @@
+(in-ns 'typed.core)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Filters
View
1  src/typed/fold.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type Folding
View
1  src/typed/frees.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Collecting frees
View
1  src/typed/infer.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;; like infer, but dotted-var is the bound on the ...
View
1  src/typed/inst.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Polymorphic type instantiation
View
4 src/typed/method_override_env.clj
@@ -1,3 +1,7 @@
+(in-ns 'typed.core)
+
+; Should only override a method with a more specific type
+; eg.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Method Override Env
View
1  src/typed/method_param_nilables.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Method Param nilables
View
1  src/typed/method_return_nilables.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Method Return non-nilables
View
1  src/typed/name_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type Name Env
View
1  src/typed/object_rep.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Runtime Objects
View
1  src/typed/parse.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type syntax
View
1  src/typed/path_rep.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Paths
View
1  src/typed/promote_demote.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variable Elim
View
1  src/typed/protocol_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Protocol Env
View
1  src/typed/rclass_env.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Restricted Class
View
1  src/typed/subst.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variable substitution
View
3  src/typed/subst_dots.clj
@@ -1,3 +1,6 @@
+(in-ns 'typed.core)
+
+
(declare sub-f sub-o sub-pe)
View
57 src/typed/subtype.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Subtype
@@ -42,7 +43,7 @@
;
; In short, only call subtype (or subtype?)
-(defmulti subtype* (fn [s t] [(class s) (class t)]))
+(defmulti subtype* (fn [s t] [(class s) (class t) *typed-impl*]))
(defn subtype? [s t]
(try
@@ -250,7 +251,7 @@
(catch Exception e))
ts))
-(defmethod subtype* [Result Result]
+(defmethod subtype* [Result Result ::default]
[{t1 :t f1 :fl o1 :o :as s}
{t2 :t f2 :fl o2 :o :as t}]
(cond
@@ -279,13 +280,13 @@
(throw (Exception. (error-msg "Filters do not match: \n" (unparse-filter-set f1) "\n" (unparse-filter-set f2))))
(throw (Exception. (error-msg "Objects do not match " (unparse-object o1) (unparse-filter o2)))))))
-(defmethod subtype* [Protocol Type]
+(defmethod subtype* [Protocol Type ::clojure]
[s t]
(if (= (RClass-of Object) t)
*sub-current-seen*
(type-error s t)))
-(defmethod subtype* [Protocol Protocol]
+(defmethod subtype* [Protocol Protocol ::default]
[{var1 :the-var variances* :variances poly1 :poly? :as s}
{var2 :the-var poly2 :poly? :as t}]
(if (and (= var1 var2)
@@ -362,16 +363,16 @@
(defmethod subtype-TApp? :default [S T] false)
-(defmethod subtype* [TApp TApp]
+(defmethod subtype* [TApp TApp ::default]
[S T]
(if (subtype-TApp? S T)
*sub-current-seen*
(type-error S T)))
-(prefer-method subtype* [Type TApp] [HeterogeneousVector Type])
-(prefer-method subtype* [Type TApp] [HeterogeneousVector Type])
+(prefer-method subtype* [Type TApp ::default] [HeterogeneousVector Type ::default])
+(prefer-method subtype* [Type TApp ::default] [HeterogeneousVector Type ::default])
-(defmethod subtype* [TApp Type]
+(defmethod subtype* [TApp Type ::default]
[S T]
(if (and (not (F? (.rator S)))
(subtypeA*? (conj *sub-current-seen* [S T])
@@ -379,7 +380,7 @@
*sub-current-seen*
(type-error S T)))
-(defmethod subtype* [Type TApp]
+(defmethod subtype* [Type TApp ::default]
[S T]
(if (and (not (F? (.rator T)))
(subtypeA*? (conj *sub-current-seen* [S T])
@@ -387,7 +388,7 @@
*sub-current-seen*
(type-error S T)))
-(defmethod subtype* [TypeFn TypeFn]
+(defmethod subtype* [TypeFn TypeFn ::default]
[S T]
(if (and (= (.nbound S) (.nbound T))
(= (.variances S) (.variances T))
@@ -399,12 +400,12 @@
*sub-current-seen*
(type-error S T)))
-(defmethod subtype* [PrimitiveArray Type]
+(defmethod subtype* [PrimitiveArray Type ::clojure]
[_ t]
(subtype (->PrimitiveArray Object -any -any) t))
;Not quite correct, datatypes have other implicit ancestors (?)
-(defmethod subtype* [DataType Type]
+(defmethod subtype* [DataType Type ::clojure]
[{:keys [the-class] :as s} t]
(if (some #(subtype? % t) (set/union #{(RClass-of (Class->symbol Object) nil)}
(or (@DATATYPE-ANCESTOR-ENV the-class)
@@ -412,7 +413,7 @@
*sub-current-seen*
(type-error s t)))
-(defmethod subtype* [Type DataType]
+(defmethod subtype* [Type DataType ::clojure]
[s {:keys [the-class] :as t}]
(if (some #(subtype? s %) (set/union #{(RClass-of (Class->symbol Object) nil)}
(or (@DATATYPE-ANCESTOR-ENV the-class)
@@ -420,7 +421,7 @@
*sub-current-seen*
(type-error s t)))
-(defmethod subtype* [DataType DataType]
+(defmethod subtype* [DataType DataType ::default]
[{cls1 :the-class poly1 :poly? :as s}
{cls2 :the-class poly2 :poly? :as t}]
(if (and (= cls1 cls2)
@@ -499,7 +500,7 @@
(.isPrimitive ^Class tcls)
(-> (primitive-coersions tcls) :down (get scls)))))
-(defmethod subtype* [RClass RClass]
+(defmethod subtype* [RClass RClass ::clojure]
[{polyl? :poly? :as s}
{polyr? :poly? :as t}]
(let [scls (symbol->Class (:the-class s))
@@ -533,10 +534,10 @@
:else (type-error s t))))
(prefer-method subtype*
- [Type Mu]
- [HeterogeneousMap Type])
+ [Type Mu ::default]
+ [HeterogeneousMap Type ::clojure])
-(defmethod subtype* [HeterogeneousMap Type]
+(defmethod subtype* [HeterogeneousMap Type ::clojure]
[s t]
(let [sk (apply Un (map first (:types s)))
sv (apply Un (map second (:types s)))]
@@ -545,7 +546,7 @@
;every rtype entry must be in ltypes
;eg. {:a 1, :b 2, :c 3} <: {:a 1, :b 2}
-(defmethod subtype* [HeterogeneousMap HeterogeneousMap]
+(defmethod subtype* [HeterogeneousMap HeterogeneousMap ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
(last (doall (map (fn [[k v]]
@@ -554,53 +555,53 @@
(type-error s t)))
rtypes))))
-(defmethod subtype* [HeterogeneousVector HeterogeneousVector]
+(defmethod subtype* [HeterogeneousVector HeterogeneousVector ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
(last (doall (map #(subtype %1 %2) ltypes rtypes))))
-(defmethod subtype* [HeterogeneousVector Type]
+(defmethod subtype* [HeterogeneousVector Type ::clojure]
[s t]
(let [ss (apply Un (:types s))]
(subtype (In (RClass-of APersistentVector [ss])
(make-ExactCountRange (count (:types s))))
t)))
-(defmethod subtype* [HeterogeneousList HeterogeneousList]
+(defmethod subtype* [HeterogeneousList HeterogeneousList ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
(last (doall (map #(subtype %1 %2) ltypes rtypes))))
-(defmethod subtype* [HeterogeneousList Type]
+(defmethod subtype* [HeterogeneousList Type ::clojure]
[s t]
(let [ss (apply Un (:types s))]
(subtype (RClass-of (Class->symbol PersistentList) [ss])
t)))
-(defmethod subtype* [HeterogeneousSeq HeterogeneousSeq]
+(defmethod subtype* [HeterogeneousSeq HeterogeneousSeq ::default]
[{ltypes :types :as s}
{rtypes :types :as t}]
(last (doall (map #(subtype %1 %2) ltypes rtypes))))
-(defmethod subtype* [HeterogeneousSeq Type]
+(defmethod subtype* [HeterogeneousSeq Type ::clojure]
[s t]
(let [ss (apply Un (:types s))]
(subtype (RClass-of (Class->symbol ASeq) [ss])
t)))
-(defmethod subtype* [Mu Type]
+(defmethod subtype* [Mu Type ::default]
[s t]
(let [s* (unfold s)]
(subtype s* t)))
-(defmethod subtype* [Type Mu]
+(defmethod subtype* [Type Mu ::default]
[s t]
(let [t* (unfold t)]
(subtype s t*)))
;subtype if t includes all of s.
;tl <= sl, su <= tu
-(defmethod subtype* [CountRange CountRange]
+(defmethod subtype* [CountRange CountRange ::default]
[{supper :upper slower :lower :as s}
{tupper :upper tlower :lower :as t}]
(if (and (<= tlower slower)
View
1  src/typed/trans.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dotted pre-type expansion
View
1  src/typed/tvar_rep.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variable rep
View
1  src/typed/type_ops.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;; FIXME much better algorithms around I'm sure
View
1  src/typed/type_rep.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types
View
1  src/typed/unparse.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
(def ^:dynamic *next-nme* 0) ;stupid readable variables
View
1  src/typed/utils.clj
@@ -1,3 +1,4 @@
+(in-ns 'typed.core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utils
View
3  test/typed/test/monads.clj
@@ -324,6 +324,8 @@
(ann-monadfn m-chain (All [x]
[(Seqable [x -> (m x)]) -> (m x)]))
+;TODO
+(tc-ignore
(defmonadfn m-chain
"Chains together monadic computation steps that are each functions
of one parameter. Each step is called with the result of the previous
@@ -337,6 +339,7 @@
[[x -> (m x)] [x -> (m x)] -> [x -> (m x)]])
m-result
steps))
+ )
(ann-monadfn m-reduce
(All [x y]

0 comments on commit fb60bb5

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