Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Tree: de8ce41aef
Fetching contributors…
Cannot retrieve contributors at this time
278 lines (228 sloc) 9.09 KB
(ns clojure.core.typed.frees
(:require [clojure.core.typed
[type-rep :as r]
[type-ctors :as c]
[utils :as u]
[filter-rep :as fr]
[free-ops :as free-ops]
[name-env :as nmenv]
[declared-kind-env :as kinds]])
(:import (clojure.core.typed.type_rep NotType Intersection Union FnIntersection Bounds
Projection DottedPretype Function RClass App TApp
PrimitiveArray DataType Protocol TypeFn Poly PolyDots
Mu HeterogeneousVector HeterogeneousList HeterogeneousMap
CountRange Name Value Top TopFunction B F Result AnyValue
HeterogeneousSeq Scope TCError)
(clojure.core.typed.filter_rep FilterSet TypeFilter NotTypeFilter ImpFilter
AndFilter OrFilter TopFilter BotFilter)
(clojure.core.typed.object_rep Path EmptyObject NoObject)
(clojure.core.typed.path_rep KeyPE)))
(def ^:dynamic *frees-mode* nil)
(set-validator! #'*frees-mode* #(or (= ::frees %)
(= ::idxs %)
(nil? %)))
;; Collecting frees
(def variance-map? (u/hash-c? symbol? r/variance?))
(declare frees-in)
(defn fv-variances
"Map of frees to their variances"
{:post [(variance-map? %)]}
(binding [*frees-mode* ::frees]
(frees-in t)))
(defn idx-variances
"Map of indexes to their variances"
{:post [(variance-map? %)]}
(binding [*frees-mode* ::idxs]
(frees-in t)))
(defn fv
"All frees in type"
{:post [((u/set-c? symbol?) %)]}
(set (keys (fv-variances t))))
(defn fi
"All index variables in type (dotted bounds, etc.)"
{:post [((u/set-c? symbol?) %)]}
(set (keys (idx-variances t))))
(defn flip-variances [vs]
{:pre [(variance-map? vs)]}
(into {} (for [[k vari] vs]
[k (case vari
:covariant :contravariant
:contravariant :covariant
(defn combine-frees [& frees]
{:pre [(every? variance-map? frees)]
:post [(variance-map? %)]}
(into {}
(apply merge-with (fn [old-vari new-vari]
(= old-vari new-vari) old-vari
(= old-vari :dotted) new-vari
(= new-vari :dotted) old-vari
(= old-vari :constant) new-vari
(= new-vari :constant) old-vari
:else :invariant))
(derive ::frees ::any-var)
(derive ::idxs ::any-var)
(declare frees)
(defn frees-in [t]
{:post [(variance-map? %)]}
(frees t))
(defmulti frees (fn [t] [*frees-mode* (class t)]))
(defmethod frees [::any-var Result]
[{:keys [t fl o]}]
(combine-frees (frees t)
(frees fl)
(frees o)))
;; Filters
(defmethod frees [::any-var FilterSet]
[{:keys [then else]}]
(combine-frees (frees then)
(frees else)))
(defmethod frees [::any-var TypeFilter]
[{:keys [type]}]
(frees type))
(defmethod frees [::any-var NotTypeFilter]
[{:keys [type]}]
(frees type))
(defmethod frees [::any-var ImpFilter]
[{:keys [a c]}]
(combine-frees (frees a)
(frees c)))
(defmethod frees [::any-var AndFilter]
[{:keys [fs]}]
(apply combine-frees (mapv frees fs)))
(defmethod frees [::any-var OrFilter]
[{:keys [fs]}]
(apply combine-frees (mapv frees fs)))
(defmethod frees [::any-var TopFilter] [t] {})
(defmethod frees [::any-var BotFilter] [t] {})
;; Objects
(defmethod frees [::any-var Path]
[{:keys [path]}]
(apply combine-frees (mapv frees path)))
(defmethod frees [::any-var EmptyObject] [t] {})
(defmethod frees [::any-var NoObject] [t] {})
(defmethod frees [::any-var KeyPE] [t] {})
(defmethod frees [::frees F]
[{:keys [name] :as t}]
{name :covariant})
(defmethod frees [::idxs F] [t] {})
(defmethod frees [::any-var TCError] [t] {})
(defmethod frees [::any-var B] [t] {})
(defmethod frees [::any-var CountRange] [t] {})
(defmethod frees [::any-var Value] [t] {})
(defmethod frees [::any-var AnyValue] [t] {})
(defmethod frees [::any-var Top] [t] {})
(defmethod frees [::any-var Name] [t] {})
(defmethod frees [::any-var DataType]
[{:keys [fields poly?]}]
(apply combine-frees
(mapv frees (concat (vals fields) poly?))))
(defmethod frees [::any-var HeterogeneousList]
[{:keys [types]}]
(apply combine-frees (mapv frees types)))
(defmethod frees [::any-var App]
[{:keys [rator rands]}]
(apply combine-frees (mapv frees (cons rator rands))))
(defmethod frees [::any-var TApp]
[{:keys [rator rands]}]
(apply combine-frees
(let [^TypeFn
tfn (loop [rator rator]
(r/F? rator) (when-let [bnds (free-ops/free-with-name-bnds (.name ^F rator))]
(.higher-kind bnds))
(r/Name? rator) (if (= nmenv/declared-name-type (@nmenv/TYPE-NAME-ENV (.id ^Name rator)))
(recur (kinds/get-declared-kind (.id ^Name rator)))
(recur (c/resolve-Name rator)))
(r/TypeFn? rator) rator
:else (throw (Exception. (u/error-msg "NYI case " (class rator))))))
_ (assert (r/TypeFn? tfn))]
(mapv (fn [[v arg-vs]]
(case v
:covariant arg-vs
:contravariant (flip-variances arg-vs)
:invariant (into {} (for [[k _] arg-vs]
[k :invariant]))))
(map vector (.variances tfn) (map frees rands))))))
(defmethod frees [::any-var PrimitiveArray]
[{:keys [input-type output-type]}]
(combine-frees (flip-variances (frees input-type))
(frees output-type)))
(defmethod frees [::any-var HeterogeneousSeq]
[{:keys [types]}]
(apply combine-frees (mapv frees types)))
(defmethod frees [::any-var HeterogeneousMap]
[{:keys [types]}]
(apply combine-frees (mapv frees (concat (keys types) (vals types)))))
(defmethod frees [::any-var HeterogeneousVector]
[{:keys [types filters objects]}]
(apply combine-frees (mapv frees (concat types filters objects))))
(defmethod frees [::any-var Intersection]
[{:keys [types]}]
(apply combine-frees (mapv frees types)))
(defmethod frees [::any-var Union]
[{:keys [types]}]
(apply combine-frees (mapv frees types)))
(defmethod frees [::any-var FnIntersection]
[{:keys [types]}]
(apply combine-frees (mapv frees types)))
(defmethod frees [::frees Function]
[{:keys [dom rng rest drest kws]}]
(apply combine-frees (concat (mapv (comp flip-variances frees)
(concat dom
(when rest
(when kws
[(vals kws)])))
[(frees rng)]
(when drest
[(dissoc (-> (:pre-type drest) frees flip-variances)
(:name drest))]))))
(defmethod frees [::idxs Function]
[{:keys [dom rng rest drest kws]}]
(apply combine-frees (concat (mapv (comp flip-variances frees)
(concat dom
(when rest
(when kws
(vals kws))))
[(frees rng)]
(when drest
(let [{:keys [name pre-type]} drest]
[{name :contravariant}
(-> pre-type
frees flip-variances)])))))
(defmethod frees [::any-var RClass]
(let [varis (:variances t)
args (:poly? t)]
(assert (= (count args) (count varis)))
(apply combine-frees (for [[arg va] (map vector args varis)]
(case va
:covariant (frees arg)
:contravariant (flip-variances (frees arg))
:invariant (let [fvs (frees arg)]
(into {}
(for [[k _] fvs]
[k :invariant]))))))))
(defmethod frees [::any-var Scope]
[{:keys [body]}]
(frees body))
;FIXME Type variable bounds should probably be checked for frees
(defmethod frees [::any-var TypeFn]
[{:keys [scope]}]
(frees scope))
(defmethod frees [::any-var Poly]
[{:keys [scope]}]
(frees scope))
(defmethod frees [::any-var PolyDots]
[{:keys [nbound scope]}]
(frees scope))
Jump to Line
Something went wrong with that request. Please try again.