├── test └── typed │ └── test │ ├── reader.clj │ ├── macro.clj │ ├── hello_world.clj │ ├── collatz.clj │ ├── interop.clj │ ├── array.clj │ ├── project.clj │ ├── cljs.clj │ ├── poly.clj │ ├── person.clj │ ├── mm.clj │ ├── atom.clj │ ├── pomegranate.clj │ ├── cps.clj │ ├── example.clj │ ├── set.clj │ ├── logic │ └── macros.clj │ ├── core_logic.clj │ ├── conduit.clj │ └── rbt.clj ├── .gitignore ├── src └── typed │ ├── ctor_override_env.clj │ ├── datatype_ancestor_env.clj │ ├── method_override_env.clj │ ├── protocol_env.clj │ ├── datatype_env.clj │ ├── declared_kind_env.clj │ ├── dvar_env.clj │ ├── internal.cljs │ ├── method_return_nilables.clj │ ├── method_param_nilables.clj │ ├── path_rep.clj │ ├── object_rep.clj │ ├── mm_env.clj │ ├── subst.clj │ ├── rclass_env.clj │ ├── constant_type.clj │ ├── name_env.clj │ ├── utils.clj │ ├── filter_rep.clj │ ├── trans.clj │ ├── subst_dots.clj │ ├── infer.clj │ ├── inst.clj │ ├── type_ops.clj │ ├── alter.clj │ ├── frees.clj │ ├── promote_demote.clj │ ├── tvar_rep.clj │ ├── unparse.clj │ └── fold.clj ├── project.clj ├── notes ├── abstraction-over-dots ├── altered_types.clj ├── sigs.clj ├── unit_tests.clj └── filter_ops.clj ├── README.md └── LICENSE /test/typed/test/reader.clj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/typed/test/macro.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.macro) 2 | 3 | (defmacro anything [& a] 4 | `(if 1 ~a 1)) 5 | -------------------------------------------------------------------------------- /test/typed/test/hello_world.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.hello-world 2 | (:require [typed.core :refer [check-ns]])) 3 | 4 | (println "Hello world") 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | target 3 | *jar 4 | /lib/ 5 | /classes/ 6 | .lein-failures 7 | .lein-deps-sum 8 | *.swp 9 | *.swo 10 | *.aux 11 | *.dvi 12 | *.pdf 13 | *.log 14 | papers 15 | *~ 16 | -------------------------------------------------------------------------------- /test/typed/test/collatz.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.collatz 2 | (:require [typed.core :refer [check-ns ann]])) 3 | 4 | (ann collatz [Number -> Number]) 5 | (defn collatz [n] 6 | (cond 7 | (= 1 n) 8 | 1 9 | (and (integer? n) 10 | (even? n)) 11 | (collatz (/ n 2)) 12 | :else 13 | (collatz (inc (* 3 n))))) 14 | -------------------------------------------------------------------------------- /src/typed/ctor_override_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Constructor Override Env 5 | 6 | (defonce CONSTRUCTOR-OVERRIDE-ENV 7 | (atom {} 8 | :validator (hash-c? symbol? Type?))) 9 | 10 | (defn add-constructor-override [sym t] 11 | (swap! CONSTRUCTOR-OVERRIDE-ENV assoc sym t) 12 | nil) 13 | 14 | 15 | -------------------------------------------------------------------------------- /test/typed/test/interop.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.interop 2 | (:import (java.io File)) 3 | (:require [typed.core :refer [ann non-nil-return check-ns]])) 4 | 5 | (ann f nil) 6 | (def f (File. "a")) 7 | 8 | (ann prt (U nil String)) 9 | (def prt (.getParent ^File f)) 10 | 11 | (non-nil-return java.io.File/getName :all) 12 | (ann nme String) 13 | (def nme (.getName ^File f)) 14 | -------------------------------------------------------------------------------- /test/typed/test/array.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.pomegranate 2 | (:import (clojure.lang DynamicClassLoader Named Seqable IPersistentVector)) 3 | (:require [typed.core :refer [ann check-ns override-method ann-protocol 4 | tc-ignore non-nil-return nilable-param]] 5 | [clojure.repl :refer [pst]])) 6 | 7 | (def my-array (into-array Object [1 2])) 8 | -------------------------------------------------------------------------------- /test/typed/test/project.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.project 2 | (:import [clojure.lang Atom]) 3 | (:require [typed.core :refer [ann check-ns]])) 4 | 5 | (ann my-atom (Atom (HMap {:a Number}) (HMap {:a Number}))) 6 | (def my-atom (atom {:a 1})) 7 | 8 | (ann my-fn (All [x a ...] [Any x a ... a -> Any])) 9 | (defn my-fn [a b & c] 10 | {:a 2}) 11 | 12 | (swap! my-atom my-fn :a 2) 13 | -------------------------------------------------------------------------------- /src/typed/datatype_ancestor_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;; DataType Ancestor Env 6 | 7 | (defonce DATATYPE-ANCESTOR-ENV (atom {})) 8 | (set-validator! DATATYPE-ANCESTOR-ENV (hash-c? (every-pred symbol? #(some #{\.} (str %))) 9 | (set-c? Type?))) 10 | 11 | (defn add-datatype-ancestors [sym tset] 12 | (swap! DATATYPE-ANCESTOR-ENV update-in [sym] #(set/union (or % #{}) tset)) 13 | nil) 14 | -------------------------------------------------------------------------------- /src/typed/method_override_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ; Should only override a method with a more specific type 4 | ; eg. 5 | 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | ;; Method Override Env 8 | 9 | (defonce METHOD-OVERRIDE-ENV (atom {})) 10 | (set-validator! METHOD-OVERRIDE-ENV (hash-c? (every-pred namespace symbol?) 11 | (some-fn Poly? FnIntersection?))) 12 | 13 | (defn add-method-override [sym t] 14 | (swap! METHOD-OVERRIDE-ENV assoc sym t) 15 | nil) 16 | -------------------------------------------------------------------------------- /test/typed/test/cljs.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.core 2 | (:refer-clojure :exclude [defrecord]) 3 | (:require [clojure.test :refer :all] 4 | [analyze.core :refer [ast]] 5 | [clojure.repl :refer [pst]] 6 | [clojure.pprint :refer [pprint]] 7 | [clojure.data :refer [diff]] 8 | [typed.core :as tc, :refer :all, :exclude [subtype? check]] 9 | [clojure.tools.trace :refer [trace-vars untrace-vars 10 | trace-ns untrace-ns]])) 11 | -------------------------------------------------------------------------------- /src/typed/protocol_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Protocol Env 5 | 6 | (defonce PROTOCOL-ENV (atom {})) 7 | (set-validator! PROTOCOL-ENV (hash-c? (every-pred symbol? namespace) Type?)) 8 | 9 | (defn add-protocol [sym t] 10 | (swap! PROTOCOL-ENV assoc sym t) 11 | nil) 12 | 13 | (defn resolve-protocol [sym] 14 | (let [p (@PROTOCOL-ENV sym)] 15 | (assert p (str "Could not resolve Protocol: " sym)) 16 | (assert (not (Poly? p)) (str "Protocol " sym " takes mandatory arguments, none provided")) 17 | p)) 18 | 19 | -------------------------------------------------------------------------------- /src/typed/datatype_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Datatype Env 5 | 6 | (defonce DATATYPE-ENV (atom {})) 7 | (set-validator! DATATYPE-ENV (hash-c? (every-pred symbol? 8 | (fn [k] (some #(= \. %) (str k)))) 9 | Type?)) 10 | 11 | (defn add-datatype [sym t] 12 | (swap! DATATYPE-ENV assoc sym t) 13 | nil) 14 | 15 | (defn resolve-datatype [sym] 16 | (let [d (@DATATYPE-ENV sym)] 17 | (assert d (str "Could not resolve DataType: " sym)) 18 | d)) 19 | -------------------------------------------------------------------------------- /src/typed/declared_kind_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Declared kind Env 5 | 6 | (defonce DECLARED-KIND-ENV (atom {})) 7 | (set-validator! DECLARED-KIND-ENV (hash-c? (every-pred symbol? namespace) TypeFn?)) 8 | 9 | (defn add-declared-kind [sym tfn] 10 | (swap! DECLARED-KIND-ENV assoc sym tfn)) 11 | 12 | (defn get-declared-kind [sym] 13 | (if-let [tfn (@DECLARED-KIND-ENV sym)] 14 | tfn 15 | (throw (Exception. (error-msg "No declared kind for Name " sym))))) 16 | 17 | (defn declare-alias-kind* [sym ty] 18 | (add-declared-kind sym ty)) 19 | -------------------------------------------------------------------------------- /test/typed/test/poly.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.poly 2 | (:require [typed.core :refer [ann AnyInteger check-ns cf]] 3 | [clojure.repl :refer [pst]]) 4 | (:import [clojure.lang Seqable])) 5 | 6 | (ann repeatedly' 7 | (All [x] 8 | (Fn [[-> x] -> (Seqable x)] 9 | [AnyInteger [-> x] -> (Seqable x)]))) 10 | (defn repeatedly' 11 | "Takes a function of no args, presumably with side effects, and 12 | returns an infinite (or length n if supplied) lazy sequence of calls 13 | to it" 14 | ([f] (lazy-seq (cons (f) (repeatedly' f)))) 15 | ([n f] (take n (repeatedly' f)))) 16 | -------------------------------------------------------------------------------- /test/typed/test/person.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.person 2 | (:require 3 | [typed.core :refer [check-ns cf ann-datatype ann 4 | ann-protocol AnyInteger defprotocol>]])) 5 | 6 | (ann-protocol Age 7 | age [Age -> AnyInteger]) 8 | (defprotocol> Age 9 | (age [this])) 10 | 11 | (ann-datatype Person 12 | [name :- String 13 | age :- AnyInteger]) 14 | (deftype Person [name age] 15 | Age 16 | (age [this] age)) 17 | 18 | (age (Person. "Lucy" 34)) 19 | 20 | (ann my-apply (All [x y] [[x -> y] x -> y])) 21 | (defn my-apply [f a] 22 | (f a)) 23 | 24 | #_(my-apply age nil) 25 | -------------------------------------------------------------------------------- /src/typed/dvar_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Dotted Variable Environment 5 | 6 | ;symbol -> F 7 | (def ^:dynamic *dotted-scope* {}) 8 | (set-validator! #'*dotted-scope* (hash-c? symbol? F?)) 9 | 10 | (defn bound-index? [n] 11 | (contains? *dotted-scope* n)) 12 | 13 | (defmacro with-dotted [dvars & body] 14 | `(with-dotted-mappings (into {} (for [v# ~dvars] 15 | [(:name v#) v#])) 16 | ~@body)) 17 | 18 | (defmacro with-dotted-mappings [dvar-map & body] 19 | `(binding [*dotted-scope* (merge *dotted-scope* ~dvar-map)] 20 | ~@body)) 21 | 22 | 23 | -------------------------------------------------------------------------------- /test/typed/test/mm.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.mm 2 | (:import (clojure.lang IPersistentMap)) 3 | (:require [typed.core :refer [def-alias ann check-ns print-env cf]] 4 | [analyze.core :refer [ast]] 5 | [clojure.repl :refer [pst]])) 6 | 7 | (def-alias Expr 8 | (U '{:op ':test1 9 | :a Number 10 | :b Number} 11 | '{:op ':test2})) 12 | 13 | (ann MapToString [Expr -> String]) 14 | 15 | ; Expected type for :op 16 | ; -> (All [x] [Any -> x :object {:id 0 :path [(Key :op)]} 17 | ; Dispatch 18 | (defmulti MapToString :op) 19 | 20 | ;(isa? (:op 0th) :test1) 21 | (defmethod MapToString :test1 22 | [a] 23 | (print-env "mm") 24 | ) 25 | -------------------------------------------------------------------------------- /src/typed/internal.cljs: -------------------------------------------------------------------------------- 1 | (ns typed.internal) 2 | 3 | (defn ann-form-cljs* [form typ] 4 | form) 5 | 6 | (defn print-env 7 | "Print the current type environment, and debug-string" 8 | [debug-string] nil) 9 | 10 | (defn print-filterset 11 | "Print the filter set attached to form, and debug-string" 12 | [debug-string frm] 13 | frm) 14 | 15 | (defn inst-poly 16 | [inst-of types-syn] 17 | inst-of) 18 | 19 | (defn inst-poly-ctor [inst-of types-syn] 20 | inst-of) 21 | 22 | (defn fn>-ann [fn-of param-types-syn] 23 | fn-of) 24 | 25 | (defn pfn>-ann [fn-of polys param-types-syn] 26 | fn-of) 27 | 28 | (defn loop>-ann [loop-of bnding-types] 29 | loop-of) 30 | 31 | -------------------------------------------------------------------------------- /src/typed/method_return_nilables.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Method Return non-nilables 5 | 6 | (defonce METHOD-RETURN-NONNILABLE-ENV (atom {})) 7 | (set-validator! METHOD-RETURN-NONNILABLE-ENV (hash-c? (every-pred namespace symbol?) 8 | (some-fn #(= :all %) 9 | (set-c? nat?)))) 10 | 11 | (defn add-nonnilable-method-return [sym m] 12 | (swap! METHOD-RETURN-NONNILABLE-ENV assoc sym m) 13 | nil) 14 | 15 | (defn nonnilable-return? [sym arity] 16 | (let [as (@METHOD-RETURN-NONNILABLE-ENV sym)] 17 | (boolean (or (= :all as) 18 | (when as 19 | (as arity)))))) 20 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject typed "0.1.7-SNAPSHOT" 2 | :description "Gradual typing for Clojure" 3 | :dependencies [[analyze "0.2.7-SNAPSHOT"] 4 | [net.intensivesystems/arrows "1.3.0" 5 | :exclusions [org.clojure/clojure]] ;for testing conduit, lein test wants it here? 6 | [trammel "0.7.0" 7 | :exclusions [org.clojure/clojure]] 8 | [org.clojure/math.combinatorics "0.0.2" 9 | :exclusions [org.clojure/clojure]] 10 | [org.clojure/clojurescript "0.0-1450"] 11 | [org.clojure/tools.trace "0.7.3" 12 | :exclusions [org.clojure/clojure]] 13 | [org.clojure/clojure "1.5.0-RC1"] 14 | ] 15 | :dev-dependencies [[org.clojure/tools.macro "0.1.0"] ;for algo.monads 16 | ]) 17 | -------------------------------------------------------------------------------- /src/typed/method_param_nilables.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Method Param nilables 5 | 6 | (defonce METHOD-PARAM-NILABLE-ENV (atom {})) 7 | (set-validator! METHOD-PARAM-NILABLE-ENV (hash-c? (every-pred namespace symbol?) 8 | (hash-c? (some-fn #(= :all %) nat?) 9 | (some-fn #(= :all %) (set-c? nat?))))) 10 | 11 | (defn add-method-nilable-param [sym a] 12 | (swap! METHOD-PARAM-NILABLE-ENV assoc sym a) 13 | nil) 14 | 15 | (defn nilable-param? [sym arity param] 16 | (boolean 17 | (when-let [nilables (@METHOD-PARAM-NILABLE-ENV sym)] 18 | (when-let [params (or (nilables :all) 19 | (nilables arity))] 20 | (or (= :all params) 21 | (params param)))))) 22 | 23 | -------------------------------------------------------------------------------- /src/typed/path_rep.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Paths 5 | 6 | (def PathElem ::path-elem) 7 | 8 | (defn PathElem? [a] 9 | (isa? (class a) PathElem)) 10 | 11 | (defn declare-path-elem [c] 12 | (derive c PathElem)) 13 | 14 | (defrecord FirstPE [] 15 | "A path calling clojure.core/first" 16 | []) 17 | (defrecord NextPE [] 18 | "A path calling clojure.core/next" 19 | []) 20 | 21 | (defrecord ClassPE [] 22 | "A path calling clojure.core/class" 23 | []) 24 | 25 | (defrecord CountPE [] 26 | "A path calling clojure.core/count" 27 | []) 28 | 29 | (defrecord KeyPE [val] 30 | "A key in a hash-map" 31 | [(keyword? val)]) 32 | 33 | (def -kpe ->KeyPE) 34 | 35 | (declare-path-elem FirstPE) 36 | (declare-path-elem NextPE) 37 | (declare-path-elem ClassPE) 38 | (declare-path-elem CountPE) 39 | (declare-path-elem KeyPE) 40 | 41 | -------------------------------------------------------------------------------- /src/typed/object_rep.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Runtime Objects 5 | 6 | (def RObject ::r-object) 7 | 8 | (defn RObject? [a] 9 | (isa? (class a) RObject)) 10 | 11 | (defn declare-robject [c] 12 | (derive c RObject)) 13 | 14 | (defrecord EmptyObject [] 15 | "?" 16 | []) 17 | 18 | (def -empty (->EmptyObject)) 19 | 20 | (defrecord Path [path id] 21 | "A path to a variable. Paths grow to the right, with leftmost 22 | pathelem being applied first (think of -> threading operator)." 23 | [(or (and (seq path) 24 | (sequential? path)) 25 | (nil? path)) 26 | (every? PathElem? path) 27 | (name-ref? id)]) 28 | 29 | (defrecord NoObject [] 30 | "Represents no info about the object of this expression 31 | should only be used for parsing type annotations and expected types" 32 | []) 33 | 34 | ;Objects 35 | 36 | (declare unparse-path-elem) 37 | 38 | (declare-robject EmptyObject) 39 | (declare-robject Path) 40 | (declare-robject NoObject) 41 | -------------------------------------------------------------------------------- /test/typed/test/atom.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.atom 2 | (:require [typed.core :refer [ann ann-form check-ns cf Atom1 fn> def-alias]] 3 | [clojure.repl :refer [pst]]) 4 | (:import (clojure.lang IPersistentMap Symbol))) 5 | 6 | (ann my-atom (Atom1 Number)) 7 | (def my-atom (atom 2)) 8 | 9 | (reset! my-atom 1) 10 | (swap! my-atom (fn> [[x :- Number]] (+ x 2 3))) 11 | 12 | (def-alias InnerEntry (HMap {:c 13 | (HMap {:d 14 | String})})) 15 | (def-alias Entry (HMap {:a 16 | (HMap {:b 17 | (IPersistentMap Symbol 18 | (Atom1 InnerEntry))})})) 19 | 20 | (ann complicated (Atom1 Entry)) 21 | (def complicated (atom {:a {:b {}}})) 22 | 23 | ;(swap! complicated update-in [:a :b 'a] #(swap! (or % (atom {})) assoc-in [:c :d] "b")) 24 | 25 | (swap! complicated (ann-form 26 | (fn [c] 27 | (-> c 28 | (update-in [:a :b 'a] 29 | (fn [a] (swap! (or a (atom {})) 30 | (fn [i] 31 | (-> i (assoc-in [:c :d] "b")))))))) 32 | [Entry -> Entry])) 33 | -------------------------------------------------------------------------------- /src/typed/mm_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;; Environment for storing multimethod types and inferred filters 4 | 5 | ; (Atom (Seqable (IPersistentMap Symbol '{:fn-type Type, :dispatch-result (U nil Type)}))) 6 | (defonce MULTIMETHOD-DISPATCH-ENV (atom {} 7 | :validator (hash-c? 8 | (every-pred symbol? namespace) 9 | Type?))) 10 | 11 | ; [Symbol Filter -> nil] 12 | (defn add-multimethod-dispatch-type 13 | "Add the type of the dispatch function of the multimethod named by mmsym 14 | to the environment. If already exists, must be identical." 15 | [mmsym dtype] 16 | {:pre [(symbol? mmsym) 17 | (Type? dtype)]} 18 | (when-let [old (@MULTIMETHOD-DISPATCH-ENV mmsym)] 19 | (assert (= old dtype) 20 | (str "Cannot assign multimethod a different dispatch result: " 21 | " Old: " (unparse-type old) 22 | " New: " (unparse-type dtype)))) 23 | (swap! MULTIMETHOD-DISPATCH-ENV assoc mmsym dtype) 24 | nil) 25 | 26 | (defn get-multimethod-dispatch-type [mmsym] 27 | {:pre [(symbol? mmsym)] 28 | :post [(Type? %)]} 29 | (let [t (@MULTIMETHOD-DISPATCH-ENV mmsym)] 30 | (assert t (str "Multimethod requires dispatch type: " mmsym)) 31 | t)) 32 | -------------------------------------------------------------------------------- /test/typed/test/pomegranate.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.pomegranate 2 | (:import (clojure.lang DynamicClassLoader Named Seqable IPersistentVector) 3 | (java.net URL URLClassLoader)) 4 | 5 | (:require #_[clojure.java.io :as io] 6 | #_[cemerick.pomegranate.aether :as aether] 7 | [typed.core :refer [ann check-ns non-nil-return nilable-param into-array>]] 8 | [clojure.repl :refer [pst]]) 9 | (:refer-clojure :exclude (add-classpath))) 10 | 11 | (non-nil-return java.lang.Class/getDeclaredMethod :all) 12 | (nilable-param java.lang.reflect.Method/invoke {2 #{0}}) 13 | 14 | (ann call-method [Class Named (IPersistentVector Class) (U nil Object) (U nil Object) * -> (U nil Object)]) 15 | 16 | ;; call-method pulled from clojure.contrib.reflect, (c) 2010 Stuart Halloway & Contributors 17 | (defn call-method 18 | "Calls a private or protected method. 19 | 20 | params is a vector of classes which correspond to the arguments to 21 | the method e 22 | 23 | obj is nil for static methods, the instance object otherwise. 24 | 25 | The method-name is given a symbol or a keyword (something Named)." 26 | [^Class klass method-name params obj & args] 27 | (let [method (doto (.getDeclaredMethod klass 28 | (name method-name) 29 | (into-array> Class params)) 30 | (.setAccessible true))] 31 | (.invoke method obj (into-array> (U nil Object) args)))) 32 | -------------------------------------------------------------------------------- /src/typed/subst.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Variable substitution 5 | 6 | (declare subtype) 7 | 8 | (derive ::substitute fold-rhs-default) 9 | 10 | (add-fold-case ::substitute 11 | F 12 | (fn [{name* :name :as f} {{:keys [name image]} :locals}] 13 | (if (= name* name) 14 | image 15 | f))) 16 | 17 | (defn substitute [image name target] 18 | {:pre [(AnyType? image) 19 | (symbol? name) 20 | (AnyType? target)] 21 | :post [(AnyType? %)]} 22 | (fold-rhs ::substitute 23 | {:locals {:name name 24 | :image image}} 25 | target)) 26 | 27 | (defn substitute-many [target images names] 28 | (reduce (fn [t [im nme]] (substitute im nme t)) 29 | target 30 | (map vector images names))) 31 | 32 | (defn subst-all [s t] 33 | {:pre [(substitution-c? s) 34 | (AnyType? t)] 35 | :post [(AnyType? %)]} 36 | (reduce (fn [t [v r]] 37 | (cond 38 | (t-subst? r) (substitute (:type r) v t) 39 | (i-subst? r) (substitute-dots (:types r) nil v t) 40 | (i-subst-starred? r) (substitute-dots (:types r) (:starred r) v t) 41 | (and (i-subst-dotted? r) 42 | (empty? (:types r))) (substitute-dotted (:dty r) (:name (:dbound r)) v t) 43 | (i-subst-dotted? r) (throw (Exception. "i-subst-dotted nyi")) 44 | :else (throw (Exception. "Other substitutions NYI")))) 45 | t s)) 46 | -------------------------------------------------------------------------------- /src/typed/rclass_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Restricted Class 5 | 6 | ;Class -> RClass 7 | (defonce RESTRICTED-CLASS (atom {})) 8 | (set-validator! RESTRICTED-CLASS (hash-c? symbol? Type?)) 9 | 10 | (declare with-frees) 11 | 12 | (defn- build-replacement-syntax [m] 13 | `(into {} (for [[k# v#] '~m] 14 | [(if-let [c# (resolve k#)] 15 | (and (class? c#) (Class->symbol c#)) 16 | k#) 17 | (parse-type v#)]))) 18 | 19 | (defn parse-RClass-binder [bnds] 20 | (for [[nme & {:keys [variance]}] bnds] 21 | [variance (make-F nme)])) 22 | 23 | (defn alter-class* [csym type] 24 | (swap! RESTRICTED-CLASS assoc csym type)) 25 | 26 | (defmacro alter-class [the-class frees-syn & opts] 27 | (let [{replacements-syn :replace} (apply hash-map opts)] 28 | `(let [[variances# frees#] (when-let [fs# (seq '~frees-syn)] 29 | (let [b# (parse-RClass-binder fs#)] 30 | [(map first b#) (map second b#)])) 31 | csym# (let [cls# (when-let [c# (resolve '~the-class)] 32 | (when (class? c#) 33 | c#))] 34 | (or (and cls# (Class->symbol cls#)) 35 | '~the-class))] 36 | (alter-class* csym# (RClass* (map :name frees#) variances# frees# csym# 37 | (with-frees frees# 38 | ~(build-replacement-syntax replacements-syn)))) 39 | ~the-class))) 40 | -------------------------------------------------------------------------------- /src/typed/constant_type.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;[Any -> Type] 4 | (defmulti constant-type class) 5 | 6 | (defmethod constant-type nil [_] -nil) 7 | (defmethod constant-type Class [v] (-val v)) 8 | (defmethod constant-type Symbol [v] (-val v)) 9 | (defmethod constant-type Long [v] (-val v)) 10 | (defmethod constant-type Double [v] (-val v)) 11 | (defmethod constant-type Integer [v] (-val v)) 12 | (defmethod constant-type java.math.BigDecimal [v] (-val v)) 13 | (defmethod constant-type clojure.lang.BigInt [v] (-val v)) 14 | (defmethod constant-type String [v] (-val v)) 15 | (defmethod constant-type Character [v] (-val v)) 16 | (defmethod constant-type clojure.lang.Keyword [v] (-val v)) 17 | (defmethod constant-type java.util.regex.Pattern [v] (RClass-of java.util.regex.Pattern)) 18 | 19 | (defmethod constant-type Boolean [v] (if v -true -false)) 20 | (defmethod constant-type PersistentHashSet [v] (RClass-of PersistentHashSet [(apply Un (map constant-type v))])) 21 | 22 | ;nothing specific, Cons seems like an implementation detail 23 | (defmethod constant-type Cons [v] (RClass-of Seqable [(apply Un (map constant-type v))])) 24 | 25 | (defmethod constant-type IPersistentList 26 | [clist] 27 | (->HeterogeneousList (apply list (map constant-type clist)))) 28 | 29 | (defmethod constant-type IPersistentVector 30 | [cvec] 31 | (-hvec (mapv constant-type cvec))) 32 | 33 | (defmethod constant-type IPersistentMap 34 | [cmap] 35 | (let [kts (map constant-type (keys cmap)) 36 | vts (map constant-type (vals cmap))] 37 | (if (every? Value? kts) 38 | (-hmap (zipmap kts vts)) 39 | (RClass-of IPersistentMap 40 | [(apply Un kts) 41 | (apply Un vts)])))) 42 | 43 | -------------------------------------------------------------------------------- /test/typed/test/cps.clj: -------------------------------------------------------------------------------- 1 | ;https://gist.github.com/3191865 2 | ; 3 | ;(defn cpf [f priority] 4 | ; (fn [k & args] 5 | ; (js/setTimeout #(k (apply f args)) priority))) 6 | ; 7 | ;(def sqrt #(Math/sqrt %)) 8 | ; 9 | ;(defn pyth 10 | ; "Calculate the hypotenuse of a right triangle." 11 | ; [x y] 12 | ; (sqrt (+ (* x x) (* y y)))) 13 | ; 14 | ;(defn pyth& 15 | ; "Calculate the hypotenuse of a right triangle: continuation passing style (CPS) version. 16 | ; 17 | ; Represents a green thread. k is the function to invoke with the 18 | ; final result; priority is the number of milliseconds to wait between 19 | ; continuation invocations. 20 | ; 21 | ; One can imagine a macro for converting pyth to pyth&. 22 | ; 23 | ; One can also imagine a mechanism, involving the cpf function above, 24 | ; for maintaining outstanding green threads and their associated 25 | ; timeouts and continuations. One might use .clearInterval to pause a 26 | ; thread, restarting it by invoking the last reified continuation in 27 | ; that thread. 28 | ; 29 | ; One may also involve a scheduler that prioritizes or deprioritizes 30 | ; outstanding threads by some heuristic. 31 | ; 32 | ; This system could allow us to use futures, promises, and blocking 33 | ; derefs on green threads without blocking the entire browser in 34 | ; ClojureScript programs." 35 | ; [x y k priority] 36 | ; ((cpf * priority) 37 | ; (fn [x2] 38 | ; ((cpf * priority) 39 | ; (fn [y2] 40 | ; ((cpf + priority) 41 | ; (fn [x2py2] 42 | ; ((cpf sqrt priority) k x2py2)) x2 y2)) y y)) x x)) 43 | ; 44 | ;(do 45 | ; (pyth& 1 2 #(.log js/console (str "thread 0: " %)) 500) 46 | ; (pyth& 1 2 #(.log js/console (str "thread 1: " %)) 100) 47 | ; (pyth& 1 2 #(.log js/console (str "thread 2: " %)) 0) 48 | ; ;; thread 2: 2.23606797749979 49 | ; ;; thread 1: 2.23606797749979 50 | ; ;; thread 0: 2.23606797749979 51 | ; ) 52 | -------------------------------------------------------------------------------- /src/typed/name_env.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Type Name Env 5 | 6 | (def declared-name-type ::declared-name) 7 | (def protocol-name-type ::protocol-name) 8 | (def datatype-name-type ::datatype-name) 9 | 10 | (def temp-binding ::temp-binding) 11 | 12 | (doseq [k [declared-name-type protocol-name-type datatype-name-type]] 13 | (derive k temp-binding)) 14 | 15 | (defonce TYPE-NAME-ENV (atom {})) 16 | (set-validator! TYPE-NAME-ENV #(and (every? (every-pred (some-fn namespace 17 | (fn [k] (some (fn [a] (= \. a)) (str k)))) 18 | symbol?) 19 | (keys %)) 20 | (every? (some-fn Type? (fn [a] (isa? a temp-binding))) 21 | (vals %)))) 22 | 23 | (defn add-type-name [sym ty] 24 | (swap! TYPE-NAME-ENV assoc sym (if (Type? ty) 25 | (vary-meta ty assoc :from-name sym) 26 | ty)) 27 | nil) 28 | 29 | (defn declare-name* [sym] 30 | {:pre [(symbol? sym) 31 | (namespace sym)]} 32 | (add-type-name sym declared-name-type) 33 | nil) 34 | 35 | (defn declare-protocol* [sym] 36 | {:pre [(symbol? sym) 37 | (some #(= \. %) (str sym))]} 38 | (add-type-name sym protocol-name-type) 39 | nil) 40 | 41 | (defn declare-datatype* [sym] 42 | (add-type-name sym datatype-name-type) 43 | nil) 44 | 45 | (defn- resolve-name* [sym] 46 | (let [t (@TYPE-NAME-ENV sym)] 47 | (cond 48 | (= protocol-name-type t) (resolve-protocol sym) 49 | (= datatype-name-type t) (resolve-datatype sym) 50 | (= declared-name-type t) (throw (IllegalArgumentException. (str "Reference to declared but undefined name " sym))) 51 | (Type? t) (vary-meta t assoc :source-Name sym) 52 | :else (throw (IllegalArgumentException. (error-msg "Cannot resolve name " sym)))))) 53 | -------------------------------------------------------------------------------- /src/typed/utils.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Utils 5 | 6 | (defmacro defrecord [name slots inv-description invariants & etc] 7 | ;only define record if symbol doesn't resolve, not completely sure if this behaves like defonce 8 | (when-not (resolve name) 9 | `(contracts/defconstrainedrecord ~name ~slots ~inv-description ~invariants ~@etc))) 10 | 11 | (def third (comp second next)) 12 | 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | ;; Constraint shorthands 15 | 16 | (def boolean? (some-fn true? false?)) 17 | 18 | (defn =-c? [& as] 19 | #(apply = (concat as %&))) 20 | 21 | (defn every-c? [c] 22 | #(every? c %)) 23 | 24 | (defn hvector-c? [& ps] 25 | (apply every-pred vector? 26 | (map (fn [p i] #(p (nth % i false))) ps (range)))) 27 | 28 | (defn array-map-c? [ks-c? vs-c?] 29 | (every-pred #(instance? PersistentArrayMap %) 30 | #(every? ks-c? (keys %)) 31 | #(every? vs-c? (vals %)))) 32 | 33 | (defn hmap-c? [& key-vals] 34 | (every-pred map? 35 | #(every? identity 36 | (for [[k vc] (partition 2 key-vals)] 37 | (and (contains? % k) 38 | (vc (get % k))))))) 39 | 40 | (defn hash-c? [ks-c? vs-c?] 41 | (every-pred map? 42 | #(every? ks-c? (keys %)) 43 | #(every? vs-c? (vals %)))) 44 | 45 | (defn set-c? [c?] 46 | (every-pred set? 47 | #(every? c? %))) 48 | 49 | (defn sequential-c? [c?] 50 | (every-pred sequential? 51 | (every-c? c?))) 52 | 53 | ;(defn- comp-mm [mm disps] 54 | ; (set/difference disps (set (keys (methods mm))))) 55 | ; 56 | ;(comp-mm replace-image (disj kinds :scope)) 57 | ;(comp-mm replace-image (disj kinds :scope)) 58 | 59 | (declare ^:dynamic *current-env*) 60 | 61 | ;[Any * -> String] 62 | (defn ^String 63 | error-msg 64 | [& msg] 65 | (apply str (when *current-env* 66 | (str (:line *current-env*) ": ")) 67 | (concat msg))) 68 | 69 | -------------------------------------------------------------------------------- /src/typed/filter_rep.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Filters 5 | 6 | (def name-ref? (some-fn symbol? integer?)) 7 | 8 | (def Filter ::filter) 9 | 10 | (defn Filter? [a] 11 | (isa? (class a) Filter)) 12 | 13 | (defn declare-filter [c] 14 | (derive c Filter)) 15 | 16 | (defrecord BotFilter [] 17 | "?" 18 | []) 19 | (defrecord TopFilter [] 20 | "?" 21 | []) 22 | 23 | (def -top (->TopFilter)) 24 | (def -bot (->BotFilter)) 25 | 26 | (defrecord NoFilter [] 27 | "Represents no info about filters, used for parsing types" 28 | []) 29 | 30 | (declare PathElem?) 31 | 32 | (defrecord TypeFilter [type path id] 33 | "A filter claiming looking up id, down the given path, is of given type" 34 | [(Type? type) 35 | (every? PathElem? path) 36 | (name-ref? id)]) 37 | 38 | (defrecord NotTypeFilter [type path id] 39 | "A filter claiming looking up id, down the given path, is NOT of given type" 40 | [(Type? type) 41 | (every? PathElem? path) 42 | (name-ref? id)]) 43 | 44 | (defrecord AndFilter [fs] 45 | "Logical conjunction of filters" 46 | [(set? fs) 47 | (seq fs) 48 | (every? Filter? fs)]) 49 | 50 | (defrecord OrFilter [fs] 51 | "Logical disjunction of filters" 52 | [(seq fs) 53 | (set? fs) 54 | (every? Filter? fs)]) 55 | 56 | (defrecord ImpFilter [a c] 57 | "Antecedent (filter a) implies consequent (filter c)" 58 | [(Filter? a) 59 | (Filter? c)]) 60 | 61 | (defrecord FilterSet [then else] 62 | "A filter claiming looking up id, down the given path, is NOT of given type" 63 | [(and (or (BotFilter? then) 64 | (and (BotFilter? else) 65 | (TopFilter? then)) 66 | (Filter? then)) 67 | (or (BotFilter? else) 68 | (and (BotFilter? then) 69 | (TopFilter? else)) 70 | (Filter? else)))]) 71 | 72 | (declare-filter BotFilter) 73 | (declare-filter TopFilter) 74 | (declare-filter NoFilter) 75 | (declare-filter AndFilter) 76 | (declare-filter OrFilter) 77 | (declare-filter TypeFilter) 78 | (declare-filter NotTypeFilter) 79 | (declare-filter ImpFilter) 80 | (declare-filter FilterSet) 81 | -------------------------------------------------------------------------------- /notes/abstraction-over-dots: -------------------------------------------------------------------------------- 1 | (assoc {} :a 2 :b 3) 2 | 3 | (reduce assoc1 [a b]) 4 | 5 | ...2 <: ...1 6 | 7 | ;swap 8 | (All [w r] 9 | [(Atom w r) [r b ... b -> w] b ... b -> w]) 10 | 11 | ;assoc 12 | (All [t c d a ...] 13 | [t c d a ... a -> (Project 14 | (fn [t c d as] 15 | (assert (even? (count as)) 16 | "assoc accepts even number of arguments") 17 | (let [as (apply array-map as) 18 | assoc1 (parse-type )] 19 | (reduce (fn [t [k v]] 20 | )))) 21 | [t c d a ... a]) 22 | 23 | ;dissoc 24 | [t b ...1 b -> (FReduceDots1 dissoc1 25 | t 26 | b)] 27 | 28 | ;get-in 29 | [t (HSeqable b ...1 b) -> (FReduceDots1 clojure.core/get 30 | t 31 | identity 32 | b ...1 b)] 33 | 34 | ;comp 35 | 36 | ;[[Integer -> Double] 37 | ; [String -> Integer] 38 | ; [Float -> String] 39 | ; [Double Double -> Float] 40 | ; -> [Double Double -> Double]] 41 | 42 | [b ...1 b -> (Project 43 | (fn [bs] 44 | (let [[single-args multi-arg] [(butlast bs) (last bs)] 45 | chk-single-arg (parse-type '(All [x y z] 46 | [[x -> y] [z -> x] -> [z -> y]])) 47 | chk-multi-arg (parse-type '(All [x y z] 48 | [[x -> y] [z ...* -> x] -> [z ...* -> y]])) 49 | but-multi (reduce (fn [l r] 50 | (check-funapp (ret chk-single-arg) 51 | (ret l) 52 | (ret r) 53 | nil)) 54 | (parse-type '(All [x] [x -> x])) 55 | single-args) 56 | multi (check-funapp (ret chk-multi-arg) 57 | (ret but-multi) 58 | (ret multi-arg) 59 | nil)] 60 | (ret-t multi))) 61 | [b ...1 b])] 62 | 63 | (swap! a assoc :a 1) 64 | 65 | (All [w r b ...*] 66 | [(Atom w r) [r b ...* -> w] b ...* -> nil]) 67 | 68 | 69 | 70 | ...2 <: ...* 71 | ...1 <: ...* 72 | * <: ...* 73 | * <: ...1 74 | * <: ...2 75 | 76 | 77 | Higher-order Variable-arity Polymorphism 78 | 79 | 80 | -------------------------------------------------------------------------------- /test/typed/test/example.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.example 2 | (:refer-clojure :exclude [< not=]) 3 | (:import (clojure.lang Seqable PersistentHashSet Symbol) 4 | (java.io File)) 5 | (:require [typed.core :refer [ann inst cf fn> pfn> check-ns ann-form]] 6 | [clojure.repl :refer [pst]] 7 | [analyze.core :refer [ast]])) 8 | 9 | (ann test1 (All [x y] [x y -> x])) 10 | (defn test1 [a b] 11 | a) 12 | 13 | (test1 1 2) 14 | 15 | (ann test2 (All [y] 16 | [(Seqable y) -> (Seqable Number)])) 17 | ;(defn test2 [a] 18 | ; (map + [1 2])) 19 | 20 | (ann use-map [(HMap {:a Number}) -> Number]) 21 | (defn use-map [a] 22 | (get a :a)) 23 | 24 | (use-map {:a 1}) 25 | 26 | ;(ann rest-arg1 [Number * -> Number]) 27 | ;(defn rest-arg1 [& ns] 28 | ; (+ (first ns))) 29 | 30 | ;#lang typed-scheme 31 | ;(: collatz (Number → Number)) (define (collatz n) 32 | ; (cond 33 | ; [(= 1 n) 1] [(even? n) 34 | ; (collatz (/ n 2))] 35 | ; [else (collatz (add1 (∗ 3 n)))])) 36 | ;(collatz 17) 37 | 38 | (comment 39 | (ns typed.test.collatz 40 | (:require [typed.core :refer [ann]])) 41 | 42 | (ann collatz [Number -> Number]) 43 | (defn collatz [n] 44 | (cond 45 | (= 1 n) 1 46 | (even? n) (collatz (/ n 2)) 47 | :else (collatz (inc (* 3 n))))) 48 | ) 49 | 50 | (ann to-set (All [x] 51 | [(U nil (Seqable x)) -> (PersistentHashSet x)])) 52 | (defn to-set [a] 53 | (set a)) 54 | 55 | (ann config 56 | (HMap {:file String 57 | :ns Symbol})) 58 | (def config 59 | {:file "clojure/core.clj" 60 | :ns 'clojure.core}) 61 | 62 | (comment 63 | (ann add-or-zero [(U nil Number) * -> Number]) 64 | (defn add-or-zero [& nzs] 65 | (reduce (fn> [[acc :- Number] 66 | [n :- (U nil Number)]] 67 | (+ acc (if n 68 | n 69 | 0))) 70 | 0 nzs)) 71 | 72 | (add-or-zero 1 2 3 nil) 73 | ) 74 | 75 | (ann num-vec2 [(U nil Number) (U nil Number) -> (Vector* Number Number)]) 76 | (defn num-vec2 [a b] 77 | [(if a a 0) (if b b 0)]) 78 | 79 | (ann < (Fn [Number -> boolean] 80 | [Number Number -> boolean] 81 | [Number Number Number * -> boolean])) 82 | #_(defn < 83 | "Returns non-nil if nums are in monotonically increasing order, 84 | otherwise false." 85 | ([x] true) 86 | ([x y] (. clojure.lang.Numbers (lt x y))) 87 | ([x y & more] 88 | (if (< x y) 89 | (if (next more) 90 | (recur y (first more) (next more)) 91 | (< y (first more))) 92 | false))) 93 | 94 | (ann not= (Fn [Any -> boolean] 95 | [Any Any -> boolean] 96 | [Any Any Any * -> boolean])) 97 | (defn not= 98 | ([x] false) 99 | ([x y] (not (= x y))) 100 | ([x y & more] 101 | (not (apply = x y more)))) 102 | -------------------------------------------------------------------------------- /src/typed/trans.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Dotted pre-type expansion 5 | 6 | ;tdr from Practical Variable-Arity Polymorphism paper 7 | ; Expand out dotted pretypes to fixed domain, using types bm, if (:name bound) = b 8 | (defmulti trans-dots (fn [t b bm] 9 | {:pre [(AnyType? t) 10 | (symbol? b) 11 | (every? Type? bm)]} 12 | (class t))) 13 | 14 | (defmethod trans-dots Name [t b bm] t) 15 | (defmethod trans-dots F [t b bm] t) 16 | (defmethod trans-dots Value [t b bm] t) 17 | (defmethod trans-dots RClass [t b bm] t) 18 | 19 | (defmethod trans-dots TApp 20 | [^TApp t b bm] 21 | (let [tfn #(trans-dots % b bm)] 22 | (->TApp (tfn (.rator t)) (mapv tfn (.rands t))))) 23 | 24 | (defmethod trans-dots Union 25 | [t b bm] 26 | (let [tfn #(trans-dots % b bm)] 27 | (apply Un (doall (map tfn (:types t)))))) 28 | 29 | (defmethod trans-dots FnIntersection 30 | [t b bm] 31 | (let [tfn #(trans-dots % b bm)] 32 | (->FnIntersection (doall (map tfn (:types t)))))) 33 | 34 | (defmethod trans-dots Intersection 35 | [t b bm] 36 | (let [tfn #(trans-dots % b bm)] 37 | (apply In (doall (map tfn (:types t)))))) 38 | 39 | (defmethod trans-dots Function 40 | [t b bm] 41 | ;TODO how to handle filters? 42 | ; (assert (NoFilter? (-> t :rng :fl))) 43 | ; (assert (NoObject? (-> t :rng :o))) 44 | (let [tfn #(trans-dots % b bm)] 45 | (cond 46 | (:drest t) 47 | (let [{:keys [pre-type name]} (:drest t)] 48 | (assert (symbol? name)) 49 | (if (= b name) ;identical bounds 50 | (let [dom (concat 51 | ;keep fixed domain 52 | (doall (map tfn (:dom t))) 53 | ;expand dotted type to fixed domain 54 | (doall (map (fn [bk] 55 | {:post [(Type? %)]} 56 | ;replace free occurences of bound with bk 57 | (-> (substitute bk b pre-type) 58 | tfn)) 59 | bm)))] 60 | (->Function dom 61 | (update-in (:rng t) [:t] tfn) 62 | nil 63 | nil ;dotted pretype now expanded to fixed domain 64 | nil)) 65 | (-> t 66 | (update-in [:dom] #(doall (map tfn %))) 67 | (update-in [:rng :t] tfn) 68 | (update-in [:drest] (fn [drest] 69 | (when drest 70 | (-> drest 71 | (update-in [:pre-type] tfn)))))))) ;translate pre-type 72 | :else 73 | (-> t 74 | (update-in [:dom] #(doall (map tfn %))) 75 | (update-in [:rng] tfn) 76 | (update-in [:rest] #(when % 77 | (tfn %))))))) 78 | 79 | -------------------------------------------------------------------------------- /src/typed/subst_dots.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | 4 | 5 | (declare sub-f sub-o sub-pe) 6 | 7 | (derive ::substitute-dots fold-rhs-default) 8 | 9 | (add-fold-case ::substitute-dots 10 | Function 11 | (fn [{:keys [dom rng rest drest kws] :as ftype} {{:keys [name sb images rimage]} :locals}] 12 | (assert (not kws) "TODO substitute keyword args") 13 | (if (and drest 14 | (= name (:name drest))) 15 | (->Function (concat (map sb dom) 16 | ;; We need to recur first, just to expand out any dotted usages of this. 17 | (let [expanded (sb (:pre-type drest))] 18 | ;(prn "expanded" (unparse-type expanded)) 19 | (map (fn [img] (substitute img name expanded)) images))) 20 | (sb rng) 21 | rimage nil nil) 22 | (->Function (map sb dom) 23 | (sb rng) 24 | (and rest (sb rest)) 25 | (and drest (->DottedPretype (sb (:pre-type drest)) 26 | (:name drest))) 27 | nil)))) 28 | 29 | ;; implements angle bracket substitution from the formalism 30 | ;; substitute-dots : Listof[Type] Option[type] Name Type -> Type 31 | (defn substitute-dots [images rimage name target] 32 | {:pre [(every? AnyType? images) 33 | ((some-fn nil? AnyType?) rimage) 34 | (symbol? name) 35 | (AnyType? target)]} 36 | ;(prn "substitute-dots" (unparse-type target) name "->" (map unparse-type images)) 37 | (letfn [(sb [t] (substitute-dots images rimage name t))] 38 | (if (or ((fi target) name) 39 | ((fv target) name)) 40 | (fold-rhs ::substitute-dots 41 | {:type-rec sb 42 | :filter-rec (sub-f sb ::substitute-dots) 43 | :locals {:name name 44 | :sb sb 45 | :images images 46 | :rimage rimage}} 47 | target) 48 | target))) 49 | 50 | (derive ::substitute-dotted fold-rhs-default) 51 | 52 | (add-fold-case ::substitute-dotted 53 | F 54 | (fn [{name* :name :as t} {{:keys [name image]} :locals}] 55 | (if (= name* name) 56 | image 57 | t))) 58 | 59 | (add-fold-case ::substitute-dotted 60 | Function 61 | (fn [{:keys [dom rng rest drest kws]} {{:keys [sb name image]} :locals}] 62 | (assert (not kws)) 63 | (->Function (map sb dom) 64 | (sb rng) 65 | (and rest (sb rest)) 66 | (and drest 67 | (->DottedPretype (substitute image (:name drest) (sb (:pretype drest))) 68 | (if (= name (:name drest)) 69 | name 70 | (:name drest)))) 71 | nil))) 72 | 73 | ;; implements curly brace substitution from the formalism 74 | ;; substitute-dotted : Type Name Name Type -> Type 75 | (defn substitute-dotted [image image-bound name target] 76 | {:pre [(AnyType? image) 77 | (symbol? image-bound) 78 | (symbol? name) 79 | (AnyType? target)] 80 | :post [(AnyType? %)]} 81 | (letfn [(sb [t] (substitute-dotted image image-bound name t))] 82 | (if ((fi target) name) 83 | (fold-rhs ::substitute-dotted 84 | {:type-rec sb 85 | :filter-rec (sub-f sb ::substitute-dotted) 86 | :locals {:name name 87 | :sb sb 88 | :image image}} 89 | target 90 | target)))) 91 | -------------------------------------------------------------------------------- /src/typed/infer.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | 4 | ;; like infer, but dotted-var is the bound on the ... 5 | ;; and T-dotted is the repeated type 6 | (defn infer-dots [X dotted-var dotted-bnd S T T-dotted R must-vars & {:keys [expected]}] 7 | {:pre [((hash-c? symbol? Bounds?) X) 8 | (symbol? dotted-var) 9 | (Bounds? dotted-bnd) 10 | (every? #(every? Type? %) [S T]) 11 | (Type? T-dotted) 12 | (AnyType? R) 13 | ((set-c? symbol?) must-vars) 14 | ((some-fn nil? Type?) expected)] 15 | :post [(substitution-c? %)]} 16 | (let [[short-S rest-S] (split-at (count T) S) 17 | ; _ (prn "short-S" (map unparse-type short-S)) 18 | ; _ (prn "rest-S" (map unparse-type rest-S)) 19 | expected-cset (if expected 20 | (cs-gen #{} X {dotted-var dotted-bnd} R expected) 21 | (empty-cset {} {})) 22 | ; _ (prn "expected-cset" expected-cset) 23 | cs-short (cs-gen-list #{} X {dotted-var dotted-bnd} short-S T 24 | :expected-cset expected-cset) 25 | ;_ (prn "cs-short" cs-short) 26 | new-vars (var-store-take dotted-var T-dotted (count rest-S)) 27 | new-Ts (doall 28 | (for [v new-vars] 29 | (let [target (substitute-dots (map make-F new-vars) nil dotted-var T-dotted)] 30 | #_(prn "replace" v "with" dotted-var "in" (unparse-type target)) 31 | (substitute (make-F v) dotted-var target)))) 32 | ;_ (prn "new-Ts" new-Ts) 33 | cs-dotted (cs-gen-list #{} (merge X (zipmap new-vars (repeat dotted-bnd))) {dotted-var dotted-bnd} rest-S new-Ts 34 | :expected-cset expected-cset) 35 | ;_ (prn "cs-dotted" cs-dotted) 36 | cs-dotted (move-vars-to-dmap cs-dotted dotted-var new-vars) 37 | ;_ (prn "cs-dotted" cs-dotted) 38 | cs (cset-meet cs-short cs-dotted) 39 | ;_ (prn "cs" cs) 40 | ] 41 | (subst-gen (cset-meet cs expected-cset) #{dotted-var} R))) 42 | 43 | ;; like infer, but T-var is the vararg type: 44 | (defn infer-vararg [X Y S T T-var R & [expected]] 45 | {:pre [(every? (hash-c? symbol? Bounds?) [X Y]) 46 | (every? (every-c? Type?) [S T]) 47 | ((some-fn nil? Type?) T-var) 48 | (AnyType? R) 49 | ((some-fn nil? AnyType?) expected)] 50 | :post [((some-fn nil? substitution-c?) %)]} 51 | ;(prn "infer-vararg" "X:" X) 52 | (let [new-T (if T-var 53 | ;Pad out T 54 | (concat T (repeat (- (count S) (count T)) T-var)) 55 | T)] 56 | ; (prn "S" (map unparse-type S)) 57 | ; (prn "new-T" (map unparse-type new-T)) 58 | ; (prn "R" (unparse-type R)) 59 | ; (prn "expected" (class expected) (when expected (unparse-type expected))) 60 | (and (>= (count S) (count T)) 61 | (infer X Y S new-T R expected)))) 62 | 63 | ;; X : variables to infer 64 | ;; Y : indices to infer 65 | ;; S : actual argument types 66 | ;; T : formal argument types 67 | ;; R : result type 68 | ;; expected : #f or the expected type 69 | ;; returns a substitution 70 | ;; if R is nil, we don't care about the substituion 71 | ;; just return a boolean result 72 | (defn infer [X Y S T R & [expected]] 73 | {:pre [(every? (hash-c? symbol? Bounds?) [X Y]) 74 | (every? Type? S) 75 | (every? Type? T) 76 | (AnyType? R) 77 | ((some-fn nil? AnyType?) expected)] 78 | :post [((some-fn nil? true? substitution-c?) %)]} 79 | ; (prn "infer" ) 80 | ; (prn "X:" X) 81 | ; (prn "Y:" Y) 82 | ; (prn "S:" (map unparse-type S)) 83 | ; (prn "T:" (map unparse-type T)) 84 | ; (when R 85 | ; (prn "R:" (class R) (unparse-type R))) 86 | ; (when expected 87 | ; (prn "expected:" (class expected) (unparse-type expected))) 88 | (let [expected-cset (if expected 89 | (cs-gen #{} X Y R expected) 90 | (empty-cset {} {})) 91 | ;_ (prn "expected cset" expected-cset) 92 | cs (cs-gen-list #{} X Y S T :expected-cset expected-cset) 93 | cs* (cset-meet cs expected-cset)] 94 | ;(prn "final cs" cs*) 95 | (if R 96 | (subst-gen cs* (set (keys Y)) R) 97 | true))) 98 | 99 | -------------------------------------------------------------------------------- /src/typed/inst.clj: -------------------------------------------------------------------------------- 1 | (set! *warn-on-reflection* true) 2 | 3 | (in-ns 'typed.core) 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Polymorphic type instantiation 7 | 8 | (defn manual-inst 9 | "Poly Type^n -> Type 10 | Substitute the type parameters of the polymorphic type 11 | with given types" 12 | [ptype argtys] 13 | {:pre [((some-fn Poly? PolyDots?) ptype) 14 | (seq argtys) 15 | (every? Type? argtys)] 16 | :post [(Type? %)]} 17 | (cond 18 | (Poly? ptype) 19 | (let [^Poly ptype ptype 20 | _ (assert (= (.nbound ptype) (count argtys)) (error-msg "Wrong number of arguments to instantiate polymorphic type")) 21 | names (repeatedly (.nbound ptype) gensym) 22 | body (Poly-body* names ptype) 23 | bbnds (Poly-bbnds* names ptype)] 24 | (doseq [[nme ty ^Bounds bnds] (map vector names argtys bbnds)] 25 | (if (.higher-kind bnds) 26 | (do 27 | (if (F? ty) 28 | (assert (and (TypeFn? (.higher-kind bnds)) 29 | (let [given-bnds (free-with-name-bnds (.name ^F ty)) 30 | _ (assert given-bnds *free-scope*)] 31 | (and (.higher-kind given-bnds) 32 | (subtype? (.higher-kind given-bnds) (.higher-kind bnds))))) 33 | (error-msg "Must instantitate higher-order type variable with another higher-order type variable, given: " 34 | (unparse-type ty))) 35 | (do 36 | (assert (TypeFn? ty) (error-msg "Must instantiate higher-order type variable with type function, given:" 37 | (unparse-type ty))) 38 | (assert (subtype? ty (.higher-kind bnds)) 39 | (error-msg "Higher-order type variable " (unparse-type ty) 40 | " does not match bound " (unparse-type (.higher-kind bnds))))))) 41 | (let [lower-bound (substitute-many (.lower-bound bnds) argtys names) 42 | upper-bound (substitute-many (.upper-bound bnds) argtys names)] 43 | (assert (subtype? lower-bound upper-bound) 44 | (error-msg "Lower-bound " (unparse-type lower-bound) 45 | " is not below upper-bound " (unparse-type upper-bound))) 46 | (assert (and (subtype? ty upper-bound) 47 | (subtype? lower-bound ty)) 48 | (error-msg "Manually instantiated type " (unparse-type ty) 49 | " is not between bounds " (unparse-type lower-bound) 50 | " and " (unparse-type upper-bound)))))) 51 | (substitute-many body argtys names)) 52 | 53 | (PolyDots? ptype) 54 | (let [^PolyDots ptype ptype 55 | nrequired-types (dec (.nbound ptype)) 56 | _ (assert (<= nrequired-types (count argtys)) "Insufficient arguments to instantiate dotted polymorphic type") 57 | names (repeatedly (.nbound ptype) gensym) 58 | body (PolyDots-body* names ptype) 59 | bbnds (PolyDots-bbnds* names ptype)] 60 | (doseq [[nme ty ^Bounds bnds] (map vector names argtys bbnds)] 61 | (assert (not (.higher-kind bnds)) "NYI") 62 | (let [lower-bound (substitute-many (.lower-bound bnds) argtys names) 63 | upper-bound (substitute-many (.upper-bound bnds) argtys names)] 64 | (assert (subtype? lower-bound upper-bound) 65 | (error-msg "Lower-bound " (unparse-type lower-bound) 66 | " is not below upper-bound " (unparse-type upper-bound))) 67 | (assert (and (subtype? ty upper-bound) 68 | (subtype? lower-bound ty)) 69 | (error-msg "Manually instantiated type " (unparse-type ty) 70 | " is not between bounds " (unparse-type lower-bound) 71 | " and " (unparse-type upper-bound))))) 72 | (-> body 73 | ; expand dotted pre-types in body 74 | (trans-dots (last names) ;the bound 75 | (drop (dec (:nbound ptype)) argtys)) ;the types to expand pre-type with 76 | ; substitute normal variables 77 | (substitute-many (take nrequired-types argtys) (butlast names)))))) 78 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repository has moved: [core.typed](https://github.com/clojure/core.typed) 2 | ====== 3 | 4 | 5 | Leiningen dependency (Clojars): 6 | 7 | `[typed "0.1.6"]` 8 | 9 | # Typed Clojure 10 | 11 | Gradual typing in Clojure, as a library. 12 | 13 | # [Talk] Clojure Conj 2012 14 | 15 | [Video](http://www.youtube.com/watch?v=wNhK8t3uLJU) 16 | 17 | # Documentation 18 | 19 | See [wiki](https://github.com/frenchy64/typed-clojure/wiki). 20 | 21 | # License 22 | 23 | Typed Clojure is released under the same license as Clojure: Eclipse Public License v 1.0. 24 | 25 | See `LICENSE`. 26 | 27 | # Changelog 28 | 29 | 0.1.6 30 | - Ensure `Result` is not introduced when performing type inference on drest fn apps 31 | - `tc-ignore` is more do-like. 32 | 33 | Workaround for a quirk in the Clojure compiler where protocols only get generated in 34 | a top-level `do`. 35 | 36 | ```clojure 37 | (identity (do (def-protocol foo (bar [this])) 38 | bar)) ;; <-- bar cannot be resolved 39 | vs. 40 | (do (def-protocol foo (bar [this])) 41 | bar) ;; <-- bar is resolvable 42 | ``` 43 | 44 | (patch by Stephen Compall, issue #3) 45 | - Fix typo in `into-array` logic 46 | (patch by Stephen Compall, issue #4) 47 | - `into-array>` generalises Java types, does not need redundant type annotations. See User Documentation in wiki. 48 | - Improve type of `clojure.core/class`. 49 | (class ) is always a Class 50 | (class nil) is always a nil 51 | - Move documentation to [wiki](https://github.com/frenchy64/typed-clojure/wiki). 52 | 53 | 0.1.5 54 | - Better errors for Java methods and polymorphic function applications, borrow error messages from Typed Racket 55 | - Change `ann-datatype`, `ann-protocol`, `ann-pprotocol` syntax to be flatter 56 | (ann-protocol pname 57 | method-name method-type ...) 58 | (ann-dataype dname 59 | [field-name :- field-type ...]) 60 | - Add `defprotocol>` 61 | 62 | 0.1.4 63 | - Support Clojure 1.4.0+ 64 | - Better errors, print macro-expanded form from AST 65 | 66 | 0.1.3 67 | - Refactor typed.core into individual files 68 | - Add `method-type` 69 | - `(method-type 'java.io.File/getName)` prints the current Typed Clojure type for the getName method of File 70 | - Add types for some clojure.core coersion functions 71 | - Preliminary support for ClojureScript 72 | 73 | 0.1.2 74 | - Fix objects and filters being lost during polymorphic and dotted function applications 75 | - Add tests for (if (seq a) (first a) 0) filter example. 76 | - Can annotate datatypes outside current namespace 77 | - Improve type of `seq`, `next`, `conj` 78 | - tc-pr-env -> print-env 79 | - tc-pr-filters -> print-filterset 80 | - Alter APersistentMap 81 | - Check that local binding occurrences match with expected types 82 | - Heterogeneous maps are APersistentMap's instead of IPersistentMap's 83 | - Heterogeneous vectors are APersistentVector's instead of IPersistentVector's 84 | 85 | 0.1.1 86 | 87 | - Ensure `ann-form` finally checks its expression is of the expected type 88 | - Improve simplifying of intersections involving Java classes 89 | 90 | # Quickstart 91 | 92 | `(typed.core/ann v t)` gives var `v` the static type `t`. 93 | 94 | `(typed.core/ann-form f t)` ensures form `f` is of the static type `t`. 95 | 96 | `(typed.core/check-ns)` type checks the current namespace. 97 | 98 | `(typed.core/cf t)` type checks the form `t`. 99 | 100 | # Examples 101 | 102 | (These don't completely type check yet) 103 | 104 | * [typed.test.rbt](https://github.com/frenchy64/typed-clojure/blob/master/test/typed/test/rbt.clj) for examples of mutually recursive types and heterogenous maps 105 | * [typed.test.core-logic](https://github.com/frenchy64/typed-clojure/blob/master/test/typed/test/core_logic.clj) for examples of typing (tightly coupled) datatypes and protocols 106 | * [typed.test.example](https://github.com/frenchy64/typed-clojure/blob/master/test/typed/test/example.clj) for a few little examples of simple usage 107 | 108 | # Future work 109 | 110 | * Equality filters for occurrence typing 111 | * Type check multimethods 112 | * Rest type checking in fn definition 113 | * Type check defprotocol definitions 114 | * Unify AST with ClojureScript 115 | * Namespace dependency management 116 | 117 | # Contributors 118 | 119 | Stephen Compall (S11001001) 120 | -------------------------------------------------------------------------------- /src/typed/type_ops.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | 4 | ;; FIXME much better algorithms around I'm sure 5 | (defn countrange-overlap? 6 | [{lowerl :lower upperl :upper :as l} 7 | {lowerr :lower upperr :upper :as r}] 8 | {:pre [(CountRange? l) 9 | (CountRange? r)]} 10 | (cond 11 | (and upperl upperr) 12 | (or 13 | ;; ----- 14 | ;; ------- 15 | ;; and 16 | ;; --- 17 | ;; ------- 18 | (<= lowerl lowerr upperl upperr) 19 | 20 | ;; -- 21 | ;; ------- 22 | (<= lowerr lowerl upperl upperr) 23 | 24 | ;; ------ 25 | ;; ------- 26 | ;; and 27 | ;; --- 28 | ;; ------- 29 | (<= lowerr lowerl upperr upperl) 30 | 31 | ;; otherwise no overlap 32 | false) 33 | 34 | upperl ;; and (not upperr) 35 | (or 36 | ;; ---- 37 | ;; ----->> 38 | ;; and 39 | ;; --- 40 | ;; ----->> 41 | (<= lowerl lowerr upperl) 42 | ;; --- 43 | ;; ----->> 44 | (<= lowerr lowerl) 45 | ;; otherwise no overlap 46 | false) 47 | upperr 48 | (or 49 | ;; ------>> 50 | ;; ---- 51 | ;; and 52 | ;; ----->> 53 | ;; --- 54 | (<= lowerl lowerr) 55 | 56 | ;; --->> 57 | ;; ---- 58 | (<= lowerr lowerl upperr) 59 | 60 | ;; else no overlap 61 | false) 62 | :else ;; (and (not upperl) (not upperr)) 63 | ;; ---->> 64 | ;; -->> 65 | ;; and 66 | ;; -->> 67 | ;; ---->> 68 | true)) 69 | 70 | 71 | ;true if types t1 and t2 overlap (NYI) 72 | (defn overlap [t1 t2] 73 | (let [eq (= t1 t2) 74 | hmap-and-seq? (fn [h s] (and (HeterogeneousMap? h) 75 | (RClass? s) 76 | (= (Class->symbol clojure.lang.ISeq) (:the-class s))))] 77 | (cond 78 | eq eq 79 | 80 | (and (Value? t1) 81 | (Value? t2)) 82 | eq 83 | 84 | ;if both are Classes, and at least one isn't an interface, then they must be subtypes to have overlap 85 | (and (RClass? t1) 86 | (RClass? t2) 87 | (let [{t1-flags :flags} (reflect/type-reflect (RClass->Class t1)) 88 | {t2-flags :flags} (reflect/type-reflect (RClass->Class t2))] 89 | (some (complement :interface) [t1-flags t2-flags]))) 90 | (or (subtype? t1 t2) 91 | (subtype? t2 t1)) 92 | 93 | (or (Value? t1) 94 | (Value? t2)) (or (subtype? t1 t2) 95 | (subtype? t2 t1)) 96 | (and (CountRange? t1) 97 | (CountRange? t2)) (countrange-overlap? t1 t2) 98 | ; (and (Name? t1) 99 | ; (Name? t2)) (overlap (-resolve t1) (-resolve t2)) 100 | ; (Name? t1) (overlap (-resolve t1) t2) 101 | ; (Name? t2) (overlap t1 (-resolve t2)) 102 | (and (HeterogeneousMap? t1) 103 | (HeterogeneousMap? t2)) (and (= (set (-> t1 :types keys)) 104 | (set (-> t2 :types keys))) 105 | (every? true? 106 | (for [[k1 v1] (:types t1)] 107 | (let [v2 ((:types t2) k1)] 108 | (overlap v1 v2))))) 109 | 110 | ;for destructuring mexpansion 111 | (or (hmap-and-seq? t1 t2) 112 | (hmap-and-seq? t2 t1)) 113 | false 114 | 115 | :else true))) ;FIXME conservative result 116 | 117 | (declare infer subst-all) 118 | 119 | ; restrict t1 to be a subtype of t2 120 | (defn restrict [t1 t2] 121 | (cond 122 | (subtype? t1 t2) t1 ;; already a subtype 123 | 124 | (not (overlap t1 t2)) (Un) ;there's no overlap, so the restriction is empty 125 | 126 | (Union? t1) (apply Un (map (fn [e] (restrict e t2)) (:types t1))) 127 | (Union? t2) (apply Un (map (fn [e] (restrict t1 e)) (:types t2))) 128 | 129 | (Poly? t2) 130 | (let [names (repeatedly (:nbound t2) gensym) 131 | t (Poly-body* names t2) 132 | bbnds (Poly-bbnds* names t2) 133 | subst (try 134 | (infer (zipmap names bbnds) {} (list t1) (list t) t1) 135 | (catch IllegalArgumentException e 136 | (throw e)) 137 | (catch Exception e))] 138 | (and subst (restrict t1 (subst-all subst t1)))) 139 | 140 | ;TODO other cases 141 | :else (In t2 t1))) 142 | -------------------------------------------------------------------------------- /test/typed/test/set.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.set 2 | (:require [typed.core :refer [check-ns ann cf tc-ignore print-env ann-form]]) 3 | (:import (clojure.lang Seqable APersistentSet IPersistentSet IPersistentMap))) 4 | 5 | (ann clojure.core/< [Number Number * -> Number]) 6 | (ann clojure.core/max-key (All [x] 7 | [[x -> Number] x x x * -> x])) 8 | 9 | (ann bubble-max-key (All [x] 10 | [[x -> Number] (I (Seqable x) (CountRange 2)) -> (Seqable x)])) 11 | (tc-ignore 12 | (defn- bubble-max-key [k coll] 13 | "Move a maximal element of coll according to fn k (which returns a number) 14 | to the front of coll." 15 | (let [max (apply max-key k coll)] 16 | (cons max (remove #(identical? max %) coll)))) 17 | ) 18 | 19 | (ann union (All [x] 20 | (Fn [ -> (APersistentSet x)] 21 | [(APersistentSet x) -> (APersistentSet x)] 22 | [(APersistentSet x) (APersistentSet x) -> (APersistentSet x)] 23 | [(APersistentSet x) (APersistentSet x) (APersistentSet x) * -> (APersistentSet x)]))) 24 | (tc-ignore 25 | (defn union 26 | "Return a set that is the union of the input sets" 27 | {:added "1.0"} 28 | ([] #{}) 29 | ([s1] s1) 30 | ([s1 s2] 31 | (if (< (count s1) (count s2)) 32 | (reduce conj s2 s1) 33 | (reduce conj s1 s2))) 34 | ([s1 s2 & sets] 35 | (print-env "top of variable arity") 36 | (let [bubbled-sets (bubble-max-key count (conj sets s2 s1))] 37 | (reduce into (first bubbled-sets) (rest bubbled-sets))))) 38 | ) 39 | 40 | (tc-ignore 41 | (defn intersection 42 | "Return a set that is the intersection of the input sets" 43 | {:added "1.0"} 44 | ([s1] s1) 45 | ([s1 s2] 46 | (if (< (count s2) (count s1)) 47 | (recur s2 s1) 48 | (reduce (fn [result item] 49 | (if (contains? s2 item) 50 | result 51 | (disj result item))) 52 | s1 s1))) 53 | ([s1 s2 & sets] 54 | (let [bubbled-sets (bubble-max-key #(- (count %)) (conj sets s2 s1))] 55 | (reduce intersection (first bubbled-sets) (rest bubbled-sets))))) 56 | 57 | (defn difference 58 | "Return a set that is the first set without elements of the remaining sets" 59 | {:added "1.0"} 60 | ([s1] s1) 61 | ([s1 s2] 62 | (if (< (count s1) (count s2)) 63 | (reduce (fn [result item] 64 | (if (contains? s2 item) 65 | (disj result item) 66 | result)) 67 | s1 s1) 68 | (reduce disj s1 s2))) 69 | ([s1 s2 & sets] 70 | (reduce difference s1 (conj sets s2)))) 71 | ) 72 | 73 | (ann select (All [x] 74 | [[x -> Any] (IPersistentSet x) -> (IPersistentSet x)])) 75 | (tc-ignore 76 | (defn select 77 | "Returns a set of the elements for which pred is true" 78 | {:added "1.0"} 79 | [pred xset] 80 | (reduce (ann-form 81 | (fn [s k] (if (pred k) s (disj s k))) 82 | [(IPersistentSet x) x -> (IPersistentSet x)]) 83 | xset xset)) 84 | 85 | (defn project 86 | "Returns a rel of the elements of xrel with only the keys in ks" 87 | {:added "1.0"} 88 | [xrel ks] 89 | (with-meta (set (map #(select-keys % ks) xrel)) (meta xrel))) 90 | 91 | (defn rename-keys 92 | "Returns the map with the keys in kmap renamed to the vals in kmap" 93 | {:added "1.0"} 94 | [map kmap] 95 | (reduce 96 | (fn [m [old new]] 97 | (if (contains? map old) 98 | (assoc m new (get map old)) 99 | m)) 100 | (apply dissoc map (keys kmap)) kmap)) 101 | 102 | (defn rename 103 | "Returns a rel of the maps in xrel with the keys in kmap renamed to the vals in kmap" 104 | {:added "1.0"} 105 | [xrel kmap] 106 | (with-meta (set (map #(rename-keys % kmap) xrel)) (meta xrel))) 107 | 108 | (defn index 109 | "Returns a map of the distinct values of ks in the xrel mapped to a 110 | set of the maps in xrel with the corresponding values of ks." 111 | {:added "1.0"} 112 | [xrel ks] 113 | (reduce 114 | (fn [m x] 115 | (let [ik (select-keys x ks)] 116 | (assoc m ik (conj (get m ik #{}) x)))) 117 | {} xrel)) 118 | ) 119 | 120 | (comment 121 | (check-ns) 122 | ) 123 | 124 | (ann map-invert (All [x y] 125 | [(IPersistentMap x y) -> (IPersistentMap y x)])) 126 | (defn map-invert 127 | "Returns the map with the vals mapped to the keys." 128 | {:added "1.0"} 129 | [m] 130 | (reduce (ann-form 131 | (fn [m [k v]] 132 | (assoc m v k)) 133 | [(IPersistentMap y x) '[x y] -> (IPersistentMap y x)]) 134 | {} m)) 135 | 136 | (defn join 137 | "When passed 2 rels, returns the rel corresponding to the natural 138 | join. When passed an additional keymap, joins on the corresponding 139 | keys." 140 | {:added "1.0"} 141 | ([xrel yrel] ;natural join 142 | (if (and (seq xrel) (seq yrel)) 143 | (let [ks (intersection (set (keys (first xrel))) (set (keys (first yrel)))) 144 | [r s] (if (<= (count xrel) (count yrel)) 145 | [xrel yrel] 146 | [yrel xrel]) 147 | idx (index r ks)] 148 | (reduce (fn [ret x] 149 | (let [found (idx (select-keys x ks))] 150 | (if found 151 | (reduce #(conj %1 (merge %2 x)) ret found) 152 | ret))) 153 | #{} s)) 154 | #{})) 155 | ([xrel yrel km] ;arbitrary key mapping 156 | (let [[r s k] (if (<= (count xrel) (count yrel)) 157 | [xrel yrel (map-invert km)] 158 | [yrel xrel km]) 159 | idx (index r (vals k))] 160 | (reduce (fn [ret x] 161 | (let [found (idx (rename-keys (select-keys x (keys k)) k))] 162 | (if found 163 | (reduce #(conj %1 (merge %2 x)) ret found) 164 | ret))) 165 | #{} s)))) 166 | 167 | (defn subset? 168 | "Is set1 a subset of set2?" 169 | {:added "1.2", 170 | :tag Boolean} 171 | [set1 set2] 172 | (and (<= (count set1) (count set2)) 173 | (every? #(contains? set2 %) set1))) 174 | 175 | (defn superset? 176 | "Is set1 a superset of set2?" 177 | {:added "1.2", 178 | :tag Boolean} 179 | [set1 set2] 180 | (and (>= (count set1) (count set2)) 181 | (every? #(contains? set1 %) set2))) 182 | 183 | (comment 184 | (refer 'set) 185 | (def xs #{{:a 11 :b 1 :c 1 :d 4} 186 | {:a 2 :b 12 :c 2 :d 6} 187 | {:a 3 :b 3 :c 3 :d 8 :f 42}}) 188 | 189 | (def ys #{{:a 11 :b 11 :c 11 :e 5} 190 | {:a 12 :b 11 :c 12 :e 3} 191 | {:a 3 :b 3 :c 3 :e 7 }}) 192 | 193 | (join xs ys) 194 | (join xs (rename ys {:b :yb :c :yc}) {:a :a}) 195 | 196 | (union #{:a :b :c} #{:c :d :e }) 197 | (difference #{:a :b :c} #{:c :d :e}) 198 | (intersection #{:a :b :c} #{:c :d :e}) 199 | 200 | (index ys [:b]) 201 | ) 202 | 203 | 204 | -------------------------------------------------------------------------------- /notes/altered_types.clj: -------------------------------------------------------------------------------- 1 | ;#; Base Types 2 | 3 | (alter-poly-interface Seqable [[a :< (U (Inst ISeq _ _ _) Nil) :variance :covariant] ;result of (seq this) 4 | ]) 5 | 6 | ;cons, count, empty, equiv 7 | (alter-poly-interface IPersistentCollection [[a :variance :covariant] ;object to cons 8 | [b :< (Inst IPersistentCollection _ _ _) 9 | :variance :covariant] ;cons result 10 | [c :< (Inst IPersistentCollection _ _ _) 11 | :variance :covariant] ;empty 12 | ]) 13 | 14 | (alter-poly-interface ISeq [[a :variance :covariant] ;first 15 | [b :< (Inst ISeq _) 16 | :variance :covariant] ;rest output 17 | [c :< (U Nil (Inst ISeq _)) 18 | :variance :covariant] ;next output 19 | ]) 20 | 21 | ;(get (ILookup [a -> b]) a) => b 22 | (alter-poly-interface ILookup [[a :< (Fn [_ -> _]) ;just return Nothing for not found? then fns using this can union to get not found 23 | :variance :covariant]]) 24 | 25 | (alter-poly-interface IPersistentSet [[a :variance :covariant] ;contents of set 26 | ]) 27 | 28 | ;(assoc (Associative [a b -> c]) a b) => c 29 | (alter-poly-interface Associative [[a :< (Fn [_ _ -> _]) ;key value -> assoc result 30 | :variance :covariant] 31 | ] 32 | ) 33 | 34 | ;(dissoc (IPersistentMap [c -> d]) c) => d 35 | (alter-poly-interface IPersistentMap [[c :< (Fn [_ -> _]) ;dissockey -> dissocresult 36 | :variance :covariant]] 37 | ) 38 | 39 | (alter-poly-interface IPersistentStack [[a :variance :covariant] ;peek result 40 | [b :< (Inst IPersistentStack _ _) 41 | :variance :covariant] ;pop result 42 | ]) 43 | 44 | (alter-poly-interface IPersistentVector [[a :variance :covariant] ;key 45 | [b :variance :covariant]]);value 46 | 47 | (alter-poly-interface Counted [[a :variance :covariant] ;count 48 | ]) 49 | 50 | 51 | (alter-poly-class Cons [[a :variance :covariant] 52 | [b :< (U Nil (Inst ISeq a)) :variance :covariant]] 53 | :replace 54 | {Seqable (Inst Seqable (Inst Cons a b)) 55 | IPersistentColection (Inst IPersistentColection 56 | a ;object to cons 57 | (Inst Cons a (Inst Cons a b)) ;conj 58 | PersistentList$EmptyList ;empty 59 | a ;first 60 | b) ;rest 61 | ISeq (Inst ISeq a)}) 62 | 63 | (alter-poly-class PersistentList [[a :variance :covariant]] 64 | :replace 65 | {Seqable (Inst Seqable (Inst PersistentList a)) 66 | IPersistentStack (Inst IPersistentStack a (U (Inst PersistentList a) 67 | PersistentList$EmptyList)) 68 | IPersistentColection (Inst IPersistentColection 69 | a ;cons obj 70 | (Inst PersistentList a) ;cons result 71 | PersistentList$EmptyList ;empty 72 | a ;first 73 | (U (Inst PersistentList a) 74 | (Inst PersistentList$EmptyList)) ;rest 75 | (Inst PersistentList a) ;next 76 | ) 77 | }) 78 | 79 | (alter-poly-class PersistentList$EmptyList [[a :variance :covariant]] 80 | :replace 81 | {Seqable (Inst Seqable Nil) 82 | IPersistentStack (Inst IPersistentStack a Nothing) ;cannot pop 83 | IPersistentCollection (Inst IPersistentCollection 84 | a ;cons obj 85 | (Inst PersistentList a) ;cons result 86 | PersistentList$EmptyList ;empty 87 | Nil ;first 88 | IPersistentCollection$EmptyList ;rest 89 | Nil) ;next 90 | }) 91 | 92 | (alter-poly-interface IMapEntry [[a :variance :covariant] ;key 93 | [b :variance :covariant] ;value 94 | ] 95 | ) 96 | 97 | ;(alter-poly-class MapEntry [[a :variance :covariant] ;key 98 | ; [b :variance :covariant] ;value 99 | ; ] 100 | ; :replace 101 | ; {IMapEntry (Inst IMapEntry a b) 102 | ; Associative (Inst Associative 103 | ; (Fn [ 104 | ; a b -> (Inst PersistentVector b) 105 | 106 | (alter-poly-class PersistentHashMap [[a :variance :invariant] ;key 107 | [b :variance :invariant]] 108 | :replace 109 | {Seqable (Inst Seqable (Inst ASeq (MapEntry a b))) 110 | IPersistentMap (Inst IPersistentMap 111 | (Fn [a -> (Inst IPersistentMap a b)])) ;dissockey -> dissocresult 112 | }) 113 | 114 | (deftype ConstantPersistentHashMap [keyvals]) 115 | 116 | (alter-poly-class PersistentVector [[a :variance :covariant]] 117 | :replace 118 | {Seqable (Inst Seqable (U Nil (Inst PersistentVector$ChunkedSeq a))) 119 | IPersistentCollection (Inst IPersistentCollection 120 | a ;type to cons 121 | (Inst PersistentVector a) ;cons result 122 | (Inst PersistentVector Nothing) ;empty 123 | a ;first 124 | (Inst PersistentVector a) ;rest 125 | (Inst PersistentVector a) ;next 126 | ) 127 | Associative (Inst Associative (Fn [Long a -> (PersistentVector a)])) ;TODO clojure integer type 128 | IPersistentStack (Inst IPersistentStack a) 129 | IFn (Fn [Long -> a])}) 130 | 131 | -------------------------------------------------------------------------------- /notes/sigs.clj: -------------------------------------------------------------------------------- 1 | 2 | ;; Some sigs 3 | 4 | (+T clojure.core/seq 5 | (All [[x :variance :invariant]] 6 | (Fn [(Inst Seqable x) -> x] 7 | [CharSequence -> (U StringSeq Nil)] 8 | ;array -> (U ArraySeq Nil) 9 | [Nil -> Nil] 10 | [(U Map Iterable) -> (U IteratorSeq Nil)]))) 11 | 12 | (+T clojure.core/conj 13 | (All [[x :variance :invariant] ;object to cons 14 | [c :variance :invariant]] ;cons result 15 | (Fn [(Inst IPersistentCollection x c _ _ _) x & x * -> c] 16 | [Nil & x * -> (Inst PersistentList x)]))) 17 | 18 | (+T clojure.core/into 19 | (All [[o :variance :invariant] ;first arg 20 | [tx :variance :invariant] 21 | [tc :variance :invariant] 22 | [t :variance :invariant] ;transient 23 | [pt :variance :invariant] 24 | [x :variance :invariant] ;object to cons 25 | [c :variance :invariant]] ;cons result 26 | (Fn [(Inst IEditableCollection t) 27 | (Inst ConstantCollection tx ... tx) -> 28 | pt :in (Inst ITransientCollection t tx _) 29 | :init t 30 | :next tx 31 | :for tx 32 | :finally (Inst ITransientCollection _ _ pt)] 33 | [(Inst IPersistentCollection x c _ _ _) -> c] 34 | [Nil & x * -> (Inst PersistentList x)]))) 35 | 36 | (+T clojure.core/first 37 | (All [[f :variance :invariant]] 38 | (Fn [(Inst IPersistentCollection _ _ _ f _ _) -> f] 39 | [(Inst Seqable (Inst IPersistentCollection _ _ _ f _ _)) -> f] 40 | [CharSequence -> (U StringSeq Nil)] 41 | ;array -> (U Any Nil) 42 | [Iterable -> (U IteratorSeq Nil)] 43 | [Nil -> Nil]))) 44 | 45 | (+T clojure.core/rest 46 | (All [[r :variance :invariant]] ;rest 47 | (Fn [(Inst IPersistentCollection _ _ _ _ r _) -> r] 48 | [(Inst Seqable (Inst IPersistentCollection _ _ _ _ r _)) -> r] 49 | [CharSequence -> (U StringSeq PersistentList$EmptyList)] 50 | [Nil -> PersistentList$EmptyList] 51 | ;array -> (U ArraySeq PersistentList$EmptyList) 52 | [(U Map Iterable) -> (U IteratorSeq PersistentList$EmptyList)]))) 53 | 54 | (+T clojure.core/next 55 | (All [[n :variance :invariant]] ;rest 56 | (Fn [(Inst IPersistentCollection _ _ _ _ _ n) -> n] 57 | [(Inst Seqable (Inst IPersistentCollection _ _ _ _ _ n)) -> n] 58 | [CharSequence -> (U StringSeq Nil)] 59 | [Nil -> Nil] 60 | ;array -> (U ArraySeq Nil) 61 | [(U Map Iterable) -> (U IteratorSeq Nil)]))) 62 | 63 | (+T clojure.core/assoc 64 | (All [[a :variance :invariant] ;invariant 65 | [b :variance :invariant] 66 | [c :variance :invariant]] 67 | (Fn [(Inst Associative (Fn [a b -> c])) a b & [a b] * -> c] ;TODO "keyword" rest args 68 | [Nil a b & [a b] * -> (U (Inst PersistentArrayMap a b) 69 | (Inst PersistentHashMap a b))] ;sufficient return type? seems hacky - Ambrose 70 | ))) 71 | 72 | (defrecord A []) 73 | 74 | 75 | (dissoc {:a :b, :c :d, :e :f} 76 | :a ;{:c :d, :e :f} 77 | :c ;{:e :f} 78 | :e ;{} 79 | :a ;{} 80 | ) 81 | 82 | (+T clojure.core/dissoc 83 | (All [[a :< (Inst IPersistentMap _) 84 | :variance :invariant] 85 | [b :variance :invariant] 86 | [c :pre-type true] 87 | [d :recursive-placeholder true]] 88 | (Fn [a & c ... c -> d :in (IPersistentCollection [c -> d]) ... c :next d] 89 | [Nil & Any * -> Nil]))) 90 | 91 | (+T clojure.core/merge 92 | (All [[a :< (Inst IPersistentCollection _)]] 93 | (Fn [& m ... m -> r]))) 94 | 95 | (+T clojure.core/count 96 | (All [[a :variance :invariant]] 97 | (Fn [(Inst Counted a) -> a] 98 | [(Inst Seqable a) -> Integer]))) 99 | 100 | [1 2] :- (I (Counted (Value 2)) 101 | (IPersistentVector [1 2])) 102 | 103 | (+T clojure.core/nth 104 | (All [[a :< (Inst Value _) 105 | :variance :invariant] 106 | [b :< (Inst Value _) 107 | :variance :invariant]] 108 | (Fn [(Inst Counted a) (Inst Value b) -> (assert (< a b))]))) 109 | 110 | (conj {:a :b} (could-return-nil) (if (pred 1) 111 | [:a :c] 112 | [:b :c])) 113 | 114 | [& b ... b] 115 | (C a b) ... a :recursive-point b 116 | 117 | (C [a0 -> 118 | (C [a1 -> 119 | (C [a2 -> 120 | ... 121 | (C [aN -> 122 | r])])])]) 123 | 124 | (Inst IPersistentMap a 125 | (Inst IPersistentMap b (Inst IPersistentMap ))) 126 | 127 | (map + [1 2] [1]) 128 | 129 | (+T clojure.core/map 130 | (All [[a :variance :invariant] 131 | [b :pre-type true] 132 | [c :variance :invariant]] 133 | (Fn [(Fn [a & b ... b -> c]) 134 | (Inst Seqable (Inst ISeq a _ _)) 135 | & (Inst Seqable (Inst ISeq b _ _)) 136 | ... b 137 | -> (LazySeq c)]))) 138 | 139 | (+T clojure.core/nth 140 | (All [[a :variance :invariant] 141 | [b :pre-type true] 142 | [c :variance :invariant]] 143 | (I (Fn [(Inst Indexed a b) a -> b] 144 | [Nil Any -> Nil] 145 | [CharSequence Integer -> (U Nil Character)] 146 | [(U Matcher RandomAccess) Integer -> Any] 147 | [Map.Entry Integer -> Any] 148 | [Sequential Integer -> Any]) 149 | (Fn [(Inst Indexed a b) a c -> (U b c)] 150 | [Nil Any c -> c] 151 | [CharSequence Integer c -> (U c Character)] 152 | [(U Matcher RandomAccess) Integer c -> (U Any c)] 153 | [Map.Entry Integer c -> (U Any c)] 154 | [Sequential Integer -> Any])))) 155 | 156 | ;(U Integer (Value 1)) <: (Inst Value _) 157 | 158 | (get {:a 1} :a) => 1 159 | (get {:a 1} :b) => nil 160 | 161 | (+T clojure.core/get 162 | (All [[vk :< (Inst Value _) 163 | :variance :invariant] 164 | [c :variance :invariant] 165 | [d :variance :invariant] 166 | [e :variance :invariant]] 167 | (Fn [(ILookup (Fn [vk -> d])) vk -> d] ;try matching on Values 168 | [(ILookup (Fn [c -> d])) e -> (U d Nil)] ;fall back on Classes 169 | [Map Any -> Any] 170 | [(IPersistentSet vk) vk -> vk] ;try matching on Values 171 | [(IPersistentSet vk) vk -> Nil] ;try matching on Values 172 | [(IPersistentSet c) e -> (U vk Nil)] ;fall back on Classes 173 | ))) 174 | 175 | ; just playing with syntax 176 | (comment 177 | 178 | ;(+T-pprotocol ProtocolName tvars & methods) 179 | (+T-pprotocol ISeq [[a :variance :invariant]] 180 | (+T first (Fn [(Inst IPersistentCollection Nothing) 181 | -> Nil] 182 | [(Inst IPersistentCollection a) 183 | -> (U (ASeq a) Nil)] 184 | [String -> (U Nil (ASeq Character))] 185 | [(U Iterable Map Seqable) -> (U Nil (ASeq Any))]))) 186 | 187 | ;(+T-ptype TypeName tvars fields & impls) 188 | 189 | (+T-ptype VectorNode [[x :variance :invariant]] 190 | [[arr (Inst Array x)]]) 191 | 192 | (+T-ptype PersistentVector [[x :variance :covariant]] 193 | [[cnt :- Long] 194 | [root :- (Inst VectorNode Any)] 195 | [tail :- (Inst ListNode x)]] 196 | ) 197 | ) 198 | -------------------------------------------------------------------------------- /notes/unit_tests.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.example 2 | (:use [clojure.test]) 3 | (:require [typed.core :refer [subtype? Fn Any Nothing]])) 4 | 5 | (deftest form-test 6 | (is (assoc {} :a 1))) 7 | 8 | ;; subtype 9 | (deftest value-subtypes 10 | (is (subtype? 1 1)) 11 | (is (not (subtype? 1 2)))) 12 | 13 | (deftest value-subtypes 14 | (is (subtype? 1 1)) 15 | (is (not (subtype? 1 2)))) 16 | 17 | (deftest function-subtypes 18 | (is (subtype? (Fn [Number -> Number]) (Fn [Number -> Number])))) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Subtyping 22 | 23 | (deftest subtype-any-nothing 24 | (is (subtype? (Fn [1 -> 1]) Any)) 25 | (is (subtype? Nothing (Fn [1 -> 1]))) 26 | (is (subtype? Nothing Any)) 27 | (is (subtype? Nothing Object)) 28 | (is (subtype? Nothing nil)) 29 | (is (subtype? Nil Any)) 30 | (is (subtype? Long Any))) 31 | 32 | (assoc {} 33 | :a 1 34 | :b 2) 35 | ;=> {:a 1, :b 2} 36 | 37 | 38 | 39 | (conj {:a 1} 40 | (when 1 41 | [:b 2]) 42 | [:c 3]) 43 | 44 | 45 | (comment 46 | (deftest subtype-object 47 | (is (subtype? (Fn [1 -> 1]) Object)) 48 | (is (subtype? byte Object)) 49 | (is (subtype? short Object)) 50 | (is (subtype? int Object)) 51 | (is (subtype? long Object)) 52 | (is (subtype? float Object)) 53 | (is (subtype? double Object)) 54 | (is (subtype? char Object)) 55 | (is (subtype? boolean Object)) 56 | (is (not (subtype? nil Object))) 57 | (is (subtype? Object Object))) 58 | 59 | (deftest subtype-fun 60 | (is (subtype? (Fn [-> nil]) clojure.lang.IFn)) 61 | (is (subtype? (Fn [-> nil]) clojure.lang.AFn)) 62 | (is (subtype? (Fn [-> nil]) clojure.lang.IObj))) 63 | 64 | (deftest subtype-classes 65 | (is (subtype? Long Long)) 66 | (is (subtype? Long Object))) 67 | 68 | (deftest subtype-singletons 69 | (is (not (subtype? 1 2))) 70 | (is (subtype? 1 1)) 71 | (is (subtype? 1 Long)) 72 | (is (not (subtype? Long 1))) 73 | (is (subtype? :a :a)) 74 | (is (not (subtype? :a :b))) 75 | (is (subtype? :a Keyword)) 76 | (is (not (subtype? Keyword :a))) 77 | (is (subtype? (U :a :b) Keyword))) 78 | 79 | (deftest subtype-nil 80 | (is (subtype? nil nil)) 81 | (is (subtype? (U nil) nil)) 82 | (is (not (subtype? nil Var))) 83 | (is (not (subtype? nil 1))) 84 | (is (subtype? nil ISeq)) ; nil implements first, rest, cons 85 | (is (not (subtype? nil Seqable))) ; nil does not implement clojure.lang.ISeq/seq 86 | (is (subtype? nil IMeta)) 87 | (is (subtype? nil IObj)) 88 | (is (subtype? nil Counted)) 89 | (is (subtype? nil ILookup)) 90 | (is (subtype? nil Associative))) 91 | 92 | (deftest subtype-ISeq 93 | (is (subtype? nil ISeq)) 94 | (is (not (subtype? Iterable ISeq))) 95 | (is (not (subtype? java.util.Map ISeq)))) 96 | 97 | (deftest subtype-Seqable 98 | (is (not (subtype? nil Seqable))) 99 | (is (subtype? Iterable Seqable)) 100 | (is (subtype? java.util.Map Seqable))) 101 | 102 | (deftest subtype-unions 103 | (is (subtype? (U) 104 | (U))) 105 | (is (subtype? (U) 106 | (U Object nil))) 107 | (is (not (subtype? (U Object nil) 108 | (U)))) 109 | (is (subtype? (U Long) 110 | (U Long))) 111 | (is (subtype? (U Long Integer) 112 | (U Integer Long))) 113 | (is (subtype? (U (U Class String) Long Integer) 114 | (U Integer (U String Class) Long))) 115 | (is (not (subtype? (U Object) (U Long)))) 116 | (is (not (subtype? Object (U Long)))) 117 | (is (subtype? Long (U Object))) 118 | (is (subtype? (U Float Integer Double) Object)) 119 | ) 120 | 121 | (deftest subtype-funs 122 | (is (subtype? [1 -> 2] 123 | [1 -> 2])) 124 | (is (subtype? [Long -> 1] 125 | [1 -> Long])) 126 | (is (subtype? [Object Long -> 1] 127 | [Long Long -> Long])) 128 | (is (subtype? [Long -> Long] 129 | [1 -> Any] 130 | ))) 131 | 132 | (deftest subtype-qual-keywords 133 | (is (subtype? ::a ::a)) 134 | (is (subtype? t/Type t/Type)) 135 | (is (subtype? ClassType t/Type)) 136 | (is (not (subtype? t/Type Object)))) 137 | 138 | (deftest subtype-varargs 139 | (is (subtype? (Fn [Number & Object * -> Boolean]) 140 | (Fn [Number & Number * -> Boolean]))) 141 | (is (subtype? (Fn [Object & Number * -> Boolean]) 142 | (Fn [Number & Number * -> Boolean]))) 143 | (is (subtype? (Fn [Number & Number * -> Boolean]) 144 | (Fn [Number & Number * -> Boolean]))) 145 | (is (subtype? (Fn [Number & Number * -> Boolean]) 146 | (Fn [Number & Number * -> Object])))_ 147 | (is (subtype? (Fn [Number & Number * -> Number]) 148 | (Fn [Number & Number * -> Number]))) 149 | (is (subtype? (Fn [Number Number & Boolean * -> Number]) 150 | (Fn [Number Number -> Number]))) 151 | (is (not 152 | (subtype? (Fn [Number & Number * -> Boolean]) 153 | (Fn [Number Number Number -> Number])))) 154 | (is (subtype? (Fn [Number Number & Boolean * -> Number]) 155 | (Fn [Number Number Boolean Boolean -> Number]))) 156 | (is (subtype? 157 | (Fn [Long Long & Long * -> Long]) 158 | (Fn [1 1 1 1 1 1 1 -> Any]))) 159 | (is (subtype? 160 | (Fn [Long Long Long Long -> Any]) 161 | clojure.lang.IFn)) 162 | (is (not (subtype? 163 | clojure.lang.IFn 164 | (Fn [Long Long Long Long -> Any])))) 165 | ) 166 | 167 | (deftest subtype-vectors 168 | (is (subtype? (Vector Number) 169 | IPersistentVector)) 170 | (is (subtype? (Vector Number) 171 | clojure.lang.Sequential)) 172 | (is (subtype? (Vector Integer) 173 | (Vector Number))) 174 | (is (not (subtype? (Vector Number) 175 | (Vector Integer)))) 176 | ) 177 | 178 | (deftest subtype-seqable 179 | (is (subtype? (Seq Double) 180 | clojure.lang.ISeq)) 181 | (is (subtype? (Seq Double) 182 | (Seq Number))) 183 | (is (subtype? (Vector Double) 184 | (Seq Number)))) 185 | 186 | ;(deftest subtype-primitives 187 | ; (is (subtype? void void)) 188 | ; (is (subtype? nil void)) 189 | ; (is (subtype? void nil)) 190 | ; (is (subtype? int int)) 191 | ; (is (subtype? double double)) 192 | ; (is (subtype? float float)) 193 | ; (is (subtype? boolean boolean)) 194 | ; (is (subtype? long long))) 195 | 196 | ;(deftest subtype-primitive-boxing 197 | ; (is (subtype? long Long)) 198 | ; (is (subtype? Long long)) 199 | ; (is (subtype? double Double)) 200 | ; (is (subtype? Double double)) 201 | ; ) 202 | 203 | ;(deftest subtype-primitive-numbers 204 | ; (is (subtype? long Number)) 205 | ; (is (subtype? double Number)) 206 | ; (is (subtype? int Number)) 207 | ; (is (subtype? byte Number)) 208 | ; (is (subtype? short Number)) 209 | ; ) 210 | 211 | (deftest subtype-variables 212 | (is (subtype? (All [[x :variance :covariant]] x) 213 | (All [[x :variance :covariant]] x))) 214 | (is (not (subtype? (All [[x :variance :covariant]] x) 215 | (All [[y :variance :covariant]] y))))) 216 | 217 | ) 218 | -------------------------------------------------------------------------------- /src/typed/alter.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Altered Classes 5 | 6 | ;; TODO fix metadata representation 7 | ;; TODO remove redundant ancestors, add tests to ensure they are preserved. 8 | 9 | (alter-class Seqable [[a :variance :covariant]]) 10 | 11 | (alter-class IMeta [[a :variance :covariant]]) 12 | 13 | (alter-class IPersistentCollection [[a :variance :covariant]] 14 | :replace 15 | {Seqable (Seqable a)}) 16 | 17 | (alter-class ISeq [[a :variance :covariant]] 18 | :replace 19 | {Seqable (Seqable a) 20 | IPersistentCollection (IPersistentCollection a)}) 21 | 22 | (alter-class ILookup [[a :variance :covariant] 23 | [b :variance :covariant]]) 24 | 25 | (alter-class IPersistentSet [[a :variance :covariant]] 26 | :replace 27 | {IPersistentCollection (IPersistentCollection a) 28 | Seqable (Seqable a)}) 29 | 30 | (alter-class APersistentSet [[a :variance :covariant]] 31 | :replace 32 | {Seqable (Seqable a) 33 | IFn [Any -> (U a nil)] 34 | AFn [Any -> (U a nil)] 35 | IPersistentCollection (IPersistentCollection a) 36 | IPersistentSet (IPersistentSet a)}) 37 | 38 | (alter-class PersistentHashSet [[a :variance :covariant]] 39 | :replace 40 | {Seqable (Seqable a) 41 | APersistentSet (APersistentSet a) 42 | IFn [Any -> (U a nil)] 43 | AFn [Any -> (U a nil)] 44 | IPersistentSet (IPersistentSet a) 45 | IPersistentCollection (IPersistentCollection a) 46 | IMeta (IMeta Any)}) 47 | 48 | (alter-class Associative [[a :variance :covariant] 49 | [b :variance :covariant]] 50 | :replace 51 | {IPersistentCollection (IPersistentCollection Any) 52 | Seqable (Seqable Any) 53 | ILookup (ILookup a b)}) 54 | 55 | (alter-class IMapEntry [[a :variance :covariant] 56 | [b :variance :covariant]]) 57 | 58 | (alter-class IPersistentMap [[a :variance :covariant] 59 | [b :variance :covariant]] 60 | :replace 61 | {IPersistentCollection (IPersistentCollection (IMapEntry a b)) 62 | Seqable (Seqable (IMapEntry a b)) 63 | ILookup (ILookup a b) 64 | Associative (Associative a b)}) 65 | 66 | (alter-class ASeq [[a :variance :covariant]] 67 | :replace 68 | {IPersistentCollection (IPersistentCollection a) 69 | Seqable (Seqable a) 70 | ISeq (ISeq a) 71 | IMeta (IMeta Any)}) 72 | 73 | (alter-class IPersistentStack [[a :variance :covariant]] 74 | :replace 75 | {IPersistentCollection (IPersistentCollection a) 76 | Seqable (Seqable a)}) 77 | 78 | (alter-class IPersistentVector [[a :variance :covariant]] 79 | :replace 80 | {IPersistentCollection (IPersistentCollection a) 81 | Seqable (Seqable a) 82 | IPersistentStack (IPersistentStack a) 83 | ILookup (ILookup Number a) 84 | Associative (Associative Number a)}) 85 | 86 | (alter-class APersistentMap [[a :variance :covariant] [b :variance :covariant]] 87 | :replace 88 | {IPersistentCollection (IPersistentCollection (IMapEntry a b)) 89 | IPersistentMap (IPersistentMap a b) 90 | Seqable (Seqable (IMapEntry a b)) 91 | IFn (All [d] 92 | (Fn [Any -> (U nil b)] 93 | [Any d -> (U b d)])) 94 | ILookup (ILookup a b) 95 | Associative (Associative Number a)}) 96 | 97 | (alter-class APersistentVector [[a :variance :covariant]] 98 | :replace 99 | {IPersistentCollection (IPersistentCollection a) 100 | Seqable (Seqable a) 101 | IPersistentVector (IPersistentVector a) 102 | IFn [Number -> a] 103 | IPersistentStack (IPersistentStack a) 104 | ILookup (ILookup Number a) 105 | Associative (Associative Number a)}) 106 | 107 | (alter-class PersistentVector [[a :variance :covariant]] 108 | :replace 109 | {APersistentVector (APersistentVector a) 110 | IPersistentCollection (IPersistentCollection a) 111 | Seqable (Seqable a) 112 | IPersistentVector (IPersistentVector a) 113 | IFn [Number -> a] 114 | IPersistentStack (IPersistentStack a) 115 | ILookup (ILookup Number a) 116 | IMeta (IMeta Any) 117 | Associative (Associative Number a)}) 118 | 119 | (alter-class Cons [[a :variance :covariant]] 120 | :replace 121 | {IPersistentCollection (IPersistentCollection a) 122 | ASeq (ASeq a) 123 | Seqable (Seqable a) 124 | ISeq (ISeq a) 125 | IMeta (IMeta Any)}) 126 | 127 | (alter-class IPersistentList [[a :variance :covariant]] 128 | :replace 129 | {IPersistentCollection (IPersistentCollection a) 130 | Seqable (Seqable a) 131 | IPersistentStack (IPersistentStack a)}) 132 | 133 | (alter-class PersistentList [[a :variance :covariant]] 134 | :replace 135 | {IPersistentCollection (IPersistentCollection a) 136 | ASeq (ASeq a) 137 | Seqable (Seqable a) 138 | IPersistentList (IPersistentList a) 139 | ISeq (ISeq a) 140 | IPersistentStack (IPersistentStack a) 141 | IMeta (IMeta Any)}) 142 | 143 | (alter-class Symbol [] 144 | :replace 145 | {IMeta (IMeta Any)}) 146 | 147 | (alter-class IDeref [[r :variance :covariant]]) 148 | 149 | 150 | (alter-class IRef [[w :variance :contravariant] 151 | [r :variance :covariant]] 152 | :replace 153 | {IDeref (IDeref r)}) 154 | 155 | (alter-class IReference [[w :variance :contravariant] 156 | [r :variance :covariant]] 157 | :replace 158 | {IMeta (IMeta Any)}) 159 | 160 | (alter-class AReference [[w :variance :contravariant] 161 | [r :variance :covariant]] 162 | :replace 163 | {IMeta (IMeta Any) 164 | IReference (IReference w r)}) 165 | 166 | (alter-class ARef [[w :variance :contravariant] 167 | [r :variance :covariant]] 168 | :replace 169 | {IRef (IRef w r) 170 | IMeta (IMeta Any) 171 | AReference (AReference w r) 172 | IDeref (IDeref r) 173 | IReference (IReference w r)}) 174 | 175 | (alter-class Var [] 176 | :replace 177 | {AReference (AReference Any Any) 178 | IReference (IReference Any Any) 179 | IRef (IRef Any Any) 180 | ARef (ARef Any Any) 181 | IDeref (IDeref Any) 182 | IMeta (IMeta Any)}) 183 | 184 | (alter-class Atom [[w :variance :contravariant] 185 | [r :variance :covariant]] 186 | :replace 187 | {IRef (IRef w r) 188 | IMeta (IMeta Any) 189 | AReference (AReference w r) 190 | ARef (ARef w r) 191 | IDeref (IDeref r) 192 | IReference (IReference w r)}) 193 | 194 | (alter-class LazySeq [[a :variance :covariant]] 195 | :replace 196 | {Seqable (Seqable a) 197 | ISeq (ISeq a) 198 | IMeta (IMeta Any) 199 | IPersistentCollection (IPersistentCollection a)}) 200 | 201 | -------------------------------------------------------------------------------- /notes/filter_ops.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | (declare subtype? compact) 4 | 5 | (defn overlap [t1 t2] 6 | true) 7 | 8 | (defn -filter [t i & [p]] 9 | {:pre [(Type? t) 10 | (or (symbol? i) 11 | (var? i)) 12 | (or (nil? p) 13 | (every? PathElem? p))] 14 | :post [(Filter? %)]} 15 | (if (or (= (->Top) t) (subtype? (type-of i) (parse-type 'clojure.lang.IRef))) 16 | (->Top) 17 | (->TypeFilter t p i))) 18 | 19 | (defn atomic-filter? [a] 20 | (or (TypeFilter? a) 21 | (NotTypeFilter? a) 22 | (TopFilter? a) 23 | (BotFilter? a))) 24 | 25 | (defn opposite? [f1 f2] 26 | {:pre [(Filter? f1) 27 | (Filter? f2)]} 28 | (cond 29 | (and (TypeFilter? f1) 30 | (NotTypeFilter? f2) 31 | (= (:path f1) 32 | (:path f2))) 33 | (let [{t1 :type id1 :id} f1 34 | {t2 :type id2 :id} f2] 35 | (and (= id1 id2) 36 | (subtype? t1 t2))) 37 | 38 | (and (NotTypeFilter? f1) 39 | (TypeFilter? f2) 40 | (= (:path f1) 41 | (:path f2))) 42 | (let [{t2 :type id2 :id} f1 43 | {t1 :type id1 :id} f2] 44 | (and (= id1 id2) 45 | (subtype? t1 t2))) 46 | 47 | :else false)) 48 | 49 | ;; is f1 implied by f2? 50 | (defn implied-atomic? [f1 f2] 51 | (if (= f1 f2) 52 | true 53 | (cond 54 | (OrFilter? f1) 55 | (boolean (some #(= % f2) (:fs f1))) 56 | 57 | (and (TypeFilter? f1) 58 | (TypeFilter? f2) 59 | (= (:path f1) 60 | (:path f2))) 61 | (and (= (:id f1) (:id f2)) 62 | (subtype? (:id f2) (:id f1))) 63 | 64 | (and (NotTypeFilter? f1) 65 | (NotTypeFilter? f2) 66 | (= (:path f1) 67 | (:path f2))) 68 | (and (= (:id f1) (:id f2)) 69 | (subtype? (:id f1) (:id f2))) 70 | 71 | :else false))) 72 | 73 | (defn -imp [p1 p2] 74 | (cond 75 | (BotFilter? p1) (->TopFilter) 76 | (TopFilter? p1) p2 77 | :else (->ImpFilter p1 p2))) 78 | 79 | (declare -and) 80 | 81 | (defn -or [& args] 82 | (letfn [(mk [& fs] 83 | (cond 84 | (empty? fs) (->BotFilter) 85 | (= 1 (count fs)) (first fs) 86 | :else (->OrFilter fs))) 87 | (distribute [args] 88 | (let [{ands :true others :false} (group-by AndFilter? args)] 89 | (if (empty? others) 90 | (apply mk others) 91 | (let [{elems :fs} (first ands)] 92 | (apply -and (for [a elems] 93 | (apply -or a (concat (rest ands) others))))))))] 94 | (loop [[f :as fs] args 95 | result nil] 96 | (if (empty? fs) 97 | (cond 98 | (empty? fs) (->BotFilter) 99 | (= 1 (count fs)) f 100 | :else (distribute (compact result true))) 101 | (cond 102 | (Top? f) f 103 | 104 | (OrFilter? f) 105 | (recur (concat (:fs f) (rest fs)) result) 106 | 107 | (BotFilter? f) 108 | (recur (rest fs) result) 109 | 110 | (some #(opposite? % f) (concat (rest fs) result)) 111 | (->TopFilter) 112 | 113 | ;TODO Is this translated properly? Rep-seq? check filter-ops.rkt 114 | (some #(or (= % f) (implied-atomic? % f)) result) 115 | (recur (rest fs) result) 116 | 117 | :else (recur (rest fs) (cons f result))))))) 118 | 119 | (defn -and [& args] 120 | (letfn [(mk [& fs] 121 | (cond 122 | (empty? fs) (->TopFilter) 123 | (= 1 (count fs)) (first fs) 124 | :else (->AndFilter fs)))] 125 | (loop [fs (set args) ;TODO remove-duplicates? is set good enough? 126 | result nil] 127 | (if (empty? fs) 128 | (cond 129 | (empty? result) (->TopFilter) 130 | (= 1 (count result)) (first result) 131 | ;; don't think this is useful here 132 | (= 2 (count result)) (let [[f1 f2] result] 133 | (if (opposite? f1 f2) 134 | (->BotFilter) 135 | (if (= f1 f2) 136 | f1 137 | (apply mk (compact (list f1 f2) false))))) 138 | :else 139 | ;; first, remove anything implied by the atomic propositions 140 | ;; We commonly see: (And (Or P Q) (Or P R) (Or P S) ... P), which this fixes 141 | (let [{atomic :true not-atomic :false} (group-by atomic-filter? result) 142 | not-atomic* (for [p not-atomic 143 | :when (not (some #(implied-atomic? p %) atomic))] 144 | p)] 145 | ;; `compact' takes care of implications between atomic props 146 | (apply mk (compact (concat not-atomic* atomic) false)))) 147 | (let [[fs1] fs] 148 | (cond 149 | (BotFilter? fs1) fs1 150 | (AndFilter? fs1) (let [{fs* :fs} fs1] 151 | (recur (rest fs) (concat fs* result))) 152 | (TopFilter? fs1) (recur (rest fs) result) 153 | (some #(opposite? % fs1) (concat (rest fs) result)) (->BotFilter) 154 | 155 | ;;TODO is = enough? see Rep-seq 156 | (some #(or (= % fs1) 157 | (implied-atomic? fs1 %)) 158 | result) 159 | (recur (rest fs) result) 160 | 161 | :else (recur (rest fs) (cons fs1 result)))))))) 162 | 163 | (defn compact [props or?] 164 | {:pre [(every? Filter? props) 165 | (or (true? or?) 166 | (false? or?))] 167 | :post [(every? Filter? %)]} 168 | (let [tf-map (atom {}) 169 | ntf-map (atom {})] 170 | (loop [[props1 :as props] props 171 | others nil] 172 | (if (empty? props) 173 | (concat others 174 | (vals @tf-map) 175 | (vals @ntf-map)) 176 | (cond 177 | (and (TypeFilter? props1) 178 | or?) 179 | (do 180 | (swap! tf-map #(update-in % [(list (:type props1) 181 | (:id props1))] 182 | (fn [p] 183 | (or (and (nil? p) props1) 184 | (do 185 | (assert (TypeFilter? p)) 186 | (-filter (Un [(:type props1) (:type p)]) 187 | (:id props1) 188 | (:path props1))))))) 189 | (recur (rest props) others)) 190 | 191 | (and (TypeFilter? props1) 192 | (not or?)) 193 | (let [f1 (:path props1) 194 | tf (@tf-map (list f1 (:id props1)))] 195 | (cond 196 | (and (TypeFilter? tf) 197 | (not (overlap (:type props1) (:type tf)))) 198 | ;; we're in an And, and we got two types for the same path that do not overlap 199 | (list (->BotFilter)) 200 | 201 | (TypeFilter? tf) 202 | (do (swap! tf-map #(assoc % (list f1 (:id props1)) 203 | (-filter (restrict (:type props1) (:type tf)) 204 | (:id props1) f1))) 205 | (recur (rest props) others)) 206 | 207 | :else 208 | (do (swap! tf-map #(assoc % (list f1 (:id props1)) 209 | (-filter (:type props1) (:id props1) f1))) 210 | (recur (rest props) others)))) 211 | (and (NotTypeFilter? props1) 212 | (not or?)) 213 | (do (swap! ntf-map 214 | #(update-in % [(list f1 (:id props1))] 215 | (fn [p] 216 | (or (and (nil? p) props1) 217 | (do (assert (NotTypeFilter? p)) 218 | (-not-filter (Un [(:type props1) (:type p)]) 219 | (:id props1) f1)))))) 220 | (recur (rest props) others)) 221 | 222 | :else (recur (rest props) (cons props1 others))))))) 223 | 224 | (defn restrict [t1 t2] 225 | (cond 226 | (subtype? t1 t2) t1 ;; already a subtype 227 | -------------------------------------------------------------------------------- /src/typed/frees.clj: -------------------------------------------------------------------------------- 1 | (set! *warn-on-reflection* true) 2 | 3 | (in-ns 'typed.core) 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Collecting frees 7 | 8 | (def variance-map? (hash-c? symbol? variance?)) 9 | 10 | (declare ^:dynamic *frees-mode* frees-in) 11 | 12 | (defn fv-variances 13 | "Map of frees to their variances" 14 | [t] 15 | {:post [(variance-map? %)]} 16 | (binding [*frees-mode* ::frees] 17 | (frees-in t))) 18 | 19 | (defn idx-variances 20 | "Map of indexes to their variances" 21 | [t] 22 | {:post [(variance-map? %)]} 23 | (binding [*frees-mode* ::idxs] 24 | (frees-in t))) 25 | 26 | (defn fv 27 | "All frees in type" 28 | [t] 29 | {:post [((set-c? symbol?) %)]} 30 | (set (keys (fv-variances t)))) 31 | 32 | (defn fi 33 | "All index variables in type (dotted bounds, etc.)" 34 | [t] 35 | {:post [((set-c? symbol?) %)]} 36 | (set (keys (idx-variances t)))) 37 | 38 | (defn flip-variances [vs] 39 | {:pre [(variance-map? vs)]} 40 | (into {} (for [[k vari] vs] 41 | [k (case vari 42 | :covariant :contravariant 43 | :contravariant :covariant 44 | vari)]))) 45 | 46 | (defn combine-frees [& frees] 47 | {:pre [(every? variance-map? frees)] 48 | :post [(variance-map? %)]} 49 | (into {} 50 | (apply merge-with (fn [old-vari new-vari] 51 | (cond 52 | (= old-vari new-vari) old-vari 53 | (= old-vari :dotted) new-vari 54 | (= new-vari :dotted) old-vari 55 | (= old-vari :constant) new-vari 56 | (= new-vari :constant) old-vari 57 | :else :invariant)) 58 | frees))) 59 | 60 | (derive ::frees ::any-var) 61 | (derive ::idxs ::any-var) 62 | 63 | (def ^:dynamic *frees-mode* nil) 64 | (set-validator! #'*frees-mode* #(or (= ::frees %) 65 | (= ::idxs %) 66 | (nil? %))) 67 | 68 | (declare frees) 69 | 70 | (defn frees-in [t] 71 | {:post [(variance-map? %)]} 72 | (frees t)) 73 | 74 | (defmulti frees (fn [t] [*frees-mode* (class t)])) 75 | 76 | (defmethod frees [::any-var Result] 77 | [{:keys [t fl o]}] 78 | (combine-frees (frees t) 79 | (frees fl) 80 | (frees o))) 81 | 82 | ;; Filters 83 | 84 | (defmethod frees [::any-var FilterSet] 85 | [{:keys [then else]}] 86 | (combine-frees (frees then) 87 | (frees else))) 88 | 89 | (defmethod frees [::any-var TypeFilter] 90 | [{:keys [type]}] 91 | (frees type)) 92 | 93 | (defmethod frees [::any-var NotTypeFilter] 94 | [{:keys [type]}] 95 | (frees type)) 96 | 97 | (defmethod frees [::any-var ImpFilter] 98 | [{:keys [a c]}] 99 | (combine-frees (frees a) 100 | (frees c))) 101 | 102 | (defmethod frees [::any-var AndFilter] 103 | [{:keys [fs]}] 104 | (apply combine-frees (mapv frees fs))) 105 | 106 | (defmethod frees [::any-var OrFilter] 107 | [{:keys [fs]}] 108 | (apply combine-frees (mapv frees fs))) 109 | 110 | (defmethod frees [::any-var TopFilter] [t] {}) 111 | (defmethod frees [::any-var BotFilter] [t] {}) 112 | 113 | ;; Objects 114 | 115 | (defmethod frees [::any-var Path] 116 | [{:keys [path]}] 117 | (apply combine-frees (mapv frees path))) 118 | 119 | (defmethod frees [::any-var EmptyObject] [t] {}) 120 | (defmethod frees [::any-var NoObject] [t] {}) 121 | (defmethod frees [::any-var KeyPE] [t] {}) 122 | 123 | 124 | (defmethod frees [::frees F] 125 | [{:keys [name] :as t}] 126 | {name :covariant}) 127 | 128 | (defmethod frees [::idxs F] [t] {}) 129 | 130 | (defmethod frees [::any-var B] [t] {}) 131 | (defmethod frees [::any-var CountRange] [t] {}) 132 | (defmethod frees [::any-var Value] [t] {}) 133 | (defmethod frees [::any-var AnyValue] [t] {}) 134 | (defmethod frees [::any-var Top] [t] {}) 135 | (defmethod frees [::any-var Name] [t] {}) 136 | 137 | (defmethod frees [::any-var DataType] 138 | [{:keys [fields poly?]}] 139 | (apply combine-frees 140 | (mapv frees (concat (vals fields) poly?)))) 141 | 142 | (defmethod frees [::any-var HeterogeneousList] 143 | [{:keys [types]}] 144 | (apply combine-frees (mapv frees types))) 145 | 146 | (defmethod frees [::any-var App] 147 | [{:keys [rator rands]}] 148 | (apply combine-frees (mapv frees (cons rator rands)))) 149 | 150 | (defmethod frees [::any-var TApp] 151 | [{:keys [rator rands]}] 152 | (apply combine-frees 153 | (let [^TypeFn 154 | tfn (loop [rator rator] 155 | (cond 156 | (F? rator) (when-let [bnds (free-with-name-bnds (.name ^F rator))] 157 | (.higher-kind bnds)) 158 | (Name? rator) (if (= declared-name-type (@TYPE-NAME-ENV (.id ^Name rator))) 159 | (recur (get-declared-kind (.id ^Name rator))) 160 | (recur (resolve-Name rator))) 161 | (TypeFn? rator) rator 162 | :else (throw (Exception. (error-msg "NYI case " (class rator) (unparse-type rator)))))) 163 | _ (assert (TypeFn? tfn))] 164 | (mapv (fn [[v arg-vs]] 165 | (case v 166 | :covariant arg-vs 167 | :contravariant (flip-variances arg-vs) 168 | :invariant (into {} (for [[k _] arg-vs] 169 | [k :invariant])))) 170 | (map vector (.variances tfn) (map frees rands)))))) 171 | 172 | (defmethod frees [::any-var PrimitiveArray] 173 | [{:keys [input-type output-type]}] 174 | (combine-frees (flip-variances (frees input-type)) 175 | (frees output-type))) 176 | 177 | (defmethod frees [::any-var HeterogeneousSeq] 178 | [{:keys [types]}] 179 | (apply combine-frees (mapv frees types))) 180 | 181 | (defmethod frees [::any-var HeterogeneousMap] 182 | [{:keys [types]}] 183 | (apply combine-frees (mapv frees (concat (keys types) (vals types))))) 184 | 185 | (defmethod frees [::any-var HeterogeneousVector] 186 | [{:keys [types]}] 187 | (apply combine-frees (mapv frees types))) 188 | 189 | (defmethod frees [::any-var Intersection] 190 | [{:keys [types]}] 191 | (apply combine-frees (mapv frees types))) 192 | 193 | (defmethod frees [::any-var Union] 194 | [{:keys [types]}] 195 | (apply combine-frees (mapv frees types))) 196 | 197 | (defmethod frees [::any-var FnIntersection] 198 | [{:keys [types]}] 199 | (apply combine-frees (mapv frees types))) 200 | 201 | (defmethod frees [::frees Function] 202 | [{:keys [dom rng rest drest kws]}] 203 | (apply combine-frees (concat (mapv (comp flip-variances frees) 204 | (concat dom 205 | (when rest 206 | [rest]) 207 | (when kws 208 | [(vals kws)]))) 209 | [(frees rng)] 210 | (when drest 211 | [(dissoc (-> (:pre-type drest) frees flip-variances) 212 | (:name drest))])))) 213 | 214 | (defmethod frees [::idxs Function] 215 | [{:keys [dom rng rest drest kws]}] 216 | (apply combine-frees (concat (mapv (comp flip-variances frees) 217 | (concat dom 218 | (when rest 219 | [rest]) 220 | (when kws 221 | (vals kws)))) 222 | [(frees rng)] 223 | (when drest 224 | (let [{:keys [name pre-type]} drest] 225 | [{name :contravariant} 226 | (-> pre-type 227 | frees flip-variances)]))))) 228 | 229 | (defmethod frees [::any-var RClass] 230 | [t] 231 | (let [varis (:variances t) 232 | args (:poly? t)] 233 | (assert (= (count args) (count varis))) 234 | (apply combine-frees (for [[arg va] (map vector args varis)] 235 | (case va 236 | :covariant (frees arg) 237 | :contravariant (flip-variances (frees arg)) 238 | :invariant (let [fvs (frees arg)] 239 | (into {} 240 | (for [[k _] fvs] 241 | [k :invariant])))))))) 242 | 243 | (defmethod frees [::any-var Scope] 244 | [{:keys [body]}] 245 | (frees body)) 246 | 247 | ;FIXME Type variable bounds should probably be checked for frees 248 | (defmethod frees [::any-var TypeFn] 249 | [{:keys [scope]}] 250 | (frees scope)) 251 | 252 | (defmethod frees [::any-var Poly] 253 | [{:keys [scope]}] 254 | (frees scope)) 255 | 256 | (defmethod frees [::any-var PolyDots] 257 | [{:keys [nbound scope]}] 258 | (frees scope)) 259 | 260 | -------------------------------------------------------------------------------- /src/typed/promote_demote.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;FIXME use fold! 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Variable Elim 7 | 8 | (declare promote demote) 9 | 10 | (defn promote-var [T V] 11 | {:pre [(Type? T) 12 | (set? V) 13 | (every? symbol? V)] 14 | :post [(Type? %)]} 15 | (promote T V)) 16 | 17 | (defn demote-var [T V] 18 | {:pre [(AnyType? T) 19 | (set? V) 20 | (every? symbol? V)] 21 | :post [(Type? %)]} 22 | (demote T V)) 23 | 24 | (defmulti promote 25 | "Eliminate all variables V in t by promotion" 26 | (fn [T V] 27 | {:pre [(AnyType? T) 28 | (set? V) 29 | (every? symbol? V)]} 30 | (class T))) 31 | 32 | (defmulti demote 33 | "Eliminate all variables V in T by demotion" 34 | (fn [T V] 35 | {:pre [(AnyType? T) 36 | (set? V) 37 | (every? symbol? V)]} 38 | (class T))) 39 | 40 | (defmethod promote PrimitiveArray 41 | [T V] 42 | (-> T 43 | (update-in [:input-type] #(promote % V)) 44 | (update-in [:output-type] #(promote % V)))) 45 | 46 | (defmethod demote PrimitiveArray 47 | [T V] 48 | (-> T 49 | (update-in [:input-type] #(demote % V)) 50 | (update-in [:output-type] #(demote % V)))) 51 | 52 | (defmethod promote F 53 | [{:keys [name] :as T} V] 54 | (if (V name) 55 | -any 56 | T)) 57 | 58 | (defmethod demote F 59 | [{:keys [name] :as T} V] 60 | (if (V name) 61 | (Bottom) 62 | T)) 63 | 64 | (defmethod promote HeterogeneousMap 65 | [T V] 66 | (-> T 67 | (update-in [:types] #(into {} 68 | (for [[k v] %] 69 | [k (promote v V)]))))) 70 | 71 | (defmethod demote HeterogeneousMap 72 | [T V] 73 | (-> T 74 | (update-in [:types] #(into {} 75 | (for [[k v] %] 76 | [k (demote v V)]))))) 77 | 78 | (defmethod promote HeterogeneousVector 79 | [T V] 80 | (-> T 81 | (update-in [:types] #(mapv promote % (repeat V))))) 82 | 83 | (defmethod demote HeterogeneousVector 84 | [T V] 85 | (-> T 86 | (update-in [:types] #(mapv demote % (repeat V))))) 87 | 88 | (defmethod promote HeterogeneousList 89 | [T V] 90 | (-> T 91 | (update-in [:types] #(apply list (mapv promote % (repeat V)))))) 92 | 93 | (defmethod demote HeterogeneousList 94 | [T V] 95 | (-> T 96 | (update-in [:types] #(apply list (mapv demote % (repeat V)))))) 97 | 98 | (defmethod promote Value [T V] T) 99 | (defmethod demote Value [T V] T) 100 | 101 | (defmethod promote DataType [T V] 102 | (-> T 103 | (update-in [:poly?] #(when % 104 | (mapv promote % (repeat V)))) 105 | (update-in [:fields] #(apply array-map 106 | (apply concat 107 | (for [[k v] %] 108 | [k (promote v V)])))))) 109 | (defmethod demote DataType [T V] 110 | (-> T 111 | (update-in [:poly?] #(when % 112 | (mapv demote % (repeat V)))) 113 | (update-in [:fields] #(apply array-map 114 | (apply concat 115 | (for [[k v] %] 116 | [k (demote v V)])))))) 117 | 118 | (defmethod promote Name [T V] T) 119 | (defmethod demote Name [T V] T) 120 | 121 | (defmethod promote Top [T V] T) 122 | (defmethod demote Top [T V] T) 123 | 124 | (defmethod promote TApp 125 | [T V] 126 | (-> T 127 | (update-in [:rator] #(promote % V)) 128 | (update-in [:rands] (fn [rands] (mapv #(promote % V) rands))))) 129 | 130 | (defmethod demote TApp 131 | [T V] 132 | (-> T 133 | (update-in [:rator] #(demote % V)) 134 | (update-in [:rands] (fn [rands] (mapv #(demote % V) rands))))) 135 | 136 | (defmethod promote App 137 | [T V] 138 | (-> T 139 | (update-in [:rator] #(promote % V)) 140 | (update-in [:rands] (fn [rands] (mapv #(promote % V) rands))))) 141 | 142 | (defmethod demote App 143 | [T V] 144 | (-> T 145 | (update-in [:rator] #(demote % V)) 146 | (update-in [:rands] (fn [rands] (mapv #(demote % V) rands))))) 147 | 148 | (defmethod promote Union 149 | [T V] 150 | (-> T 151 | (update-in [:types] #(set (mapv promote % (repeat V)))))) 152 | 153 | (defmethod demote Union 154 | [T V] 155 | (-> T 156 | (update-in [:types] #(set (mapv demote % (repeat V)))))) 157 | 158 | (defmethod promote Intersection 159 | [T V] 160 | (-> T 161 | (update-in [:types] #(mapv promote % (repeat V))))) 162 | 163 | (defmethod demote Intersection 164 | [T V] 165 | (-> T 166 | (update-in [:types] #(mapv demote % (repeat V))))) 167 | 168 | (defmethod promote FnIntersection 169 | [T V] 170 | (-> T 171 | (update-in [:types] #(mapv promote % (repeat V))))) 172 | 173 | (defmethod demote FnIntersection 174 | [T V] 175 | (-> T 176 | (update-in [:types] #(mapv demote % (repeat V))))) 177 | 178 | (defmethod promote RClass 179 | [T V] 180 | (let [pmt #(promote % V)] 181 | (-> T 182 | (update-in [:poly?] #(when % 183 | (mapv pmt %))) 184 | (update-in [:replacements] #(into {} (for [[k v] %] 185 | [k (pmt v)])))))) 186 | 187 | (defmethod demote RClass 188 | [T V] 189 | (let [dmt #(demote % V)] 190 | (-> T 191 | (update-in [:poly?] #(when % 192 | (mapv dmt %))) 193 | (update-in [:replacements] #(into {} (for [[k v] %] 194 | [k (dmt v)])))))) 195 | 196 | (defmethod promote Poly 197 | [{:keys [nbound] :as T} V] 198 | (let [free-names (Poly-free-names* T) 199 | names (repeatedly nbound gensym) 200 | pmt-body (promote (Poly-body* names T) V)] 201 | (Poly* names 202 | (Poly-bbnds* names T) 203 | pmt-body 204 | free-names))) 205 | 206 | (defmethod demote Poly 207 | [{:keys [nbound] :as T} V] 208 | (let [free-names (Poly-free-names* T) 209 | names (repeatedly nbound gensym) 210 | dem-body (demote (Poly-body* names T) V)] 211 | (Poly* names 212 | (Poly-bbnds* names T) 213 | dem-body 214 | free-names))) 215 | 216 | (defmethod promote Mu 217 | [T V] 218 | (let [name (gensym) 219 | body (Mu-body* name T)] 220 | (Mu* name (promote body V)))) 221 | 222 | (defmethod demote Mu 223 | [T V] 224 | (let [name (gensym) 225 | body (Mu-body* name T)] 226 | (Mu* name (demote body V)))) 227 | 228 | (defmethod promote Function 229 | [{:keys [dom rng rest drest kws] :as T} V] 230 | (let [pmt #(promote % V) 231 | dmt #(demote % V) 232 | dmt-kw #(into {} (for [[k v] %] 233 | [k (dmt v)]))] 234 | (cond 235 | ;if filter contains V, give up 236 | (seq (set/intersection V (Result-filter* rng))) (->TopFunction) 237 | 238 | ;if dotted bound is in V, transfer to rest args 239 | (and drest (V (:name drest))) 240 | (-> T 241 | (update-in [:dom] #(mapv dmt %)) 242 | (update-in [:rng] pmt) 243 | (assoc :rest (dmt (:pre-type drest))) 244 | (assoc :drest nil) 245 | (assoc :kws (when kws 246 | (-> kws 247 | (update-in [:mandatory] dmt-kw) 248 | (update-in [:optional] dmt-kw))))) 249 | 250 | :else 251 | (-> T 252 | (update-in [:dom] #(mapv dmt %)) 253 | ;we know no filters contain V 254 | (update-in [:rng] #(-> % 255 | (update-in [:t] pmt))) 256 | (update-in [:rest] #(when % 257 | (dmt %))) 258 | (update-in [:drest] #(when % 259 | (-> % 260 | (update-in [:pre-type] dmt)))) 261 | (update-in [:kws] #(when % 262 | (-> % 263 | (update-in [:mandatory] dmt-kw) 264 | (update-in [:optional] dmt-kw)))))))) 265 | 266 | (defmethod demote Function 267 | [{:keys [dom rng rest drest kws] :as T} V] 268 | (let [pmt #(promote % V) 269 | dmt #(demote % V) 270 | pmt-kw #(into {} (for [[k v] %] 271 | [k (pmt v)]))] 272 | (cond 273 | ;if filter contains V, give up 274 | (seq (set/intersection V (Result-filter* rng))) (->TopFunction) 275 | 276 | ;if dotted bound is in V, transfer to rest args 277 | (and drest (V (:name drest))) 278 | (-> T 279 | (update-in [:dom] #(mapv pmt %)) 280 | (update-in [:rng] dmt) 281 | (assoc :rest (pmt (:pre-type drest))) 282 | (assoc :drest nil) 283 | (assoc :kws (when kws 284 | (-> kws 285 | (update-in [:mandatory] pmt-kw) 286 | (update-in [:optional] pmt-kw))))) 287 | 288 | :else 289 | (-> T 290 | (update-in [:dom] #(mapv pmt %)) 291 | ;we know no filters contain V 292 | (update-in [:rng] #(-> % 293 | (update-in [:t] pmt))) 294 | (update-in [:rest] #(when % 295 | (pmt %))) 296 | (update-in [:drest] #(when % 297 | (-> % 298 | (update-in [:pre-type] pmt)))) 299 | (update-in [:kws] #(when % 300 | (-> % 301 | (update-in [:mandatory] pmt-kw) 302 | (update-in [:optional] pmt-kw)))))))) 303 | -------------------------------------------------------------------------------- /src/typed/tvar_rep.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;; Variable rep 5 | 6 | (defn add-scopes [n t] 7 | "Wrap type in n Scopes" 8 | {:pre [(nat? n) 9 | (Type? t)]} 10 | (doall 11 | (last 12 | (take (inc n) (iterate ->Scope t))))) 13 | 14 | (defn remove-scopes 15 | "Unwrap n Scopes" 16 | [n sc] 17 | {:pre [(nat? n) 18 | (or (zero? n) 19 | (Scope? sc))] 20 | :post [(or (Scope? %) (Type? %))]} 21 | (doall 22 | (last 23 | (take (inc n) (iterate (fn [t] 24 | (assert (Scope? t) "Tried to remove too many Scopes") 25 | (:body t)) 26 | sc))))) 27 | 28 | (defn- rev-indexed 29 | "'(a b c) -> '([2 a] [1 b] [0 c])" 30 | [c] 31 | (map vector (iterate dec (dec (count c))) c)) 32 | 33 | (derive ::abstract-many fold-rhs-default) 34 | 35 | (add-fold-case ::abstract-many 36 | F 37 | (fn [{name* :name :as t} {{:keys [name count outer sb]} :locals}] 38 | (if (= name name*) 39 | (->B (+ count outer)) 40 | t))) 41 | 42 | (add-fold-case ::abstract-many 43 | Function 44 | (fn [{:keys [dom rng rest drest kws]} {{:keys [name count outer sb]} :locals}] 45 | (assert (not kws)) 46 | (->Function (map sb dom) 47 | (sb rng) 48 | (when rest (sb rest)) 49 | (when drest 50 | (->DottedPretype (sb (:pre-type drest)) 51 | (if (= (:name drest) name) 52 | (+ count outer) 53 | (:name drest)))) 54 | nil))) 55 | 56 | (add-fold-case ::abstract-many 57 | Mu 58 | (fn [{:keys [scope]} {{:keys [name count type outer name-to]} :locals}] 59 | (let [body (remove-scopes 1 scope)] 60 | (->Mu (->Scope (name-to name count type (inc outer) body)))))) 61 | 62 | (add-fold-case ::abstract-many 63 | PolyDots 64 | (fn [{bbnds* :bbnds n :nbound body* :scope} {{:keys [name count type outer name-to]} :locals}] 65 | (let [rs #(remove-scopes n %) 66 | body (rs body*) 67 | bbnds (mapv #(visit-bounds % rs) bbnds*) 68 | as #(add-scopes n (name-to name count type (+ n outer) %))] 69 | (->PolyDots n 70 | (mapv #(visit-bounds % rs) bbnds) 71 | (as body))))) 72 | 73 | (add-fold-case ::abstract-many 74 | Poly 75 | (fn [{bbnds* :bbnds n :nbound body* :scope :as poly} {{:keys [name count type outer name-to]} :locals}] 76 | (let [rs #(remove-scopes n %) 77 | body (rs body*) 78 | bbnds (mapv #(visit-bounds % rs) bbnds*) 79 | as #(add-scopes n (name-to name count type (+ n outer) %))] 80 | (->Poly n 81 | (mapv #(visit-bounds % as) bbnds) 82 | (as body) 83 | (Poly-free-names* poly))))) 84 | 85 | (add-fold-case ::abstract-many 86 | TypeFn 87 | (fn [{bbnds* :bbnds n :nbound body* :scope :keys [variances]} {{:keys [name count type outer name-to]} :locals}] 88 | (let [rs #(remove-scopes n %) 89 | body (rs body*) 90 | bbnds (mapv #(visit-bounds % rs) bbnds*) 91 | as #(add-scopes n (name-to name count type (+ n outer) %))] 92 | (->TypeFn n 93 | variances 94 | (mapv #(visit-bounds % as) bbnds) 95 | (as body))))) 96 | 97 | (defn abstract-many 98 | "Names Type -> Scope^n where n is (count names)" 99 | [names ty] 100 | {:pre [(every? symbol? names) 101 | ((some-fn Type? TypeFn?) ty)]} 102 | (letfn [(name-to 103 | ([name count type] (name-to name count type 0 type)) 104 | ([name count type outer ty] 105 | (letfn [(sb [t] (name-to name count type outer t))] 106 | (fold-rhs ::abstract-many 107 | {:type-rec sb 108 | :filter-rec (sub-f sb ::abstract-many) 109 | :object-rec (sub-o sb ::abstract-many) 110 | :locals {:name name 111 | :count count 112 | :outer outer 113 | :sb sb 114 | :name-to name-to}} 115 | ty))))] 116 | (if (empty? names) 117 | ty 118 | (let [n (count names)] 119 | (loop [ty ty 120 | names names 121 | count (dec n)] 122 | (if (zero? count) 123 | (add-scopes n (name-to (first names) 0 ty)) 124 | (recur (name-to (first names) count ty) 125 | (next names) 126 | (dec count)))))))) 127 | 128 | (derive ::instantiate-many fold-rhs-default) 129 | 130 | (add-fold-case ::instantiate-many 131 | B 132 | (fn [{:keys [idx] :as t} {{:keys [count outer image sb]} :locals}] 133 | (if (= (+ count outer) idx) 134 | (->F image) 135 | t))) 136 | 137 | (add-fold-case ::instantiate-many 138 | Function 139 | (fn [{:keys [dom rng rest drest kws]} {{:keys [count outer image sb]} :locals}] 140 | (assert (not kws)) 141 | (->Function (map sb dom) 142 | (sb rng) 143 | (when rest 144 | (sb rest)) 145 | (when drest 146 | (->DottedPretype (sb (:pre-type drest)) 147 | (let [{:keys [name]} drest] 148 | (assert (nat? name)) 149 | (if (= (+ count outer) name) 150 | image 151 | name)))) 152 | nil))) 153 | 154 | (add-fold-case ::instantiate-many 155 | Mu 156 | (fn [{:keys [scope]} {{:keys [replace count outer image sb type]} :locals}] 157 | (let [body (remove-scopes 1 scope)] 158 | (->Mu (->Scope (replace image count type (inc outer) body)))))) 159 | 160 | (add-fold-case ::instantiate-many 161 | PolyDots 162 | (fn [{bbnds* :bbnds n :nbound body* :scope} {{:keys [replace count outer image sb type]} :locals}] 163 | (let [rs #(remove-scopes n %) 164 | body (rs body*) 165 | bbnds (mapv #(visit-bounds % rs) bbnds*) 166 | as #(add-scopes n (replace image count type (+ n outer) %))] 167 | (->PolyDots n 168 | (mapv #(visit-bounds % as) bbnds) 169 | (as body))))) 170 | 171 | (add-fold-case ::instantiate-many 172 | Poly 173 | (fn [{bbnds* :bbnds n :nbound body* :scope :as poly} {{:keys [replace count outer image sb type]} :locals}] 174 | (let [rs #(remove-scopes n %) 175 | body (rs body*) 176 | bbnds (mapv #(visit-bounds % rs) bbnds*) 177 | as #(add-scopes n (replace image count type (+ n outer) %))] 178 | (->Poly n 179 | (mapv #(visit-bounds % as) bbnds) 180 | (as body) 181 | (Poly-free-names* poly))))) 182 | 183 | (add-fold-case ::instantiate-many 184 | TypeFn 185 | (fn [{bbnds* :bbnds n :nbound body* :scope :keys [variances]} {{:keys [replace count outer image sb type]} :locals}] 186 | (let [rs #(remove-scopes n %) 187 | body (rs body*) 188 | bbnds (mapv #(visit-bounds % rs) bbnds*) 189 | as #(add-scopes n (replace image count type (+ n outer) %))] 190 | (->TypeFn n 191 | variances 192 | (mapv #(visit-bounds % as) bbnds) 193 | (as body))))) 194 | 195 | (defn instantiate-many 196 | "instantiate-many : List[Symbols] Scope^n -> Type 197 | Instantiate de Bruijn indices in sc to frees named by 198 | images, preserving upper/lower bounds" 199 | [images sc] 200 | {:pre [(every? symbol? images) 201 | (or (Scope? sc) 202 | (empty? images))] 203 | :post [((some-fn Type? TypeFn?) %)]} 204 | (letfn [(replace 205 | ([image count type] (replace image count type 0 type)) 206 | ([image count type outer ty] 207 | (letfn [(sb [t] (replace image count type outer t))] 208 | (let [sf (sub-f sb ::instantiate-many)] 209 | (fold-rhs ::instantiate-many 210 | {:type-rec sb 211 | :filter-rec sf 212 | :object-rec (sub-o sb ::instantiate-many) 213 | :locals {:count count 214 | :outer outer 215 | :image image 216 | :sb sb 217 | :type type 218 | :replace replace}} 219 | ty)))))] 220 | (if (empty? images) 221 | sc 222 | (let [n (count images)] 223 | (loop [ty (remove-scopes n sc) 224 | images images 225 | count (dec n)] 226 | (if (zero? count) 227 | (replace (first images) 0 ty) 228 | (recur (replace (first images) count ty) 229 | (next images) 230 | (dec count)))))))) 231 | 232 | (defn abstract [name ty] 233 | "Make free name bound" 234 | {:pre [(symbol? name) 235 | (Type? ty)]} 236 | (abstract-many [name] ty)) 237 | 238 | (defn instantiate [f sc] 239 | "Instantiate bound name to free" 240 | {:pre [(symbol? f) 241 | (Scope? sc)]} 242 | (instantiate-many [f] sc)) 243 | 244 | -------------------------------------------------------------------------------- /src/typed/unparse.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'typed.core) 2 | 3 | (def ^:dynamic *next-nme* 0) ;stupid readable variables 4 | 5 | (declare unparse-type* unparse-object unparse-filter-set unparse-filter) 6 | 7 | (defn unparse-type [t] 8 | (if-let [nsym (-> t meta :source-Name)] 9 | nsym 10 | (unparse-type* t))) 11 | 12 | (defmulti unparse-type* class) 13 | (defn unp [t] (prn (unparse-type t))) 14 | 15 | (defmethod unparse-type* Top [_] 'Any) 16 | (defmethod unparse-type* Name [{:keys [id]}] id) 17 | (defmethod unparse-type* AnyValue [_] 'AnyValue) 18 | 19 | (defmethod unparse-type* Projection 20 | [{:keys [ts] :as t}] 21 | (let [{:keys [fsyn]} (meta t)] 22 | (list 'Project fsyn (mapv unparse-type ts)))) 23 | 24 | (defmethod unparse-type* DottedPretype 25 | [{:keys [pre-type name]}] 26 | (list 'DottedPretype (unparse-type pre-type) name)) 27 | 28 | (defmethod unparse-type* CountRange [{:keys [lower upper]}] 29 | (cond 30 | (= lower upper) (list 'ExactCount lower) 31 | :else (list* 'CountRange lower (when upper [upper])))) 32 | 33 | (defmethod unparse-type* App 34 | [{:keys [rator rands]}] 35 | (list* (unparse-type rator) (mapv unparse-type rands))) 36 | 37 | (defmethod unparse-type* TApp 38 | [{:keys [rator rands] :as tapp}] 39 | (cond 40 | ;perform substitution if obvious 41 | ;(TypeFn? rator) (unparse-type (resolve-tapp tapp)) 42 | :else 43 | (list* (unparse-type rator) (mapv unparse-type rands)))) 44 | 45 | (defmethod unparse-type* Result 46 | [{:keys [t]}] 47 | (unparse-type t)) 48 | 49 | (defmethod unparse-type* F 50 | [{:keys [name]}] 51 | (or (some (fn [[sym {{fname :name} :F}]] 52 | (when (= name fname) 53 | sym)) 54 | *free-scope*) 55 | name)) 56 | 57 | (defmethod unparse-type* PrimitiveArray 58 | [{:keys [input-type output-type]}] 59 | (list 'Array (unparse-type input-type) (unparse-type output-type))) 60 | 61 | (defmethod unparse-type* B 62 | [{:keys [idx]}] 63 | (list 'B idx)) 64 | 65 | (defmethod unparse-type* Union 66 | [{types :types :as u}] 67 | (cond 68 | ; Prefer the user provided Name for this type. Needs more thinking? 69 | ;(-> u meta :from-name) (-> u meta :from-name) 70 | (seq types) (list* 'U (doall (map unparse-type types))) 71 | :else 'Nothing)) 72 | 73 | (defmethod unparse-type* FnIntersection 74 | [{types :types}] 75 | (list* 'Fn (doall (map unparse-type types)))) 76 | 77 | (defmethod unparse-type* Intersection 78 | [{types :types}] 79 | (list* 'I (doall (map unparse-type types)))) 80 | 81 | (defmethod unparse-type* Function 82 | [{:keys [dom rng rest drest]}] 83 | (vec (concat (doall (map unparse-type dom)) 84 | (when rest 85 | [(unparse-type rest) '*]) 86 | (when drest 87 | (let [{:keys [pre-type name]} drest] 88 | [(unparse-type pre-type) '... name])) 89 | (let [{:keys [t fl o]} rng] 90 | (concat ['-> (unparse-type t)] 91 | (when (not (and ((some-fn TopFilter? BotFilter?) (:then fl)) 92 | ((some-fn TopFilter? BotFilter?) (:else fl)))) 93 | [(unparse-filter-set fl)]) 94 | (when (not ((some-fn NoObject? EmptyObject?) o)) 95 | [(unparse-object o)])))))) 96 | 97 | (defmethod unparse-type* Protocol 98 | [{:keys [the-var poly?]}] 99 | (if poly? 100 | (list* the-var (mapv unparse-type poly?)) 101 | the-var)) 102 | 103 | (defmethod unparse-type* DataType 104 | [{:keys [the-class poly?]}] 105 | (if poly? 106 | (list* the-class (mapv unparse-type poly?)) 107 | the-class)) 108 | 109 | (defmulti unparse-RClass :the-class) 110 | 111 | (defmethod unparse-RClass 'clojure.lang.Atom 112 | [{:keys [the-class poly?]}] 113 | (let [[w r] poly?] 114 | (list* the-class (map unparse-type (concat [w] 115 | (when (not= w r) 116 | [r])))))) 117 | 118 | (defmethod unparse-RClass :default 119 | [{:keys [the-class poly?]}] 120 | (list* the-class (doall (map unparse-type poly?)))) 121 | 122 | (defmethod unparse-type* RClass 123 | [{:keys [the-class poly?] :as r}] 124 | (if (empty? poly?) 125 | the-class 126 | (unparse-RClass r))) 127 | 128 | (defmethod unparse-type* Mu 129 | [m] 130 | (let [nme (gensym "Mu") 131 | body (Mu-body* nme m)] 132 | (list 'Rec [nme] (unparse-type body)))) 133 | 134 | (defmethod unparse-type* PolyDots 135 | [{:keys [nbound] :as p}] 136 | (let [{:keys [actual-frees dvar-name]} (meta p) 137 | free-names actual-frees 138 | given-names? (and free-names dvar-name) 139 | end-nme (if given-names? 140 | *next-nme* 141 | (+ nbound *next-nme*)) 142 | fs (if given-names? 143 | (vec (concat free-names [dvar-name])) 144 | (vec 145 | (for [x (range *next-nme* end-nme)] 146 | (symbol (str "v" x))))) 147 | body (PolyDots-body* fs p)] 148 | (binding [*next-nme* end-nme] 149 | (list 'All (vec (concat (butlast fs) [(last fs) '...])) (unparse-type body))))) 150 | 151 | (defmethod unparse-type* Poly 152 | [{:keys [nbound] :as p}] 153 | (let [free-names (Poly-free-names* p) 154 | given-names? free-names 155 | end-nme (if given-names? 156 | *next-nme* 157 | (+ nbound *next-nme*)) 158 | fs-names (or (and given-names? free-names) 159 | (vec 160 | (for [x (range *next-nme* end-nme)] 161 | (symbol (str "v" x))))) 162 | bbnds (Poly-bbnds* fs-names p) 163 | fs (if given-names? 164 | (vec 165 | (for [[name {:keys [upper-bound lower-bound higher-kind]}] (map vector free-names bbnds)] 166 | (let [u (when upper-bound 167 | (unparse-type upper-bound)) 168 | l (when lower-bound 169 | (unparse-type lower-bound)) 170 | h (when higher-kind 171 | (unparse-type higher-kind))] 172 | (or (when higher-kind 173 | [name :kind h]) 174 | (when-not (or (Top? upper-bound) (Bottom? lower-bound)) 175 | [name :< u :> l]) 176 | (when-not (Top? upper-bound) 177 | [name :< u]) 178 | (when-not (Bottom? lower-bound) 179 | [name :> l]) 180 | name)))) 181 | fs-names) 182 | body (Poly-body* fs-names p)] 183 | (binding [*next-nme* end-nme] 184 | (list 'All fs (unparse-type body))))) 185 | 186 | (defmethod unparse-type* TypeFn 187 | [{:keys [nbound] :as p}] 188 | (let [free-names (-> p meta :actual-frees) 189 | given-names? free-names 190 | end-nme (if given-names? 191 | *next-nme* 192 | (+ nbound *next-nme*)) 193 | fs-names (or (and given-names? free-names) 194 | (vec 195 | (for [x (range *next-nme* end-nme)] 196 | (symbol (str "v" x))))) 197 | bbnds (TypeFn-bbnds* fs-names p) 198 | fs (if given-names? 199 | (vec 200 | (for [[name {:keys [upper-bound lower-bound higher-kind]}] (map vector 201 | (-> p meta :actual-frees) 202 | bbnds)] 203 | (let [u (when upper-bound 204 | (unparse-type upper-bound)) 205 | l (when lower-bound 206 | (unparse-type lower-bound)) 207 | h (when higher-kind 208 | (unparse-type higher-kind))] 209 | (or (when higher-kind 210 | [name :kind h]) 211 | (when-not (or (Top? upper-bound) (Bottom? lower-bound)) 212 | [name :< u :> l]) 213 | (when-not (Top? upper-bound) 214 | [name :< u]) 215 | (when-not (Bottom? lower-bound) 216 | [name :> l]) 217 | name)))) 218 | fs-names) 219 | body (TypeFn-body* fs-names p)] 220 | (binding [*next-nme* end-nme] 221 | (list 'TFn fs (unparse-type body))))) 222 | 223 | (defmethod unparse-type* Value 224 | [v] 225 | (if ((some-fn Nil? True? False?) v) 226 | (:val v) 227 | (list 'Value (:val v)))) 228 | 229 | (defmethod unparse-type* HeterogeneousMap 230 | [v] 231 | (list 'HMap (into {} (map (fn [[k v]] 232 | (assert (Value? k)) 233 | (vector (:val k) 234 | (unparse-type v))) 235 | (:types v))))) 236 | 237 | (defmethod unparse-type* HeterogeneousSeq 238 | [v] 239 | (list* 'Seq* (doall (map unparse-type (:types v))))) 240 | 241 | (defmethod unparse-type* HeterogeneousVector 242 | [v] 243 | (mapv unparse-type (:types v))) 244 | 245 | (defmethod unparse-type* HeterogeneousList 246 | [v] 247 | (list* 'List* (doall (map unparse-type (:types v))))) 248 | 249 | ; Objects 250 | 251 | (defmulti unparse-object class) 252 | (defmethod unparse-object EmptyObject [_] 'empty-object) 253 | (defmethod unparse-object NoObject [_] 'no-object) 254 | (defmethod unparse-object Path [{:keys [path id]}] (conj {:id id} (when (seq path) [:path (mapv unparse-path-elem path)]))) 255 | 256 | ; Path elems 257 | 258 | (defmulti unparse-path-elem class) 259 | (defmethod unparse-path-elem KeyPE [t] (list 'Key (:val t))) 260 | (defmethod unparse-path-elem CountPE [t] 'Count) 261 | (defmethod unparse-path-elem ClassPE [t] 'Class) 262 | 263 | ; Filters 264 | 265 | (defmulti unparse-filter* class) 266 | 267 | (declare FilterSet? unparse-filter) 268 | 269 | (defn unparse-filter-set [{:keys [then else] :as fs}] 270 | {:pre [(FilterSet? fs)]} 271 | {:then (unparse-filter then) 272 | :else (unparse-filter else)}) 273 | 274 | (defn unparse-filter [f] 275 | (unparse-filter* f)) 276 | 277 | (defmethod unparse-filter* TopFilter [f] 'tt) 278 | (defmethod unparse-filter* BotFilter [f] 'ff) 279 | 280 | (declare unparse-type) 281 | 282 | (defmethod unparse-filter* TypeFilter 283 | [{:keys [type path id]}] 284 | (concat (list 'is (unparse-type type) id) 285 | (when (seq path) 286 | [(map unparse-path-elem path)]))) 287 | 288 | (defmethod unparse-filter* NotTypeFilter 289 | [{:keys [type path id]}] 290 | (concat (list '! (unparse-type type) id) 291 | (when path 292 | [(map unparse-path-elem path)]))) 293 | 294 | (defmethod unparse-filter* AndFilter [{:keys [fs]}] (apply list '& (map unparse-filter fs))) 295 | (defmethod unparse-filter* OrFilter [{:keys [fs]}] (apply list '| (map unparse-filter fs))) 296 | 297 | (defmethod unparse-filter* ImpFilter 298 | [{:keys [a c]}] 299 | (list 'when (unparse-filter a) (unparse-filter c))) 300 | 301 | -------------------------------------------------------------------------------- /src/typed/fold.clj: -------------------------------------------------------------------------------- 1 | (set! *warn-on-reflection* true) 2 | 3 | (in-ns 'typed.core) 4 | 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;; Type Folding 7 | 8 | (def fold-rhs-default ::fold-rhs) 9 | 10 | ;1. fold-rhs calls sends 11 | ; a. Type to type-rec 12 | ; b. Filter to filter-rec 13 | ; c. Object to object-rec 14 | 15 | (declare unparse-type) 16 | 17 | ;visit a type nested inside ty. Add methods with a mode deriving ::visit-type-default 18 | (defmulti fold-rhs (fn [mode options ty] 19 | [mode (class ty)])) 20 | 21 | ; fld-fn has type-rec, filter-rec and object-rec in scope 22 | (defmacro add-fold-case [mode ty fld-fn] 23 | `(defmethod fold-rhs [~mode ~ty] 24 | [mode# options# ty#] 25 | (let [~'[type-rec filter-rec object-rec pathelem-rec] 26 | (map #(or (% options#) 27 | (partial fold-rhs mode# options#)) 28 | [:type-rec :filter-rec :object-rec :pathelem-rec])] 29 | (~fld-fn ty# options#)))) 30 | 31 | (defmacro add-default-fold-case [ty fld-fn] 32 | `(add-fold-case fold-rhs-default ~ty ~fld-fn)) 33 | 34 | (declare sub-pe) 35 | 36 | (defn sub-f [st mode] 37 | #(fold-rhs mode 38 | {:type-rec st 39 | :filter-rec (sub-f st mode) 40 | :pathelem-rec (sub-pe st mode)} 41 | %)) 42 | 43 | (defn sub-o [st mode] 44 | #(fold-rhs mode 45 | {:type-rec st 46 | :object-rec (sub-o st mode) 47 | :pathelem-rec (sub-pe st mode)} 48 | %)) 49 | 50 | (defn sub-pe [st mode] 51 | #(fold-rhs fold-rhs-default 52 | {:type-rec st 53 | :pathelem-rec (sub-pe st mode)} 54 | %)) 55 | 56 | (add-default-fold-case NotType 57 | (fn [ty _] 58 | (-> ty 59 | (update-in [:type] type-rec)))) 60 | 61 | (add-default-fold-case Intersection 62 | (fn [ty _] 63 | (apply In (mapv type-rec (:types ty))))) 64 | 65 | (add-default-fold-case Union 66 | (fn [ty _] 67 | (apply Un (mapv type-rec (:types ty))))) 68 | 69 | (add-default-fold-case FnIntersection 70 | (fn [ty _] 71 | (-> ty 72 | (update-in [:types] #(mapv type-rec %))))) 73 | 74 | (defn visit-bounds 75 | "Apply f to each element of bounds" 76 | [ty f] 77 | {:pre [(Bounds? ty)] 78 | :post [(Bounds? ty)]} 79 | (-> ty 80 | (update-in [:upper-bound] #(when % 81 | (f %))) 82 | (update-in [:lower-bound] #(when % 83 | (f %))) 84 | (update-in [:higher-kind] #(when % 85 | (f %))))) 86 | 87 | (add-default-fold-case Bounds 88 | (fn [ty _] 89 | (visit-bounds ty type-rec))) 90 | 91 | (add-default-fold-case Projection 92 | (fn [ty _] 93 | (-> ty 94 | (update-in [:ts] #(mapv type-rec %))))) 95 | 96 | (add-default-fold-case DottedPretype 97 | (fn [ty _] 98 | (-> ty 99 | (update-in [:pre-type] type-rec)))) 100 | 101 | (add-default-fold-case Function 102 | (fn [ty _] 103 | (-> ty 104 | (update-in [:dom] #(mapv type-rec %)) 105 | (update-in [:rng] type-rec) 106 | (update-in [:rest] #(when % 107 | (type-rec %))) 108 | (update-in [:drest] #(when % 109 | (-> % 110 | (update-in [:pre-type] type-rec))))))) 111 | 112 | (add-default-fold-case RClass 113 | (fn [ty _] 114 | (-> ty 115 | (update-in [:poly?] #(when % 116 | (mapv type-rec %))) 117 | (update-in [:replacements] #(into {} (for [[k v] %] 118 | [k (type-rec v)])))))) 119 | 120 | (add-default-fold-case App 121 | (fn [ty _] 122 | (-> ty 123 | (update-in [:rator] type-rec) 124 | (update-in [:rands] #(mapv type-rec %))))) 125 | 126 | (add-default-fold-case TApp 127 | (fn [ty _] 128 | (-> ty 129 | (update-in [:rator] type-rec) 130 | (update-in [:rands] #(mapv type-rec %))))) 131 | 132 | (add-default-fold-case PrimitiveArray 133 | (fn [ty _] 134 | (-> ty 135 | (update-in [:input-type] type-rec) 136 | (update-in [:output-type] type-rec)))) 137 | 138 | (add-default-fold-case DataType 139 | (fn [ty _] 140 | (-> ty 141 | (update-in [:poly?] #(when % 142 | (mapv type-rec %))) 143 | (update-in [:fields] (fn [fs] 144 | (apply array-map 145 | (apply concat 146 | (for [[k v] fs] 147 | [k (type-rec v)])))))))) 148 | 149 | (add-default-fold-case Protocol 150 | (fn [ty _] 151 | (-> ty 152 | (update-in [:poly?] #(when % 153 | (mapv type-rec %))) 154 | (update-in [:methods] (fn [ms] 155 | (into {} 156 | (for [[k v] ms] 157 | [k (type-rec v)]))))))) 158 | 159 | (add-default-fold-case TypeFn 160 | (fn [^TypeFn ty _] 161 | (let [names (repeatedly (.nbound ty) gensym) 162 | body (TypeFn-body* names ty) 163 | bbnds (TypeFn-bbnds* names ty)] 164 | (TypeFn* names 165 | (.variances ty) 166 | (mapv #(visit-bounds % type-rec) bbnds) 167 | (type-rec body))))) 168 | 169 | 170 | (add-default-fold-case Poly 171 | (fn [^Poly ty _] 172 | (let [names (repeatedly (.nbound ty) gensym) 173 | body (Poly-body* names ty) 174 | bbnds (Poly-bbnds* names ty)] 175 | (Poly* names 176 | (mapv #(visit-bounds % type-rec) bbnds) 177 | (type-rec body) 178 | (Poly-free-names* ty))))) 179 | 180 | (add-default-fold-case PolyDots 181 | (fn [^PolyDots ty _] 182 | (let [names (repeatedly (.nbound ty) gensym) 183 | body (PolyDots-body* names ty) 184 | bbnds (PolyDots-bbnds* names ty)] 185 | (PolyDots* names 186 | (mapv #(visit-bounds % type-rec) bbnds) 187 | (type-rec body))))) 188 | 189 | (add-default-fold-case Mu 190 | (fn [ty _] 191 | (let [name (gensym) 192 | body (Mu-body* name ty)] 193 | (Mu* name (type-rec body))))) 194 | 195 | (add-default-fold-case HeterogeneousVector 196 | (fn [ty _] 197 | (-> ty (update-in [:types] #(mapv type-rec %))))) 198 | 199 | (add-default-fold-case HeterogeneousList 200 | (fn [ty _] 201 | (-> ty (update-in [:types] #(mapv type-rec %))))) 202 | 203 | (add-default-fold-case HeterogeneousSeq 204 | (fn [ty _] 205 | (-> ty (update-in [:types] #(mapv type-rec %))))) 206 | 207 | (add-default-fold-case HeterogeneousMap 208 | (fn [ty _] 209 | (-> ty 210 | (update-in [:types] #(into {} (for [[k v] %] 211 | [(type-rec k) (type-rec v)])))))) 212 | 213 | (def ret-first (fn [a & rest] a)) 214 | 215 | (add-default-fold-case CountRange ret-first) 216 | (add-default-fold-case Name ret-first) 217 | (add-default-fold-case Value ret-first) 218 | (add-default-fold-case Top ret-first) 219 | (add-default-fold-case TopFunction ret-first) 220 | (add-default-fold-case B ret-first) 221 | (add-default-fold-case F ret-first) 222 | 223 | (add-default-fold-case Result 224 | (fn [ty _] 225 | (-> ty 226 | (update-in [:t] type-rec) 227 | (update-in [:fl] filter-rec) 228 | (update-in [:o] object-rec)))) 229 | 230 | 231 | ;filters 232 | 233 | (add-default-fold-case NoFilter ret-first) 234 | (add-default-fold-case TopFilter ret-first) 235 | (add-default-fold-case BotFilter ret-first) 236 | 237 | (add-default-fold-case TypeFilter 238 | (fn [ty _] 239 | (-> ty 240 | (update-in [:type] type-rec) 241 | (update-in [:path] #(seq (map pathelem-rec %)))))) 242 | 243 | (add-default-fold-case NotTypeFilter 244 | (fn [ty _] 245 | (-> ty 246 | (update-in [:type] type-rec) 247 | (update-in [:path] #(seq (map pathelem-rec %)))))) 248 | 249 | (add-default-fold-case ImpFilter 250 | (fn [ty _] 251 | (-> ty 252 | (update-in [:a] filter-rec) 253 | (update-in [:c] filter-rec)))) 254 | 255 | (add-default-fold-case AndFilter 256 | (fn [ty _] 257 | (-> ty 258 | (update-in [:fs] #(set (map filter-rec %)))))) 259 | 260 | (add-default-fold-case OrFilter 261 | (fn [ty _] 262 | (-> ty 263 | (update-in [:fs] #(set (map filter-rec %)))))) 264 | 265 | (add-default-fold-case FilterSet 266 | (fn [ty _] 267 | (-> ty 268 | (update-in [:then] filter-rec) 269 | (update-in [:else] filter-rec)))) 270 | 271 | ;objects 272 | (add-default-fold-case EmptyObject ret-first) 273 | (add-default-fold-case Path 274 | (fn [ty _] 275 | (-> ty 276 | (update-in [:path] #(when % 277 | (mapv pathelem-rec %)))))) 278 | (add-default-fold-case NoObject ret-first) 279 | 280 | ;path-elems 281 | 282 | (add-default-fold-case KeyPE ret-first) 283 | 284 | ;TCResult 285 | 286 | (add-default-fold-case TCResult 287 | (fn [ty _] 288 | (-> ty 289 | (update-in [:t] type-rec) 290 | (update-in [:fl] filter-rec) 291 | (update-in [:o] object-rec)))) 292 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF 5 | THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and 12 | documentation distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | 16 | i) changes to the Program, and 17 | 18 | ii) additions to the Program; 19 | 20 | where such changes and/or additions to the Program originate from and 21 | are distributed by that particular Contributor. A Contribution 22 | 'originates' from a Contributor if it was added to the Program by such 23 | Contributor itself or anyone acting on such Contributor's 24 | behalf. Contributions do not include additions to the Program which: 25 | (i) are separate modules of software distributed in conjunction with 26 | the Program under their own license agreement, and (ii) are not 27 | derivative works of the Program. 28 | 29 | "Contributor" means any person or entity that distributes the Program. 30 | 31 | "Licensed Patents" mean patent claims licensable by a Contributor 32 | which are necessarily infringed by the use or sale of its Contribution 33 | alone or when combined with the Program. 34 | 35 | "Program" means the Contributions distributed in accordance with this 36 | Agreement. 37 | 38 | "Recipient" means anyone who receives the Program under this 39 | Agreement, including all Contributors. 40 | 41 | 2. GRANT OF RIGHTS 42 | 43 | a) Subject to the terms of this Agreement, each Contributor hereby 44 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 45 | license to reproduce, prepare derivative works of, publicly display, 46 | publicly perform, distribute and sublicense the Contribution of such 47 | Contributor, if any, and such derivative works, in source code and 48 | object code form. 49 | 50 | b) Subject to the terms of this Agreement, each Contributor hereby 51 | grants Recipient a non-exclusive, worldwide, royalty-free patent 52 | license under Licensed Patents to make, use, sell, offer to sell, 53 | import and otherwise transfer the Contribution of such Contributor, if 54 | any, in source code and object code form. This patent license shall 55 | apply to the combination of the Contribution and the Program if, at 56 | the time the Contribution is added by the Contributor, such addition 57 | of the Contribution causes such combination to be covered by the 58 | Licensed Patents. The patent license shall not apply to any other 59 | combinations which include the Contribution. No hardware per se is 60 | licensed hereunder. 61 | 62 | c) Recipient understands that although each Contributor grants the 63 | licenses to its Contributions set forth herein, no assurances are 64 | provided by any Contributor that the Program does not infringe the 65 | patent or other intellectual property rights of any other entity. Each 66 | Contributor disclaims any liability to Recipient for claims brought by 67 | any other entity based on infringement of intellectual property rights 68 | or otherwise. As a condition to exercising the rights and licenses 69 | granted hereunder, each Recipient hereby assumes sole responsibility 70 | to secure any other intellectual property rights needed, if any. For 71 | example, if a third party patent license is required to allow 72 | Recipient to distribute the Program, it is Recipient's responsibility 73 | to acquire that license before distributing the Program. 74 | 75 | d) Each Contributor represents that to its knowledge it has sufficient 76 | copyright rights in its Contribution, if any, to grant the copyright 77 | license set forth in this Agreement. 78 | 79 | 3. REQUIREMENTS 80 | 81 | A Contributor may choose to distribute the Program in object code form 82 | under its own license agreement, provided that: 83 | 84 | a) it complies with the terms and conditions of this Agreement; and 85 | 86 | b) its license agreement: 87 | 88 | i) effectively disclaims on behalf of all Contributors all warranties 89 | and conditions, express and implied, including warranties or 90 | conditions of title and non-infringement, and implied warranties or 91 | conditions of merchantability and fitness for a particular purpose; 92 | 93 | ii) effectively excludes on behalf of all Contributors all liability 94 | for damages, including direct, indirect, special, incidental and 95 | consequential damages, such as lost profits; 96 | 97 | iii) states that any provisions which differ from this Agreement are 98 | offered by that Contributor alone and not by any other party; and 99 | 100 | iv) states that source code for the Program is available from such 101 | Contributor, and informs licensees how to obtain it in a reasonable 102 | manner on or through a medium customarily used for software exchange. 103 | 104 | When the Program is made available in source code form: 105 | 106 | a) it must be made available under this Agreement; and 107 | 108 | b) a copy of this Agreement must be included with each copy of the Program. 109 | 110 | Contributors may not remove or alter any copyright notices contained 111 | within the Program. 112 | 113 | Each Contributor must identify itself as the originator of its 114 | Contribution, if any, in a manner that reasonably allows subsequent 115 | Recipients to identify the originator of the Contribution. 116 | 117 | 4. COMMERCIAL DISTRIBUTION 118 | 119 | Commercial distributors of software may accept certain 120 | responsibilities with respect to end users, business partners and the 121 | like. While this license is intended to facilitate the commercial use 122 | of the Program, the Contributor who includes the Program in a 123 | commercial product offering should do so in a manner which does not 124 | create potential liability for other Contributors. Therefore, if a 125 | Contributor includes the Program in a commercial product offering, 126 | such Contributor ("Commercial Contributor") hereby agrees to defend 127 | and indemnify every other Contributor ("Indemnified Contributor") 128 | against any losses, damages and costs (collectively "Losses") arising 129 | from claims, lawsuits and other legal actions brought by a third party 130 | against the Indemnified Contributor to the extent caused by the acts 131 | or omissions of such Commercial Contributor in connection with its 132 | distribution of the Program in a commercial product offering. The 133 | obligations in this section do not apply to any claims or Losses 134 | relating to any actual or alleged intellectual property 135 | infringement. In order to qualify, an Indemnified Contributor must: a) 136 | promptly notify the Commercial Contributor in writing of such claim, 137 | and b) allow the Commercial Contributor tocontrol, and cooperate with 138 | the Commercial Contributor in, the defense and any related settlement 139 | negotiations. The Indemnified Contributor may participate in any such 140 | claim at its own expense. 141 | 142 | For example, a Contributor might include the Program in a commercial 143 | product offering, Product X. That Contributor is then a Commercial 144 | Contributor. If that Commercial Contributor then makes performance 145 | claims, or offers warranties related to Product X, those performance 146 | claims and warranties are such Commercial Contributor's responsibility 147 | alone. Under this section, the Commercial Contributor would have to 148 | defend claims against the other Contributors related to those 149 | performance claims and warranties, and if a court requires any other 150 | Contributor to pay any damages as a result, the Commercial Contributor 151 | must pay those damages. 152 | 153 | 5. NO WARRANTY 154 | 155 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 156 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 157 | KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY 158 | WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 159 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 160 | responsible for determining the appropriateness of using and 161 | distributing the Program and assumes all risks associated with its 162 | exercise of rights under this Agreement , including but not limited to 163 | the risks and costs of program errors, compliance with applicable 164 | laws, damage to or loss of data, programs or equipment, and 165 | unavailability or interruption of operations. 166 | 167 | 6. DISCLAIMER OF LIABILITY 168 | 169 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR 170 | ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 171 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 172 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 173 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 174 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 175 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 176 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 177 | 178 | 7. GENERAL 179 | 180 | If any provision of this Agreement is invalid or unenforceable under 181 | applicable law, it shall not affect the validity or enforceability of 182 | the remainder of the terms of this Agreement, and without further 183 | action by the parties hereto, such provision shall be reformed to the 184 | minimum extent necessary to make such provision valid and enforceable. 185 | 186 | If Recipient institutes patent litigation against any entity 187 | (including a cross-claim or counterclaim in a lawsuit) alleging that 188 | the Program itself (excluding combinations of the Program with other 189 | software or hardware) infringes such Recipient's patent(s), then such 190 | Recipient's rights granted under Section 2(b) shall terminate as of 191 | the date such litigation is filed. 192 | 193 | All Recipient's rights under this Agreement shall terminate if it 194 | fails to comply with any of the material terms or conditions of this 195 | Agreement and does not cure such failure in a reasonable period of 196 | time after becoming aware of such noncompliance. If all Recipient's 197 | rights under this Agreement terminate, Recipient agrees to cease use 198 | and distribution of the Program as soon as reasonably 199 | practicable. However, Recipient's obligations under this Agreement and 200 | any licenses granted by Recipient relating to the Program shall 201 | continue and survive. 202 | 203 | Everyone is permitted to copy and distribute copies of this Agreement, 204 | but in order to avoid inconsistency the Agreement is copyrighted and 205 | may only be modified in the following manner. The Agreement Steward 206 | reserves the right to publish new versions (including revisions) of 207 | this Agreement from time to time. No one other than the Agreement 208 | Steward has the right to modify this Agreement. The Eclipse Foundation 209 | is the initial Agreement Steward. The Eclipse Foundation may assign 210 | the responsibility to serve as the Agreement Steward to a suitable 211 | separate entity. Each new version of the Agreement will be given a 212 | distinguishing version number. The Program (including Contributions) 213 | may always be distributed subject to the version of the Agreement 214 | under which it was received. In addition, after a new version of the 215 | Agreement is published, Contributor may elect to distribute the 216 | Program (including its Contributions) under the new version. Except as 217 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives 218 | no rights or licenses to the intellectual property of any Contributor 219 | under this Agreement, whether expressly, by implication, estoppel or 220 | otherwise. All rights in the Program not expressly granted under this 221 | Agreement are reserved. 222 | 223 | This Agreement is governed by the laws of the State of Washington and 224 | the intellectual property laws of the United States of America. No 225 | party to this Agreement will bring a legal action under this Agreement 226 | more than one year after the cause of action arose. Each party waives 227 | its rights to a jury trial in any resulting litigation. 228 | -------------------------------------------------------------------------------- /test/typed/test/logic/macros.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.logic.macros 2 | (:refer-clojure :exclude [==]) 3 | (:require [clojure.set :as set])) 4 | 5 | (def ^{:dynamic true} *locals*) 6 | 7 | (defmacro llist 8 | "Constructs a sequence from 2 or more arguments, with the last argument as the tail. 9 | The tail is improper if the last argument is a logic variable." 10 | ([f s] `(cljs.core.logic/lcons ~f ~s)) 11 | ([f s & rest] `(cljs.core.logic/lcons ~f (llist ~s ~@rest)))) 12 | 13 | (defn bind-conde-clause [a] 14 | (fn [g-rest] 15 | `(bind* ~a ~@g-rest))) 16 | 17 | (defn bind-conde-clauses [a clauses] 18 | (map (bind-conde-clause a) clauses)) 19 | 20 | (defn lvar-bind [sym] 21 | ((juxt identity 22 | (fn [s] `(cljs.core.logic/lvar '~s))) sym)) 23 | 24 | (defn lvar-binds [syms] 25 | (mapcat lvar-bind syms)) 26 | 27 | (defmacro bind* 28 | ([a g] `(cljs.core.logic/-bind ~a ~g)) 29 | ([a g & g-rest] 30 | `(bind* (cljs.core.logic/-bind ~a ~g) ~@g-rest))) 31 | 32 | (defmacro mplus* 33 | ([e] e) 34 | ([e & e-rest] 35 | `(cljs.core.logic/-mplus ~e (-inc (mplus* ~@e-rest))))) 36 | 37 | (defmacro -inc [& rest] 38 | `(cljs.core.logic/Inc. (fn [] ~@rest))) 39 | 40 | (defmacro == 41 | "A goal that attempts to unify terms u and v." 42 | [u v] 43 | `(fn [a#] 44 | (if-let [b# (cljs.core.logic/-unify a# ~u ~v)] 45 | b# nil))) 46 | 47 | (defmacro conde 48 | "Logical disjunction of the clauses. The first goal in 49 | a clause is considered the head of that clause. Interleaves the 50 | execution of the clauses." 51 | [& clauses] 52 | (let [a (gensym "a")] 53 | `(fn [~a] 54 | (-inc 55 | (mplus* ~@(bind-conde-clauses a clauses)))))) 56 | 57 | (defmacro fresh 58 | "Creates fresh variables. Goals occuring within form a logical 59 | conjunction." 60 | [[& lvars] & goals] 61 | `(fn [a#] 62 | (-inc 63 | (let [~@(lvar-binds lvars)] 64 | (bind* a# ~@goals))))) 65 | 66 | (defmacro solve [& [n [x] & goals]] 67 | `(let [xs# (cljs.core.logic/-take* (-inc 68 | ((fresh [~x] ~@goals 69 | (fn [a#] 70 | (cons (cljs.core.logic/-reify a# ~x) '()))) ;; TODO: do we need this? 71 | cljs.core.logic/empty-s)))] 72 | (if ~n 73 | (take ~n xs#) 74 | xs#))) 75 | 76 | (defmacro run 77 | "Executes goals until a maximum of n results are found." 78 | [n & goals] 79 | `(doall (solve ~n ~@goals))) 80 | 81 | (defmacro run* 82 | "Executes goals until results are exhausted." 83 | [& goals] 84 | `(run false ~@goals)) 85 | 86 | (defmacro run-nc 87 | "Executes goals until a maximum of n results are found. Does not occurs-check." 88 | [& [n & goals]] 89 | `(binding [*occurs-check* false] 90 | (run ~n ~@goals))) 91 | 92 | (defmacro run-nc* 93 | "Executes goals until results are exhausted. Does not occurs-check." 94 | [& goals] 95 | `(run-nc false ~@goals)) 96 | 97 | (defmacro lazy-run 98 | "Lazily executes goals until a maximum of n results are found." 99 | [& [n & goals]] 100 | `(solve ~n ~@goals)) 101 | 102 | (defmacro lazy-run* 103 | "Lazily executes goals until results are exhausted." 104 | [& goals] 105 | `(solve false ~@goals)) 106 | 107 | (defmacro all 108 | "Like fresh but does does not create logic variables." 109 | ([] `cljs.core.logic/s#) 110 | ([& goals] `(fn [a#] (bind* a# ~@goals)))) 111 | 112 | ;; ============================================================================= 113 | ;; Debugging 114 | 115 | (defmacro log [& s] 116 | "Goal for println" 117 | `(fn [a#] 118 | (println ~@s) 119 | a#)) 120 | 121 | (defmacro trace-s [] 122 | "Goal that prints the current substitution" 123 | `(fn [a#] 124 | (println (str a#)) 125 | a#)) 126 | 127 | (defn trace-lvar [a lvar] 128 | `(println (format "%5s = %s" (str '~lvar) (-reify ~a ~lvar)))) 129 | 130 | (defmacro trace-lvars 131 | "Goal for tracing the values of logic variables." 132 | [title & lvars] 133 | (let [a (gensym "a")] 134 | `(fn [~a] 135 | (println ~title) 136 | ~@(map (partial trace-lvar a) lvars) 137 | ~a))) 138 | 139 | ;; ============================================================================= 140 | ;; Non-relational goals 141 | 142 | ;; ============================================================================= 143 | ;; project 144 | 145 | (defn project-binding [s] 146 | (fn [var] 147 | `(~var (cljs.core.logic/-walk* ~s ~var)))) 148 | 149 | (defn project-bindings [vars s] 150 | (reduce concat (map (project-binding s) vars))) 151 | 152 | (defmacro project 153 | "Extract the values bound to the specified logic vars. Non-relational." 154 | [[& vars] & goals] 155 | (let [a (gensym "a")] 156 | `(fn [~a] 157 | (let [~@(project-bindings vars a)] 158 | ((fresh [] 159 | ~@goals) ~a))))) 160 | 161 | (defmacro pred 162 | "Check a predicate against the value logic var. Non-relational." 163 | [v f] 164 | `(project [~v] 165 | (== (~f ~v) true))) 166 | 167 | (defmacro is 168 | "Set the value of a var to value of another var with the operation 169 | applied. Non-relational." 170 | [u v op] 171 | `(project [~v] 172 | (== ~u (~op ~v)))) 173 | 174 | ;; ============================================================================= 175 | ;; conda (soft-cut), condu (committed-choice) 176 | ;; 177 | ;; conda once a line succeeds no others are tried 178 | ;; condu a line can succeed only one time 179 | 180 | ;; TODO : if -> when 181 | 182 | (defmacro ifa* 183 | ([]) 184 | ([[e & gs] & grest] 185 | `(cljs.core.logic/-ifa ~e [~@gs] 186 | ~(if (seq grest) 187 | `(delay (ifa* ~@grest)) 188 | nil)))) 189 | 190 | (defmacro ifu* 191 | ([]) 192 | ([[e & gs] & grest] 193 | `(cljs.core.logic/-ifu ~e [~@gs] 194 | ~(if (seq grest) 195 | `(delay (ifu* ~@grest)) 196 | nil)))) 197 | 198 | (defn cond-clauses [a] 199 | (fn [goals] 200 | `((~(first goals) ~a) ~@(rest goals)))) 201 | 202 | (defmacro conda 203 | "Soft cut. Once the head of a clause has succeeded 204 | all other clauses will be ignored. Non-relational." 205 | [& clauses] 206 | (let [a (gensym "a")] 207 | `(fn [~a] 208 | (ifa* ~@(map (cond-clauses a) clauses))))) 209 | 210 | (defmacro condu 211 | "Committed choice. Once the head (first goal) of a clause 212 | has succeeded, remaining goals of the clause will only 213 | be run once. Non-relational." 214 | [& clauses] 215 | (let [a (gensym "a")] 216 | `(fn [~a] 217 | (ifu* ~@(map (cond-clauses a) clauses))))) 218 | 219 | ;; ============================================================================= 220 | ;; lvar nonlvar 221 | 222 | ;; ============================================================================= 223 | ;; Pattern matching 224 | 225 | (defn warn [& msg] 226 | (binding [*out* *err*] 227 | (apply println "WARNING:" msg))) 228 | 229 | (declare p->term) 230 | 231 | (defn lcons-p? [p] 232 | (and (coll? p) 233 | (not (nil? (some '#{.} p))))) 234 | 235 | (defn p->llist [p] 236 | `(llist 237 | ~@(map p->term 238 | (remove #(contains? '#{.} %) p)))) 239 | 240 | (defn- p->term [p] 241 | (cond 242 | (= p '_) `(cljs.core.logic/lvar) 243 | (lcons-p? p) (p->llist p) 244 | (and (coll? p) (not= (first p) 'quote)) 245 | (cond 246 | ;; support simple expressions 247 | (list? p) p 248 | ;; preserve original collection type 249 | :else (let [ps (map p->term p)] 250 | (cond 251 | (instance? clojure.lang.MapEntry p) (into [] ps) 252 | :else (into (empty p) ps)))) 253 | :else p)) 254 | 255 | (defn lvar-sym? [s] 256 | (and (symbol? s) 257 | (not= s '.) 258 | (not (contains? *locals* s)))) 259 | 260 | (defn extract-vars 261 | ([p] 262 | (set (cond 263 | (lvar-sym? p) [p] 264 | (coll? p) (let [p (if (seq? p) (rest p) p)] 265 | (filter lvar-sym? (flatten p))) 266 | :else nil))) 267 | ([p seen] 268 | (set/difference (extract-vars p) (set seen)))) 269 | 270 | (defn fresh-expr? [cs] 271 | (= (first cs) `fresh)) 272 | 273 | (defn ex 274 | ([vs t a] 275 | `(fresh [~@vs] 276 | (== ~t ~a))) 277 | ([vs t a exprs] 278 | (if (fresh-expr? exprs) 279 | `(fresh [~@vs] 280 | (== ~t ~a) 281 | ~exprs) 282 | `(fresh [~@vs] 283 | (== ~t ~a) 284 | ~@exprs)))) 285 | 286 | (defn ex* [[[p a :as pa] & par] exprs seen] 287 | (let [t (p->term p) 288 | vs (extract-vars p seen) 289 | seen (reduce conj seen vs)] 290 | (cond 291 | (nil? pa) exprs 292 | (= p '_) (ex* par exprs seen) 293 | (empty? par) (if exprs 294 | (ex vs t a exprs) 295 | (ex vs t a)) 296 | :else (let [r (ex* par exprs seen)] 297 | (if r 298 | (ex vs t a r) 299 | (ex vs t a)))))) 300 | 301 | (defn all-blank? [p] 302 | (every? #(= % '_) p)) 303 | 304 | (defn handle-clause [as] 305 | (when-not (vector? as) 306 | (throw (Exception. (str "Expecting vector of arguments, instead " as)))) 307 | (fn [[p & exprs]] 308 | (when-not (vector? p) 309 | (throw (Exception. (str "Expecting vector of matches, instead " p)))) 310 | (when-not (= (count p) (count as)) 311 | (warn "Differing number of matches. Matching" p "against" as)) 312 | (let [pas (partition 2 (interleave p as)) 313 | r (ex* pas exprs #{})] 314 | (if (all-blank? p) 315 | r 316 | (list r))))) 317 | 318 | (defn handle-clauses [t as cs] 319 | `(~t 320 | ~@(doall (map (handle-clause as) cs)))) 321 | 322 | ;; name-with-attributes by Konrad Hinsen, from clojure.contrib.def 323 | (defn name-with-attributes 324 | "To be used in macro definitions. 325 | Handles optional docstrings and attribute maps for a name to be defined 326 | in a list of macro arguments. If the first macro argument is a string 327 | it is added as a docstring to name and removed from the macro argument 328 | list. If afterwards the first macro argument is a map, its entries are 329 | added to the name's metadata map and the map is removed from the 330 | macro argument list. The return value is a vector containing the name 331 | with its extended metadata map and the list of unprocessed macro 332 | arguments." 333 | [name macro-args] 334 | (let [[docstring macro-args] (if (string? (first macro-args)) 335 | [(first macro-args) (next macro-args)] 336 | [nil macro-args]) 337 | [attr macro-args] (if (map? (first macro-args)) 338 | [(first macro-args) (next macro-args)] 339 | [{} macro-args]) 340 | attr (if docstring 341 | (assoc attr :doc docstring) 342 | attr) 343 | attr (if (meta name) 344 | (conj (meta name) attr) 345 | attr)] 346 | [(with-meta name attr) macro-args])) 347 | 348 | (defmacro lvaro 349 | "Goal to test whether a logic var is ground. Non-relational." 350 | [v] 351 | `(fn [a#] 352 | (if (cljs.core.logic/lvar? (cljs.core.logic/-walk a# ~v)) 353 | a# nil))) 354 | 355 | (defmacro nonlvaro 356 | "Goal to test whether a logic var is ground. Non-relational." 357 | [v] 358 | `(fn [a#] 359 | (if (not (cljs.core.logic/lvar? (cljs.core.logic/walk a# ~v))) 360 | a# nil))) 361 | 362 | (defn env-locals [& syms] 363 | (disj (set (apply concat syms)) '_)) 364 | 365 | (defmacro defnm [t n & rest] 366 | (let [[n [as & cs]] (name-with-attributes n rest)] 367 | (binding [*locals* (env-locals as (-> &env :locals keys))] 368 | (if-let [tabled? (-> n meta :tabled)] 369 | `(def ~n (tabled [~@as] ~(handle-clauses t as cs))) 370 | `(defn ~n [~@as] ~(handle-clauses t as cs)))))) 371 | 372 | ;; ============================================================================= 373 | ;; Goal sugar syntax 374 | 375 | (defmacro defne 376 | "Define a goal fn. Supports pattern matching. All 377 | patterns will be tried. See conde." 378 | [& rest] 379 | `(defnm conde ~@rest)) 380 | 381 | (defmacro matche 382 | "Pattern matching macro. All patterns will be tried. 383 | See conde." 384 | [xs & cs] 385 | (binding [*locals* (env-locals xs (-> &env :locals keys))] 386 | (handle-clauses `conde xs cs))) 387 | 388 | ;; ----------------------------------------------------------------------------- 389 | ;; defnu, defna, matcha, matchu 390 | 391 | ;; TODO: we need to rethink defna and defnu, the unification comes first 392 | ;; the *question* should come first 393 | 394 | (defmacro defna 395 | "Define a soft cut goal. See conda." 396 | [& rest] 397 | `(defnm conda ~@rest)) 398 | 399 | (defmacro defnu 400 | "Define a committed choice goal. See condu." 401 | [& rest] 402 | `(defnm condu ~@rest)) 403 | 404 | (defmacro matcha 405 | "Define a soft cut pattern match. See conda." 406 | [xs & cs] 407 | (binding [*locals* (env-locals xs (-> &env :locals keys))] 408 | (handle-clauses `conda xs cs))) 409 | 410 | (defmacro matchu 411 | "Define a committed choice goal. See condu." 412 | [xs & cs] 413 | (binding [*locals* (env-locals xs (-> &env :locals keys))] 414 | (handle-clauses `condu xs cs))) 415 | 416 | -------------------------------------------------------------------------------- /test/typed/test/core_logic.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.core-logic 2 | (:refer-clojure :exclude [==]) 3 | (:use [clojure.walk :only [postwalk]]) 4 | (:import [java.io Writer] 5 | [clojure.lang IPersistentSet Symbol IPersistentMap Seqable 6 | IPersistentVector IPersistentList Sequential]) 7 | (:require [clojure.set :as set] 8 | [clojure.repl :refer [pst]] 9 | [typed.core :refer [ann-protocol ann tc-ignore def-alias 10 | declare-protocols declare-datatypes 11 | ann-datatype loop> check-ns non-nil-return 12 | cf defprotocol>]] 13 | [analyze.core :refer [ast]])) 14 | 15 | (ann *occurs-check* (U true false)) 16 | (ann *reify-vars* (U true false)) 17 | (ann *locals* (IPersistentSet Symbol)) 18 | 19 | (def ^{:dynamic true} *occurs-check* true) 20 | (def ^{:dynamic true} *reify-vars* true) 21 | (def ^{:dynamic true} *locals*) 22 | 23 | (def-alias Fail false) 24 | 25 | (declare-protocols ISubstitutions 26 | IUnifyTerms 27 | IUnifyWithNil 28 | IUnifyWithObject 29 | IUnifyWithLVar 30 | IUnifyWithSequential 31 | IUnifyWithMap 32 | IUnifyWithSet 33 | IReifyTerm 34 | IWalkTerm 35 | IOccursCheckTerm 36 | IBuildTerm) 37 | 38 | (def-alias Term (I IUnifyTerms 39 | IUnifyWithNil 40 | IUnifyWithObject 41 | IUnifyWithLVar 42 | IUnifyWithSequential 43 | IUnifyWithMap 44 | IUnifyWithSet 45 | IReifyTerm 46 | IWalkTerm 47 | IOccursCheckTerm 48 | IBuildTerm)) 49 | 50 | (ann-protocol IUnifyTerms 51 | unify-terms [Term Term ISubstitutions -> (U ISubstitutions Fail)]) 52 | 53 | (ann-protocol IUnifyWithNil 54 | unify-with-nil [Term nil ISubstitutions -> (U ISubstitutions Fail)]) 55 | 56 | (ann-protocol IUnifyWithObject 57 | unify-with-object [Term Object ISubstitutions -> (U ISubstitutions Fail)]) 58 | 59 | (declare-protocols ILVar) 60 | 61 | (ann-protocol IUnifyWithLVar 62 | unify-with-lvar [Term ILVar ISubstitutions -> (U ISubstitutions Fail)]) 63 | 64 | (declare-protocols LConsSeq) 65 | 66 | (ann-protocol IUnifyWithLSeq 67 | unify-with-lseq [Term LConsSeq ISubstitutions -> (U ISubstitutions Fail)]) 68 | 69 | (ann-protocol IUnifyWithSequential 70 | unify-with-seq [Term Sequential ISubstitutions -> (U ISubstitutions Fail)]) 71 | 72 | (ann-protocol IUnifyWithMap 73 | unify-with-map [Term (IPersistentMap Any Any) ISubstitutions -> (U ISubstitutions Fail)]) 74 | 75 | (ann-protocol IUnifyWithSet 76 | unify-with-Set [Term (IPersistentSet Any) ISubstitutions -> (U ISubstitutions Fail)]) 77 | 78 | (ann-protocol IReifyTerm 79 | reify-term [Term ISubstitutions -> ISubstitutions]) 80 | 81 | (ann-protocol IWalkTerm 82 | walk-term [Term ISubstitutions -> Term]) ;TODO ? 83 | 84 | (ann-protocol IOccursCheckTerm 85 | occurs-check-term [Term Term Term -> ISubstitutions]) ;TODO ? 86 | 87 | (ann-protocol IBuildTerm 88 | build-term [Term ISubstitutions -> Any]) 89 | 90 | (ann-protocol IBind 91 | bind [Term [ISubstitutions -> Any] -> Any]) 92 | 93 | (ann-protocol IMPlus 94 | mplus [Term Term -> Any]) 95 | 96 | (ann-protocol ITake 97 | take* [Term -> Any]) 98 | 99 | (defprotocol> IUnifyTerms 100 | (unify-terms [u v s])) 101 | 102 | (defprotocol> IUnifyWithNil 103 | (unify-with-nil [v u s])) 104 | 105 | (defprotocol> IUnifyWithObject 106 | (unify-with-object [v u s])) 107 | 108 | (defprotocol> IUnifyWithLVar 109 | (unify-with-lvar [v u s])) 110 | 111 | (defprotocol> IUnifyWithLSeq 112 | (unify-with-lseq [v u s])) 113 | 114 | (defprotocol> IUnifyWithSequential 115 | (unify-with-seq [v u s])) 116 | 117 | (defprotocol> IUnifyWithMap 118 | (unify-with-map [v u s])) 119 | 120 | (defprotocol> IUnifyWithSet 121 | (unify-with-set [v u s])) 122 | 123 | (defprotocol> IReifyTerm 124 | (reify-term [v s])) 125 | 126 | (defprotocol> IWalkTerm 127 | (walk-term [v s])) 128 | 129 | (defprotocol> IOccursCheckTerm 130 | (occurs-check-term [v x s])) 131 | 132 | (defprotocol> IBuildTerm 133 | (build-term [u s])) 134 | 135 | (defprotocol> IBind 136 | (bind [this g])) 137 | 138 | (defprotocol> IMPlus 139 | (mplus [a f])) 140 | 141 | (defprotocol> ITake 142 | (take* [a])) 143 | 144 | (ann-datatype Unbound []) 145 | (deftype Unbound []) 146 | 147 | (ann unbound Unbound) 148 | (def ^Unbound unbound (Unbound.)) 149 | 150 | (ann Unbound? (predicate Unbound)) 151 | (tc-ignore 152 | (defn Unbound? [a] 153 | (identical? a unbound)) 154 | ) 155 | 156 | (ann-protocol ILVar 157 | constraints [ILVar -> (U nil (IPersistentSet Term))] 158 | add-constraint [ILVar Term -> ILVar] 159 | add-constraints [ILVar (Seqable Term) -> ILVar] 160 | remove-constraint [ILVar Term -> ILVar] 161 | remove-constraints [ILVar -> ILVar]) 162 | 163 | (defprotocol> ILVar 164 | (constraints [this]) 165 | (add-constraint [this c]) 166 | (add-constraints [this ds]) 167 | (remove-constraint [this c]) 168 | (remove-constraints [this])) 169 | 170 | ;; ============================================================================= 171 | ;; Pair 172 | 173 | (ann-protocol IPair 174 | lhs [IPair -> Any] 175 | rhs [IPair -> Any]) 176 | 177 | (defprotocol> IPair 178 | (lhs [this]) 179 | (rhs [this])) 180 | 181 | (ann-datatype Pair [lhs :- Term 182 | rhs :- Term]) 183 | (deftype Pair [lhs rhs] 184 | clojure.lang.Counted 185 | (count [_] 2) 186 | clojure.lang.Indexed 187 | (nth [_ i] (case i 188 | 0 lhs 189 | 1 rhs 190 | (throw (IndexOutOfBoundsException.)))) 191 | (nth [_ i not-found] (case i 192 | 0 lhs 193 | 1 rhs 194 | not-found)) 195 | IPair 196 | (lhs [_] lhs) 197 | (rhs [_] rhs) 198 | java.util.Map$Entry 199 | (getKey [_] lhs) 200 | (getValue [_] rhs) 201 | Object 202 | (toString [_] 203 | (str "(" lhs " . " rhs ")"))) 204 | 205 | (ann pair [Term Term -> Pair]) 206 | (defn- ^Pair pair [lhs rhs] 207 | (Pair. lhs rhs)) 208 | 209 | ;; ============================================================================= 210 | ;; Substitutions 211 | 212 | (ann-protocol ISubstitutions 213 | length [ISubstitutions -> Number] 214 | occurs-check [ISubstitutions Term Term -> (U true false)] 215 | ext [ISubstitutions Term Term -> (U nil ISubstitutions)] 216 | ext-no-check [ISubstitutions Term Term -> ISubstitutions] 217 | swap [ISubstitutions Any -> Any] ;TODO 218 | constrain [ISubstitutions ILVar Term -> ISubstitutions] ;TODO 3rd arg? 219 | use-verify [ISubstitutions [ISubstitutions Term Term -> ISubstitutions] -> ISubstitutions] 220 | walk-var [ISubstitutions Term -> Term] 221 | walk [ISubstitutions Term -> Term] 222 | walk* [ISubstitutions Term -> Term] 223 | unify [ISubstitutions Term Term -> (U ISubstitutions Fail)] 224 | update [ISubstitutions Term Term -> Term] ;return? 225 | reify-lvar-name [ISubstitutions -> Symbol] 226 | -reify* [ISubstitutions Term -> ISubstitutions] 227 | -reify [ISubstitutions Term -> ISubstitutions] 228 | build [ISubstitutions Term -> ISubstitutions]) 229 | 230 | (defprotocol> ISubstitutions 231 | (length [this]) 232 | (occurs-check [this u v]) 233 | (ext [this u v]) 234 | (ext-no-check [this u v]) 235 | (swap [this cu]) 236 | (constrain [this u c]) 237 | (get-var [this v]) 238 | (use-verify [this f]) 239 | (walk [this v]) 240 | (walk-var [this v]) 241 | (walk* [this v]) 242 | (unify [this u v]) 243 | (reify-lvar-name [_]) 244 | (-reify* [this v]) 245 | (-reify [this v]) 246 | (build [this u])) 247 | 248 | (declare-datatypes Substitutions) 249 | 250 | (ann empty-s Substitutions) 251 | (declare empty-s) 252 | 253 | (declare-datatypes Choice) 254 | 255 | ;TODO 256 | (ann choice [Any [Any -> Any] -> Choice]) 257 | (declare choice) 258 | 259 | (ann-datatype LVar [name :- Symbol 260 | hash :- Number 261 | cs :- Any 262 | meta :- Any] 263 | :unchecked-ancestors #{Term}) 264 | 265 | (ann lvar (Fn [-> LVar] 266 | [Symbol -> LVar] 267 | [Symbol Any -> LVar])) ;TODO second arg is a cs 268 | (declare lvar) 269 | 270 | ;TODO filters 271 | (ann lvar? (predicate LVar)) 272 | (declare lvar?) 273 | 274 | (declare pair) 275 | (declare lcons) 276 | 277 | (ann-datatype Substitutions [s :- (IPersistentMap ILVar (U Unbound Term)) 278 | l :- (IPersistentList Pair) ;[l :- (IPersistentList (Pair LVar Term))] 279 | verify :- [ISubstitutions Term Term -> ISubstitutions] 280 | cs :- Any] ;TODO constraint store 281 | ) 282 | 283 | (deftype Substitutions [s l verify cs] 284 | Object 285 | (equals [this o] 286 | (or (identical? this o) 287 | (and (.. this getClass (isInstance o)) 288 | (= s ^clojure.lang.PersistentHashMap (.s ^Substitutions o))))) 289 | (toString [_] 290 | (prn-str [s l verify cs])) 291 | 292 | ISubstitutions 293 | (length [this] (count s)) 294 | 295 | (occurs-check [this u v] 296 | (let [v (walk this v)] 297 | (occurs-check-term v u this))) 298 | 299 | (ext [this u v] 300 | (if (and *occurs-check* (occurs-check this u v)) 301 | nil 302 | (ext-no-check this u v))) 303 | 304 | (ext-no-check [this u v] 305 | (verify this u v)) 306 | 307 | (swap [this cu] 308 | (if (contains? s cu) 309 | (let [v (s cu)] 310 | (Substitutions. (-> s (dissoc cu) (assoc cu v)) l verify cs)) 311 | (Substitutions. (assoc s cu unbound) l verify cs))) 312 | 313 | (constrain [this u c] 314 | (let [u (walk this u)] 315 | (swap this (add-constraint u c)))) 316 | 317 | (get-var [this v] 318 | (first (find s v))) 319 | 320 | (use-verify [this f] 321 | (Substitutions. s l f cs)) 322 | 323 | ;Need equality filters for this to type check. 324 | (walk [this v] 325 | (loop> [[lv :- Term] v 326 | [[v vp] :- (U nil (Vector* ILVar (U Unbound Term)))] (find s v)] 327 | (cond 328 | (nil? v) lv 329 | ;created predicate for singleton type 330 | (Unbound? vp) v 331 | (not (lvar? vp)) vp 332 | :else (recur vp (find s vp))))) 333 | 334 | ; (walk [this v] 335 | ; (loop> [[lv :- Term] v 336 | ; [fr :- (U nil (Vector* ILVar (U Unbound Term)))] (find s v)] 337 | ; (let [v (nth fr 0) 338 | ; vp (nth fr 1)] 339 | ; (cond 340 | ; (nil? v) lv 341 | ; ;created predicate for singleton type 342 | ; (Unbound? vp) v 343 | ; (not (lvar? vp)) vp 344 | ; :else (recur vp (find s vp)))))) 345 | 346 | ;walk-var same as walk above... 347 | (walk-var [this v] 348 | (loop> [[lv :- Term] v 349 | [fr :- (U nil (Vector* ILVar (U Unbound Term)))] (find s v)] 350 | (let [v (nth fr 0 nil) 351 | vp (nth fr 1 nil)] 352 | (cond 353 | (nil? v) lv 354 | (Unbound? vp) v 355 | (not (lvar? vp)) v 356 | :else (recur vp (find s vp)))))) 357 | 358 | (walk* [this v] 359 | (let [v (walk this v)] 360 | (walk-term v this))) 361 | 362 | (unify [this u v] 363 | (if (identical? u v) 364 | this 365 | (let [u (walk this u) 366 | v (walk this v)] 367 | (if (identical? u v) 368 | this 369 | (unify-terms u v this))))) 370 | 371 | (reify-lvar-name [this] 372 | (symbol (str "_." (count s)))) 373 | 374 | (-reify* [this v] 375 | (let [v (walk this v)] 376 | (reify-term v this))) 377 | 378 | (-reify [this v] 379 | (let [v (walk* this v)] 380 | (walk* (-reify* empty-s v) v))) 381 | 382 | (build [this u] 383 | (build-term u this)) 384 | 385 | IBind 386 | (bind [this g] 387 | (g this)) 388 | IMPlus 389 | (mplus [this f] 390 | (choice this f)) 391 | ITake 392 | (take* [this] this)) 393 | 394 | (defn- ^Substitutions pass-verify [^Substitutions s u v] 395 | (Substitutions. (assoc (.s s) u v) 396 | (cons (pair u v) (.l s)) 397 | (.verify s) 398 | (.cs s))) 399 | 400 | (ann make-s (Fn [-> Substitutions] 401 | [(IPersistentMap Term Term) -> Substitutions] 402 | [(IPersistentMap Term Term) (Seqable Any) -> Substitutions] 403 | [(IPersistentMap Term Term) (Seqable Any) (IPersistentVector Any) -> Substitutions])) 404 | (defn- ^Substitutions make-s 405 | ([m l] (Substitutions. m l pass-verify nil)) 406 | ([m l f] (Substitutions. m l f nil)) 407 | ([m l f cs] (Substitutions. m l f cs))) 408 | 409 | (def ^Substitutions empty-s (make-s {} '())) 410 | 411 | (defn- subst? [x] 412 | (instance? Substitutions x)) 413 | 414 | (defn ^Substitutions to-s [v] 415 | (let [s (reduce (fn [m [k v]] (assoc m k v)) {} v) 416 | l (reduce (fn [l [k v]] (cons (Pair. k v) l)) '() v)] 417 | (make-s s l))) 418 | -------------------------------------------------------------------------------- /test/typed/test/conduit.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.conduit 2 | (:import (clojure.lang Seqable IMeta IPersistentMap LazySeq ISeq)) 3 | (:require [typed.core :refer [check-ns ann fn> def-alias tc-ignore ann-form declare-names inst 4 | print-env inst-ctor cf Option declare-alias-kind AnyInteger]] 5 | [clojure.repl :refer [pst]] 6 | [arrows.core :refer [defarrow]])) 7 | 8 | (def-alias Result 9 | (TFn [[x :variance :covariant]] 10 | (U nil ;stream is closed 11 | '[] ;abort/skip 12 | '[x];consume/continue 13 | ))) 14 | 15 | (def-alias Cont 16 | (TFn [[in :variance :covariant] 17 | [out :variance :invariant]] 18 | [(Option [(Result in) -> (Result out)]) -> (Result out)])) 19 | 20 | (declare-alias-kind ==> (TFn [[in :variance :contravariant] 21 | [out :variance :invariant]] Any)) 22 | 23 | (def-alias ==> 24 | (TFn [[in :variance :contravariant] 25 | [out :variance :invariant]] 26 | [in -> '[(U nil (==> in out)) (Cont out out)]])) 27 | 28 | (ann abort-c (All [x] (Cont x x))) 29 | (defn abort-c [c] 30 | (when c 31 | (c []))) 32 | 33 | (ann conduit-seq-fn 34 | (All [x] 35 | [(Seqable x) -> (==> Any x)])) 36 | (defn conduit-seq-fn [l] 37 | (fn curr-fn [_] 38 | (let [new-f (conduit-seq-fn (rest l))] 39 | (if (empty? l) 40 | [nil abort-c] 41 | [new-f 42 | (-> 43 | (fn [c] 44 | (when c ;`when` added to conform to Cont type - Ambrose 45 | (c [(first l)]))) 46 | (ann-form (Cont x x)))])))) 47 | 48 | (ann conduit-seq 49 | (All [x] 50 | [(Seqable x) -> (==> Any x)])) 51 | (defn conduit-seq 52 | "create a stream processor that emits the contents of a list 53 | regardless of what is fed to it" 54 | [l] 55 | ((inst conduit-seq-fn x) l)) 56 | 57 | (ann a-run 58 | (All [x] 59 | [(==> Any x) -> (Seqable x)])) 60 | (defn a-run 61 | "execute a stream processor function" 62 | [f] 63 | (let [[new-f c] (f nil) 64 | y (c identity)] 65 | (cond 66 | (nil? new-f) (list) 67 | (empty? y) (recur new-f) 68 | :else (lazy-seq 69 | (cons (first y) 70 | (a-run new-f)))))) 71 | 72 | (ann comp-fn2 73 | (All [x y z] 74 | [(==> x y) (==> y z) -> (==> x z)])) 75 | (defn comp-fn2 [f1 f2] 76 | (fn curr-fn [x] 77 | (let [[new-f1 first-c] (f1 x) 78 | y (first-c identity) 79 | [new-f2 new-c] (if (empty? y) 80 | [f2 abort-c] 81 | (f2 (first y)))] 82 | [(when (and new-f1 new-f2) 83 | ((inst comp-fn2 x y z) new-f1 new-f2)) 84 | new-c]))) 85 | 86 | ;Type only works for vectors of length 2 87 | (ann nth-fn 88 | (All [x y z] 89 | (Fn ['0 (U nil (==> x z)) -> (==> '[x y] '[z y])] 90 | ['1 (U nil (==> y z)) -> (==> '[x y] '[x z])]))) 91 | (tc-ignore 92 | (defn nth-fn [n f] 93 | (fn curr-fn [xs] 94 | (cond 95 | (<= (count xs) n) [curr-fn abort-c] 96 | (nil? f) [nil abort-c] ;added - Ambrose 97 | :else 98 | (let [[new-f new-c] (f (nth xs n)) 99 | _ (print-env "after new-f") 100 | next-c (ann-form 101 | (fn [c] 102 | (if (nil? c) 103 | (do (new-c nil) 104 | nil) 105 | (let [y (new-c identity)] 106 | (if (empty? y) 107 | (c []) 108 | (c [(assoc xs n (first y))]))))) 109 | (Fn [(U nil [(Result '[x y]) -> (Result '[z y])]) -> (Result '[z y])] 110 | [(U nil [(Result '[x y]) -> (Result '[x z])]) -> (Result '[x z])]))] 111 | [((inst nth-fn x y z) n new-f) next-c])))) 112 | ) 113 | 114 | (declare-names AParCtor) 115 | 116 | (ann par-fn AParCtor) 117 | (defn par-fn [f1 f2] 118 | (fn curr-fn [[x1 x2 :as xs]] 119 | (if (= (count xs) 2) 120 | (let [[new-f1 c1] (f1 x1) 121 | [new-f2 c2] (f2 x2)] 122 | (if (and new-f1 new-f2) 123 | [(par-fn new-f1 new-f2) 124 | (-> 125 | (fn [c] 126 | (if (nil? c) 127 | (do 128 | (c1 nil) 129 | (c2 nil)) 130 | (let [y1 (c1 identity) 131 | y2 (c2 identity)] 132 | (if (some empty? [y1 y2]) 133 | (c []) 134 | (c [(concat y1 y2)]))))) 135 | (ann-form (Cont '[z a] '[z a])))]) 136 | [curr-fn abort-c]) 137 | [curr-fn abort-c]))) 138 | 139 | (declare-names ASelectCtor) 140 | 141 | (ann select-fn ASelectCtor) 142 | (defn select-fn [selection-map] 143 | (fn curr-fn [[v x]] 144 | (if-let [f (ann-form (or (get selection-map v) 145 | (get selection-map '_)) 146 | (U nil (==> y z)))] 147 | (let [[new-f c] (f x)] 148 | (if new-f 149 | [(select-fn (assoc selection-map v new-f)) c] 150 | [curr-fn abort-c]) 151 | [curr-fn abort-c])))) 152 | 153 | (tc-ignore 154 | (defn loop-fn 155 | ([f prev-x] 156 | (fn curr-fn [x] 157 | (let [[new-f c] (f [prev-x x]) 158 | y (c identity)] 159 | (if (empty? y) 160 | [curr-fn abort-c] 161 | [(loop-fn new-f (first y)) (fn [c] 162 | (when c 163 | (c y)))])))) 164 | ([f fb-f prev-x] 165 | (fn curr-fn [x] 166 | (let [[new-f c] (f [prev-x x]) 167 | y (c identity)] 168 | (if (empty? y) 169 | [curr-fn abort-c] 170 | (let [[new-fb fb-c] (fb-f (first y)) 171 | fb-y (fb-c identity)] 172 | (if (empty? fb-y) 173 | [curr-fn abort-c] 174 | [(loop-fn new-f new-fb (first fb-y)) 175 | (fn [c] 176 | (when c 177 | (c y)))]))))))) 178 | ) 179 | 180 | (def-alias AArrCtor 181 | (All [x y] 182 | [[x -> y] -> (==> x y)])) 183 | 184 | (def-alias ACompCtor 185 | (All [x y z] 186 | [(==> x y) (==> y z) -> (==> x z)])) 187 | 188 | ; second arg is an arrow updating the entry named by the first argument 189 | (def-alias ANthCtor 190 | (All [x y z] 191 | (Fn ['0 (==> x z) -> (==> '[x y] '[z y])] 192 | ['1 (==> y z) -> (==> '[x y] '[x z])]))) 193 | 194 | (def-alias AParCtor 195 | (All [x y z a] 196 | [(==> x z) (==> y a) -> (==> '[x y] '[z a])])) 197 | 198 | (def-alias AAllCtor 199 | (All [x y z] 200 | [(==> x y) (==> x z) -> (==> x '[y z])])) 201 | 202 | (def-alias ASelectCtor 203 | (All [x y z] 204 | [(IPersistentMap x (==> y z)) -> (==> '[x y] (==> y z))])) 205 | 206 | (def-alias ALoopCtor 207 | (All [state in] 208 | [(==> '[state in] state) state -> (==> in state)])) 209 | 210 | (ann conduit '{:a-arr AArrCtor :a-comp ACompCtor :a-nth ANthCtor :a-par AParCtor 211 | :a-all AAllCtor :a-select ASelectCtor 212 | ;:a-loop ALoopCtor 213 | }) 214 | (defarrow conduit 215 | [a-arr (-> 216 | (fn [f] 217 | (fn a-arr [x] 218 | (let [y (f x) 219 | c (-> 220 | (fn [c] 221 | (when c 222 | (c [y]))) 223 | (ann-form (Cont y y)))] 224 | [a-arr c]))) 225 | (ann-form AArrCtor)) 226 | 227 | a-comp (-> 228 | (fn [p1 p2] 229 | ((inst comp-fn2 x y z) p1 p2)) 230 | (ann-form ACompCtor)) 231 | 232 | ;apply p to position n in passed pair 233 | ;eg. increment second element of each list 234 | ; (conduit-map (a-nth 1 (a-arr inc)) [[3 5] [3 4]]) 235 | ;([3 6] [3 5]) 236 | a-nth (ann-form 237 | (fn [n p] 238 | ((inst nth-fn x y z) n p)) 239 | ANthCtor) 240 | 241 | ;like juxt 242 | ;modified to accept 2 arrows rather than n arrows 243 | a-par (ann-form par-fn AParCtor) 244 | 245 | ;apply functions to lhs and rhs of pairs 246 | ; modified to accept 2 arrows instead of n arrows 247 | a-all (ann-form 248 | (fn [p1 p2] 249 | (ann-form 250 | ((inst a-comp x '[x x] '[y z]) 251 | (ann-form 252 | (a-arr (ann-form #(vector % %) 253 | [x -> '[x x]])) 254 | (==> x '[x x])) 255 | (ann-form 256 | ((inst a-par x x y z) p1 p2) 257 | (==> '[x x] '[y z]))) 258 | (==> x '[y z]))) 259 | AAllCtor) 260 | 261 | ;select a value 262 | a-select (ann-form 263 | (fn [pair-map] 264 | ((inst select-fn x y z) pair-map)) 265 | ASelectCtor) 266 | 267 | ; a-loop (ann-form 268 | ; (fn 269 | ; ([p initial-value] 270 | ; (loop-fn p initial-value)) 271 | ; ([p initial-value fb-p] 272 | ; (loop-fn p fb-p initial-value))) 273 | ; ALoopCtor) 274 | ]) 275 | 276 | 277 | (ann a-arr AArrCtor) 278 | (def a-arr (:a-arr conduit)) 279 | (ann a-comp ACompCtor) 280 | (def a-comp (:a-comp conduit)) 281 | (ann a-nth ANthCtor) 282 | (def a-nth (:a-nth conduit)) 283 | (ann a-par AParCtor) 284 | (def a-par (:a-par conduit)) 285 | (ann a-all AAllCtor) 286 | (def a-all (:a-all conduit)) 287 | (ann a-select ASelectCtor) 288 | (def a-select (:a-select conduit)) 289 | ;(ann a-loop ALoopCtor) 290 | ;(def a-loop (conduit :a-loop)) 291 | 292 | (ann conduit-map 293 | (All [x y] 294 | [(==> x y) (Option (Seqable x)) -> (Option (Seqable y))])) 295 | (defn conduit-map [p l] 296 | (if (empty? l) 297 | l 298 | (a-run ((inst a-comp Any x y) 299 | (conduit-seq l) p)))) 300 | 301 | (ann pass-through 302 | (All [x] 303 | (==> x x))) 304 | (def pass-through 305 | (a-arr (inst identity x))) 306 | 307 | 308 | 309 | 310 | ; TEST 311 | 312 | 313 | #_(tc-ignore 314 | (cf ((inst a-run clojure.lang.Keyword) 315 | (conduit-seq-fn [:a :b :c])) 316 | ) 317 | ) 318 | 319 | (ann pl (==> Number Number)) 320 | (def pl ((inst a-arr Number Number) inc)) 321 | 322 | (ann t2 (==> Number Number)) 323 | (def t2 (a-arr (ann-form #(* 2 %) [Number -> Number]))) 324 | 325 | (ann flt (==> AnyInteger AnyInteger)) 326 | (def flt (fn this-fn [x] 327 | (if (odd? x) 328 | [this-fn abort-c] 329 | [this-fn (ann-form (fn [c] (when c 330 | (c [x]))) 331 | (Cont AnyInteger AnyInteger))]))) 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | ;(ann a-selectp 344 | ; (All [x y z a] 345 | ; [[x -> y] (IPersistentMap y (==> z a)) -> (==> '[x z] a)])) 346 | ;(defn a-selectp [pred pair-map] 347 | ; (a-comp 348 | ; (ann-form 349 | ; (a-all (ann-form (a-arr pred) 350 | ; (==> x y)) 351 | ; pass-through) 352 | ; (==> x '[y x])) 353 | ; (a-select pair-map))) 354 | 355 | ;TODO this should type correctly 356 | ;(cf (a-arr (constantly nil))) 357 | 358 | ;(cf (a-arr (ann-form (fn [_] nil) 359 | ; ['x -> nil]))) 360 | ; 361 | ;(ann t1 (All [x] [[Any -> x] -> [x -> Any]])) 362 | ;(declare t1) 363 | ;(cf (t1 (ann-form (fn [_] nil) 364 | ; ['x -> nil]))) 365 | 366 | ;(ann a-if 367 | ; (All [x y] 368 | ; (Fn [[x -> Any] (==> x y) -> (==> x (U y nil))] 369 | ; [[x -> Any] (==> x y) (Option (==> x y)) -> (==> x (U y nil))]))) 370 | ;(defn a-if 371 | ; ([a b] (a-if a b nil)) 372 | ; ([a b c] 373 | ; (let [c (ann-form (or c (a-arr (ann-form (fn [_] nil) 374 | ; [x -> nil]))) 375 | ; (==> x (U nil y)))] 376 | ; (a-comp (-> 377 | ; (a-all (a-arr (comp boolean a)) 378 | ; pass-through) 379 | ; (ann-form (==> x '[boolean x]))) 380 | ; (-> 381 | ; (a-select 382 | ; {true b 383 | ; false c}) 384 | ; (ann-form (==> '[boolean x] (U y nil)))))))) 385 | ; 386 | ;(defn a-catch 387 | ; ([p catch-p] 388 | ; (a-catch Exception p catch-p)) 389 | ; ([class p catch-p] 390 | ; (letfn [(a-catch [f catch-f] 391 | ; (fn [x] 392 | ; (try 393 | ; (let [[new-f c] (f x)] 394 | ; [(a-catch f catch-f) c]) 395 | ; (catch Throwable e 396 | ; (if (instance? class e) 397 | ; (let [[new-catch c] (catch-f [e x])] 398 | ; [(a-catch f new-catch) c]) 399 | ; (throw e))))))] 400 | ; (with-meta 401 | ; (a-catch p catch-p) 402 | ; {:parts (:parts p) 403 | ; :created-by :a-catch 404 | ; :args [class p catch-p]})))) 405 | ; 406 | ;(defn a-finally [p final-p] 407 | ; (letfn [(a-finally [f final-f] 408 | ; (fn [x] 409 | ; (try 410 | ; (let [[new-f c] (f x)] 411 | ; [(a-finally new-f final-f) c]) 412 | ; (finally 413 | ; (final-f x)))))] 414 | ; (with-meta 415 | ; (a-finally p final-p) 416 | ; {:parts (:parts p) 417 | ; :created-by :a-finally 418 | ; :args [p final-p]}))) 419 | ; 420 | ;(defmacro def-arr [name args & body] 421 | ; `(def ~name (a-arr (fn ~name ~args ~@body)))) 422 | ; 423 | ;(defn a-filter [f] 424 | ; (with-meta 425 | ; (fn curr-fn [x] 426 | ; (if (f x) 427 | ; [curr-fn (fn [c] 428 | ; (when c 429 | ; (c [x])))] 430 | ; [curr-fn abort-c])) 431 | ; {:created-by :a-filter 432 | ; :args f})) 433 | ; 434 | ;(defn tap [p] 435 | ; (fn [x] 436 | ; (let [[new-f new-c] (p x)] 437 | ; (new-c nil) 438 | ; [new-f (fn [c] 439 | ; (when c 440 | ; (c [x])))]))) 441 | ; 442 | ;(defn disperse [p] 443 | ; (with-meta 444 | ; (fn curr-fn [xs] 445 | ; (if (empty? xs) 446 | ; [curr-fn (fn [c] 447 | ; (when c 448 | ; (c [xs])))] 449 | ; (let [[new-f cs] (reduce (fn [[new-f cs] x] 450 | ; (let [[new-f c] (new-f x)] 451 | ; [new-f (conj cs c)])) 452 | ; [p []] 453 | ; xs)] 454 | ; [(disperse new-f) (fn [c] 455 | ; (if (nil? c) 456 | ; (doseq [c cs] 457 | ; (c nil)) 458 | ; (let [ys (map #(% identity) cs)] 459 | ; (if (some empty? ys) 460 | ; (c []) 461 | ; (c [(apply concat ys)])))))]))) 462 | ; {:created-by :disperse 463 | ; :args p 464 | ; :parts (:parts p)})) 465 | ; 466 | ;(defn enqueue [f x] 467 | ; ((second (f x)) nil) 468 | ; nil) 469 | ; 470 | ;(defn wait-for-reply [f x] 471 | ; ((second (f x)) identity)) 472 | -------------------------------------------------------------------------------- /test/typed/test/rbt.clj: -------------------------------------------------------------------------------- 1 | (ns typed.test.rbt 2 | (:require [typed.core :refer [ann inst cf fn> pfn> def-alias declare-names 3 | print-env print-filterset check-ns]] 4 | [clojure.repl :refer [pst]] 5 | [analyze.core :refer [ast]])) 6 | 7 | (def-alias EntryT (HMap {:key Number 8 | :datum Number})) ;TODO is this EntryT type correct? No definition in thesis 9 | 10 | (declare-names rbt bt) 11 | 12 | ;Trees with only black children for red nodes 13 | (def-alias rbt (U 14 | ;Empty 15 | (HMap {:tree (Value :Empty)}) 16 | ;Black 17 | (HMap {:tree (Value :Black) 18 | :entry EntryT 19 | :left rbt 20 | :right rbt}) 21 | ;Red 22 | (HMap {:tree (Value :Red) 23 | :entry EntryT 24 | :left bt 25 | :right bt}))) 26 | 27 | ;As above but additionally the root node is black 28 | (def-alias bt (U 29 | ;Empty 30 | (HMap {:tree (Value :Empty)}) 31 | ;Black 32 | (HMap {:tree (Value :Black) 33 | :entry EntryT 34 | :left rbt 35 | :right rbt}))) 36 | 37 | ; Trees with a red root 38 | (def-alias red (U 39 | ;Red 40 | (HMap {:tree (Value :Red) 41 | :entry EntryT 42 | :left bt 43 | :right bt}))) 44 | 45 | ;invariant possibly violated at the root 46 | (def-alias badRoot (U 47 | ;Empty 48 | (HMap {:tree (Value :Empty)}) 49 | ;Black 50 | (HMap {:tree (Value :Black) 51 | :entry EntryT 52 | :left rbt 53 | :right bt}) 54 | ;Red 55 | (HMap {:tree (Value :Red) 56 | :entry EntryT 57 | :left rbt 58 | :right bt}) 59 | ;Red 60 | (HMap {:tree (Value :Red) 61 | :entry EntryT 62 | :left bt 63 | :right rbt}))) 64 | 65 | ;invariant possibly violated at the left child 66 | (def-alias badLeft (U 67 | ;Empty 68 | (HMap {:tree (Value :Empty)}) 69 | ;Black 70 | (HMap {:tree (Value :Black) 71 | :entry EntryT 72 | :left rbt 73 | :right rbt}) 74 | ;Red 75 | (HMap {:tree (Value :Red) 76 | :entry EntryT 77 | :left bt 78 | :right bt}) 79 | ;Black 80 | (HMap {:tree (Value :Black) 81 | :entry EntryT 82 | :left badRoot 83 | :right rbt}))) 84 | 85 | ;invariant possibly violated at the right child 86 | (def-alias badRight (U 87 | ;Empty 88 | (HMap {:tree (Value :Empty)}) 89 | ;Black 90 | (HMap {:tree (Value :Black) 91 | :entry EntryT 92 | :left rbt 93 | :right rbt}) 94 | ;Red 95 | (HMap {:tree (Value :Red) 96 | :entry EntryT 97 | :left bt 98 | :right bt}) 99 | ;Black 100 | (HMap {:tree (Value :Black) 101 | :entry EntryT 102 | :left rbt 103 | :right badRoot}))) 104 | 105 | (comment 106 | (update-composite {'tmap (->Name 'typed.test.rbt/badRight)} 107 | (-or 108 | (-not-filter (-val :Black) 'tmap [(->KeyPE :tree)]) 109 | (-and 110 | (-filter (-val :Black) 'tmap [(->KeyPE :tree)]) 111 | 112 | (-or 113 | (-not-filter (-val :Red) 'tmap [(->KeyPE :left) (->KeyPE :tree)]) 114 | (-and 115 | (-filter (-val :Red) 'tmap [(->KeyPE :left) (->KeyPE :tree)]) 116 | (-or 117 | (-not-filter (-val :Red) 'tmap [(->KeyPE :right) (->KeyPE :tree)]) 118 | (-and 119 | (-filter (-val :Red) 'tmap [(->KeyPE :right) (->KeyPE :tree)]) 120 | (-not-filter (-val :Red) 'tmap [(->KeyPE :right) (->KeyPE :left) (->KeyPE :tree)])))))))) 121 | 122 | #_(-or 123 | (-not-filter (-val :Black) [(->KeyPE :tree)] tmap) 124 | (-and 125 | (-filter (-val :Black) [(->KeyPE :tree)] tmap) 126 | 127 | (-or 128 | (-not-filter (-val :Red) [(->KeyPE :left) (->KeyPE :tree)] tmap) 129 | (-and 130 | (-filter (-val :Red) [(->KeyPE :left) (->KeyPE :tree)] tmap) 131 | (-or 132 | (-not-filter (-val :Red) [(->KeyPE :right) (->KeyPE :tree)] tmap) 133 | (-and 134 | (-filter (-val :Red) [(->KeyPE :right) (->KeyPE :tree)] tmap) 135 | (-not-filter (-val :Red) [(->KeyPE :right) (->KeyPE :left) (->KeyPE :tree)] tmap))))))) 136 | 137 | ;output of the :else of first branch 138 | (let [fs (read-string "#typed.core.FilterSet{:then #typed.core.AndFilter{:fs #{#typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :right} #typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :right} #typed.core.KeyPE{:val :tree}), :id tmap}}}, :else #typed.core.OrFilter{:fs #{#typed.core.AndFilter{:fs #{#typed.core.OrFilter{:fs #{#typed.core.AndFilter{:fs #{#typed.core.NotTypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap}}} #typed.core.AndFilter{:fs #{#typed.core.OrFilter{:fs #{#typed.core.AndFilter{:fs #{#typed.core.NotTypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :right} #typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :right} #typed.core.KeyPE{:val :tree}), :id tmap}}} #typed.core.AndFilter{:fs #{#typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.NotTypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :right} #typed.core.KeyPE{:val :tree}), :id tmap}}}}} #typed.core.TypeFilter{:type #typed.core.Value{:val :Red}, :path (#typed.core.KeyPE{:val :left} #typed.core.KeyPE{:val :tree}), :id tmap} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap}}}}} #typed.core.TypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap}}} #typed.core.NotTypeFilter{:type #typed.core.Value{:val :Black}, :path (#typed.core.KeyPE{:val :tree}), :id tmap}}}}")] 139 | 140 | (-> 141 | (env+ (->PropEnv {'tmap (->Name 'typed.test.rbt/badRight)} 142 | []) 143 | [(:else fs)] 144 | (atom true)) 145 | :l (get 'tmap))) 146 | ) 147 | 148 | ; restore-right (Black (e,l,r)) >=> dict 149 | ; where (1) Black(e,l,r) is ordered, 150 | ; (2) Black (e,l,r) hash black height n, 151 | ; (3) color invariant may be violated at the root of r: 152 | ; one of its children must be red. 153 | ; and dict is re-balanced red/black tree (satisfying all inv's) 154 | ; and the same black height n. 155 | 156 | (ann restore-right 157 | (Fn [badRight -> rbt])) 158 | (defn restore-right [tmap] 159 | (cond 160 | (print-filterset "TEST1" 161 | (and (= :Black (-> tmap :tree)) 162 | (= :Red (-> tmap :left :tree)) 163 | (= :Red (-> tmap :right :tree)) 164 | (= :Red (-> tmap :right :left :tree)))) 165 | (let [;_ (print-env "down first then") 166 | {lt :left rt :right e :entry} tmap 167 | ;re-color 168 | res {:tree :Red 169 | :entry e 170 | :left (assoc lt 171 | :tree :Black) 172 | :right (assoc rt 173 | :tree :Black)}] 174 | ;(print-env "restore-right: output first branch (res)") 175 | res) 176 | 177 | (print-filterset "TEST2" 178 | (and (= :Black (-> tmap :tree)) 179 | (= :Red (-> tmap :left :tree)) 180 | (= :Red (-> tmap :right :tree)) 181 | (= :Red (-> tmap :right :left :tree)))) 182 | (let [{lt :left rt :right e :entry} tmap 183 | ;re-color 184 | res {:tree :Red 185 | :entry e 186 | :left (assoc lt 187 | :tree :Black) 188 | :right (assoc rt 189 | :tree :Black)}] 190 | (print-env "restore-right: output second branch (res)") 191 | res) 192 | 193 | (print-filterset "TEST3" 194 | (and (= :Black (-> tmap :tree)) 195 | (= :Red (-> tmap :right :tree)) 196 | (= :Red (-> tmap :right :left :tree)))) 197 | (let [{e :entry 198 | l :left 199 | {re :entry 200 | {rle :entry 201 | rll :left 202 | rlr :right} :left 203 | rr :right} :right} tmap 204 | ;l is black, deep rotate 205 | res {:tree :Black 206 | :entry rle 207 | :left {:tree :Red 208 | :entry e 209 | :left l 210 | :right rll} 211 | :right {:tree :Red 212 | :entry re 213 | :left rlr 214 | :right rr}}] 215 | res) 216 | 217 | (and (= :Black (-> tmap :tree)) 218 | (= :Red (-> tmap :right :tree)) 219 | (= :Red (-> tmap :right :right :tree))) 220 | (let [{e :entry 221 | l :left 222 | {re :entry 223 | rl :left 224 | rr :right} :right} tmap] 225 | ;l is black, shallow rotate 226 | {:tree :Black 227 | :left {:tree :Red 228 | :entry re 229 | :left l 230 | :right rl} 231 | :right rr}) 232 | 233 | (do (print-env "final else:") 234 | :else) 235 | (do (print-env "follow final else:") 236 | tmap))) 237 | 238 | ; Okasaki's simplified rotations for red-black trees 239 | ;(Fn [badRight -> rbt]) 240 | #_(defn restore-right [tmap] 241 | (cond 242 | (and (= :Black (-> tmap :tree)) 243 | (= :Red (-> tmap :right :tree)) 244 | (= :Red (-> tmap :right :right :tree))) 245 | (let [{e :entry 246 | lt :left 247 | {re :entry 248 | rlt :left 249 | rrt :right} :right} tmap] 250 | {:tree :Red 251 | :entry re 252 | :left {:tree :Black 253 | :entry e 254 | :left lt 255 | :right rlt} 256 | :right (assoc rrt 257 | :tree :Black)}) 258 | 259 | (and (= :Black (-> tmap :tree)) 260 | (= :Red (-> tmap :right :tree)) 261 | (= :Red (-> tmap :right :left :tree))) 262 | (let [{e :entry 263 | lt :left 264 | {re :entry 265 | {rlte :entry 266 | rllt :left 267 | rlrt :right} :left 268 | rrt :right} :right} tmap] 269 | {:tree :Red 270 | :entry rlte 271 | :left {:tree :Black 272 | :entry e 273 | :left lt 274 | :right rllt} 275 | :right {:tree :Black 276 | :entry re 277 | :left rlrt 278 | :right rrt}}) 279 | 280 | :else tmap)) 281 | 282 | (ann insert (Fn [rbt EntryT -> rbt])) 283 | (defn insert [dict {:keys [key datum] :as entry}] 284 | (letfn [;; ins (Red _) may violate color invariant at root 285 | ;; ins (Black _) or ins (Empty) will be red/black tree 286 | ;; ins preserves black height 287 | 288 | ;TODO order of Function cases? 289 | ; (Fn [rbt -> badRoot] 290 | ; [bt -> rbt]) 291 | (ins [{:keys [tree] :as tmap}] 292 | (cond 293 | (= :Empty tree) {:tree :Red 294 | :entry entry 295 | :left {:tree :Empty} 296 | :right {:tree :Empty}} 297 | (= :Red tree) (let [{{key1 :key datum1 :datum :as entry1} :entry 298 | :keys [left right]} tmap] 299 | (cond 300 | (= key key1) {:tree :Red 301 | :entry entry 302 | :left left 303 | :right right} 304 | (< key key1) {:tree :Red 305 | :entry entry1 306 | :left (ins left) 307 | :right right} 308 | :else {:tree :Red 309 | :entry entry1 310 | :left left 311 | :right (ins right)})) 312 | (= :Black tree) (let [{{key1 :key datum1 :datum :as e1} :entry 313 | l :left r :right} tmap] 314 | (cond 315 | (= key key1) {:tree :Black 316 | :entry entry 317 | :left l 318 | :right r} 319 | ; (< key key1) (restore-left {:tree :Black 320 | ; :entry e1 321 | ; :left (ins l) 322 | ; :right r}) 323 | :else (restore-right {:tree :Black 324 | :entry e1 325 | :left l 326 | :right (ins r)})))))] 327 | 328 | 329 | (let [{:keys [tree l r] :as res} (ins dict)] 330 | (cond 331 | (and (= :Red tree) 332 | (= :Red (:tree l)) 333 | (= :Red (:tree r))) (assoc res 334 | :tree :Black) ;re-color 335 | :else res)))) ;depend on sequential matching 336 | --------------------------------------------------------------------------------