├── .gitignore ├── LICENSE ├── README.md ├── project.clj ├── src └── bidirectional │ ├── bidirectional.clj │ ├── fn_type.clj │ ├── hmap_type.clj │ └── unit_type.clj └── test └── bidirectional └── bidirectional_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | /.lein-* 9 | /.nrepl-port 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bidirectional 2 | 3 | Explorations and Adventures in implementing "Complete and Easy Bidirectional 4 | Typechecking for Higher-Rank Polymorphism" in Clojure. 5 | 6 | http://www.cs.cmu.edu/~joshuad/papers/bidir/ 7 | 8 | Based off of the Haskell implementation by Olle Fredriksson 9 | 10 | https://github.com/ollef/Bidirectional 11 | 12 | Copyright © 2015 Nathan Sorenson 13 | 14 | Distributed under the Eclipse Public License either version 1.0 or (at 15 | your option) any later version. 16 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject bidirectional "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.6.0"] 7 | [org.clojure/core.match "0.3.0-alpha4"] 8 | [org.clojure/tools.analyzer.jvm "0.3.0"] ;; for most of the analysis 9 | [org.clojure/jvm.tools.analyzer "0.6.1" ;; just for emit-form 10 | :exclusions [org.clojure/clojure 11 | org.clojure/clojurescript]]]) 12 | -------------------------------------------------------------------------------- /src/bidirectional/bidirectional.clj: -------------------------------------------------------------------------------- 1 | (ns bidirectional.bidirectional 2 | (:require [clojure.tools.analyzer :as ta] 3 | [clojure.set :as set] 4 | [clojure.string :as str] 5 | [clojure.test :refer :all] 6 | [clojure.tools.analyzer.passes.elide-meta :as taem] 7 | [clojure.tools.analyzer.jvm :as taj] 8 | [clojure.jvm.tools.analyzer.emit-form :as tae] 9 | [clojure.core.match :refer [match]])) 10 | 11 | (defmacro <<- 12 | "reversed version of ->> for do-notation-esque things. 13 | Forms are placed as the last argument of the PRECEEDING form. 14 | eg: (<<- (1 2) (3 4) (5 6)) goes to (1 2 (3 4 (5 6))) 15 | eg: (<<- (if (nil? a) :early-exit) (inc a)) -> 16 | (if (nil? a) :early-exit (inc a)) 17 | Nice for deeply right-nested expressions." 18 | [& forms] 19 | `(->> ~@(reverse forms))) 20 | 21 | (def ann) ;; Unbound - keyword reserved for type annotations. 22 | 23 | (defn ctx-conj 24 | [ctx ctx-elem] 25 | (conj ctx ctx-elem)) 26 | 27 | (defn ctx-concat 28 | [& ctxs] 29 | (vec (apply concat ctxs))) 30 | 31 | (defn c-var-name-break 32 | "returns [ctx-left ctx-right]" 33 | [ctx c-var-name] 34 | (let [idx (ffirst (filter (fn [[i e]] (if (= (:c-var-name e) c-var-name) i nil)) (map-indexed vector ctx)))] 35 | (if (nil? idx) (throw (ex-info "Can't find element to break" {:ctx ctx :ctx-elem c-var-name})) 36 | [(subvec ctx 0 idx) 37 | (subvec ctx (inc idx) (count ctx))]))) 38 | 39 | (defn c-update-var 40 | "returns updated ctx" 41 | [ctx c-var-name f] 42 | (let [idx (ffirst (filter (fn [[i e]] (if (= (:c-var-name e) c-var-name) i nil)) (map-indexed vector ctx)))] 43 | (if (nil? idx) (throw (ex-info "Can't find element to break" {:ctx ctx :ctx-elem c-var-name})) 44 | (update-in ctx [idx] f)))) 45 | 46 | (defn ctx-break 47 | "returns [ctx-left ctx-right]" 48 | [ctx ctx-elem] 49 | (let [idx (ffirst (filter (fn [[i e]] (if (= e ctx-elem) i nil)) (map-indexed vector ctx)))] 50 | (if (nil? idx) (throw (ex-info "Can't find element to break" {:ctx ctx :ctx-elem ctx-elem})) 51 | [(subvec ctx 0 idx) 52 | (subvec ctx (inc idx) (count ctx))]))) 53 | 54 | (defn ctx-drop 55 | "I think this drops everything to the right of elem, including elem." 56 | [ctx ctx-elem] 57 | (first (ctx-break ctx ctx-elem))) 58 | 59 | (defn c-find-var 60 | "Looks up a var in context" 61 | [ctx var-name] 62 | (first (filter (fn [e] (= (:c-var-name e) var-name)) ctx))) 63 | 64 | (defn find-var-type ;; Context.hs 65 | "Looks up a var in context - returns its type or nil" 66 | [ctx var-name] 67 | (:c-typ (first (filter (fn [e] (= (:c-var-name e) var-name)) ctx)))) 68 | 69 | (defn existentials 70 | "returns a set of the existential var names" 71 | [ctx] 72 | (into #{} (map :c-var-name (filter #(#{:c-exists :c-exists-solved} (:c-op %)) ctx)))) 73 | 74 | (defmulti type-wf (fn [ctx typ] (:t-op typ))) 75 | 76 | (defmethod type-wf ::t-var [ctx typ] 77 | (contains? (into #{} (map :c-var-name (filter #(= :c-forall (:c-op %)) ctx))) 78 | (:t-var-name typ))) 79 | (defmethod type-wf ::t-forall [ctx typ] 80 | (type-wf (ctx-conj ctx {:c-op :c-forall :c-var-name (:t-var-name typ)}) 81 | (:t-ret typ))) 82 | (defmethod type-wf ::t-exists [ctx typ] 83 | (contains? (existentials ctx) 84 | (:t-var-name typ))) 85 | 86 | ;;; FIXME I'm not sure this is what this fn is doing? I think we're effectively 87 | ;;; resolving to the "leftmost" unsolved existential, even if it's not yet 88 | ;;; resolved to a monotype. Is this right/ok? 89 | (defn find-solved ;; findSolved Context.hs 90 | "returns nil or the solved monotype" 91 | [ctx var-name] 92 | (:c-typ (first (filter (fn [c-elem] (and (= :c-exists-solved (:c-op c-elem)) 93 | (= var-name (:c-var-name c-elem)))) 94 | ctx)))) 95 | 96 | (defn unsolved 97 | "returns set of unsolved existentials" 98 | [ctx] 99 | (into #{} (filter #(#{:c-exists} (:c-op %)) ctx))) 100 | 101 | (defn update-keys 102 | "update-in over parallel sibling keys, (i.e. not nested keys like update-in)" 103 | [m ks f] 104 | (reduce (fn [m k] (update-in m [k] f)) m ks)) 105 | 106 | ;;; Types are functorial 107 | (defmulti map-type (fn [f t] (:t-op t))) 108 | (defmethod map-type ::t-var [f t] t) 109 | (defmethod map-type ::t-forall [f t] (update-keys t [:t-ret] f)) 110 | 111 | (defn update-type 112 | "arg flipped map-type" 113 | [t f] (map-type f t)) 114 | 115 | (defn type-apply ;; apply Context.hs 116 | "looks up a type with the solved existentals replaced with what they're solved with? 117 | takes a type and returns a type." 118 | [ctx typ] 119 | (if (= ::t-exists (:t-op typ)) 120 | (if-let [typ' (find-solved ctx (:t-var-name typ))] 121 | (type-apply ctx typ') 122 | typ) 123 | (map-type #(type-apply ctx %) typ))) 124 | 125 | ;;; TODO Might be handy to renumber the context too (for showing unsolved existentials etc) 126 | (defn renumber-varnames 127 | "renames gensyms to something stable. Recognizes gensyms via regex so just clips off post-fix number" 128 | [typ] 129 | (let [env (atom {})] ;; exists can add names anywhere. 130 | (letfn [(fresh [typ] 131 | (let [old-name (:t-var-name typ) 132 | new-base (subs (str old-name) 0 (- (count (str old-name)) 133 | (count (re-find #"[0-9_]*" (str/reverse (str old-name)))))) 134 | new-renames (into #{} (vals @env)) 135 | new-name (->> (for [i (drop 1 (range))] (str new-base "_" i)) 136 | (cons new-base) 137 | (map symbol) 138 | (remove #(contains? new-renames %)) 139 | (first))] 140 | (swap! env assoc old-name new-name) 141 | new-name)) 142 | (renumber 143 | [typ] 144 | (case (:t-op typ) 145 | ::t-forall 146 | (->> (assoc-in typ [:t-var-name] (fresh typ)) 147 | (map-type renumber)) 148 | ::t-exists (if-let [new-name (get @env (:t-var-name typ))] ;; existentials implicitly range over entire expression 149 | (assoc-in typ [:t-var-name] new-name) 150 | (assoc-in typ [:t-var-name] (fresh typ))) 151 | ::t-var (if-let [new-name (get @env (:t-var-name typ))] 152 | (assoc-in typ [:t-var-name] new-name) 153 | (throw (ex-info "No name provided for var " {:typ typ}))) 154 | (map-type renumber typ)))] 155 | (renumber typ)))) 156 | 157 | ;; for ad-hoc hijaking of houw analysis works. 158 | (defn analyze-annotations 159 | [expr] 160 | (cond 161 | (vector? expr) (vec (map analyze-annotations expr)) ;; eg: for :args children traversal 162 | :else (reduce (fn [e key] 163 | (update-in e [key] analyze-annotations)) 164 | expr 165 | (:children expr)))) 166 | 167 | (defn c-marker 168 | "constructor" 169 | [c-var-name] 170 | {:c-op :c-exists :c-var-name c-var-name}) 171 | 172 | (defn c-exists 173 | "constructor" 174 | [c-var-name] 175 | {:c-op :c-exists :c-var-name c-var-name}) 176 | 177 | (defn c-exists-solved 178 | "constructor" 179 | [c-var-name typ] 180 | {:c-op :c-exists-solved :c-var-name c-var-name :c-typ typ}) 181 | 182 | (defn t-exists 183 | [t-var-name] 184 | {:t-op ::t-exists 185 | :t-var-name t-var-name}) 186 | 187 | (defmulti monotype? :t-op) 188 | (defmethod monotype? ::t-var [_] true) 189 | (defmethod monotype? ::t-exists [_] true) 190 | (defmethod monotype? ::t-forall [_] false) 191 | 192 | 193 | (defn solve 194 | "This unifies an existential to a monotype" 195 | [ctx t-var-name typ] 196 | (assert (monotype? typ) "Can only solve for monotypes -- forgot a guard?") 197 | (let [[ctx-l ctx-r] (ctx-break ctx {:c-op :c-exists :c-var-name t-var-name})] 198 | (if (type-wf ctx-l typ) ;; Q: What does this check represent? 199 | (do (prn "solve: " [t-var-name typ "->" (c-exists-solved t-var-name typ)]) 200 | {:solved (ctx-concat ctx-l [(c-exists-solved t-var-name typ)] ctx-r)}) 201 | {:unsolved true}))) 202 | 203 | (defmulti free-t-vars :t-op) 204 | (defmethod free-t-vars ::t-var [typ] #{(:t-var-name typ)}) 205 | (defmethod free-t-vars ::t-exists [typ] #{(:t-var-name typ)}) 206 | (defmethod free-t-vars ::t-forall [typ] (set/difference (free-t-vars (:t-ret typ)) 207 | #{(:t-var-name typ)})) 208 | 209 | (defn ordered? 210 | "b occurs after a in ctx" 211 | [ctx t-var-name-a t-var-name-b] 212 | (let [ctx-l (ctx-drop ctx (c-exists t-var-name-b))] 213 | (contains? (existentials ctx-l) t-var-name-a))) 214 | 215 | (defn operator 216 | "treat const values (like `nil`) as different operators than the analyzer does." 217 | [expr] (let [r (if (= :const (:op expr)) (:type expr) (:op expr))] 218 | (when (nil? r) (throw (ex-info "Nil opertator:" {:expr expr}))) 219 | r)) 220 | 221 | (defmulti rename-var 222 | "a la substitution: [new-name / for-name]expr 223 | This assumes analysis has already freshly renamed all variables. 224 | for-name is the actual symbol name to rebind (not the analyzed local var form)" 225 | (fn [new-name for-name expr] (operator expr))) 226 | (defmethod rename-var :with-meta 227 | [new-name for-name expr] 228 | (update-in expr [:expr] #(rename-var new-name for-name %))) 229 | (defmethod rename-var :annotation 230 | [new-name for-name expr] 231 | (update-in expr [:expr] #(rename-var new-name for-name %))) 232 | (defmethod rename-var :do 233 | [new-name for-name expr] 234 | (-> (<<- (update-in expr [:statements]) (fn [ss]) 235 | (vec) (for [s ss]) 236 | (rename-var new-name for-name s)) 237 | (update-in [:ret] #(rename-var new-name for-name %)))) 238 | (defmethod rename-var :local 239 | [new-name for-name expr] 240 | (if (= for-name (:name expr)) 241 | (assoc expr :name new-name) 242 | expr)) 243 | (defmethod rename-var :invoke 244 | [new-name for-name expr] 245 | (-> (<<- (update-in expr [:args]) (fn [as]) 246 | (vec) (for [a as]) 247 | (rename-var new-name for-name a)) 248 | (update-in [:fn] #(rename-var new-name for-name %)))) 249 | 250 | ;;; Not a multimethod since it's assumed the map-type should be you need to implement 251 | (defn type-substitute 252 | "sub new-typ for t-var-name in typ" 253 | [new-typ t-var-name typ] 254 | (let [r (case (:t-op typ) 255 | ::t-var (if (= t-var-name (:t-var-name typ)) new-typ typ) 256 | ::t-exists (if (= t-var-name (:t-var-name typ)) new-typ typ) 257 | ::t-forall (if (= t-var-name (:t-var-name typ)) 258 | (do (println "Should this ever happen with hygenic vars??") typ) 259 | (update-in typ [:t-ret] #(type-substitute new-typ t-var-name %))) 260 | (map-type #(type-substitute new-typ t-var-name %) typ))] 261 | #_(prn "type-substitute" [new-typ t-var-name typ "->" r]) 262 | r)) 263 | 264 | (declare subtype typesynth typecheck) 265 | 266 | (derive ::t-exists ::t-any-type) 267 | (derive ::t-forall ::t-any-type) 268 | (derive ::t-var ::t-any-type) 269 | 270 | ;; returns a context 271 | (defmulti typecheck (fn [ctx expr typ] (prn "typecheck:" [ctx expr typ]) [(operator expr) (:t-op typ)])) 272 | 273 | (defmethod typecheck [:with-meta ::t-any-type] 274 | [ctx expr typ] 275 | (typecheck ctx (:expr expr) typ)) 276 | 277 | (defmethod typecheck [:do ::t-any-type] 278 | [ctx expr typ] 279 | (typecheck ctx (:ret expr) typ)) 280 | 281 | (defmethod typecheck :default 282 | [ctx expr typ] 283 | (cond 284 | (= ::t-forall (:t-op typ)) 285 | , (let [fresh (gensym (:t-var-name typ)) 286 | ctx-elem {:c-op :c-forall 287 | :c-var-name fresh}] 288 | (-> (typecheck (ctx-conj ctx ctx-elem) 289 | expr 290 | (type-substitute {:t-op ::t-var :t-var-name fresh} 291 | (:t-var-name typ) 292 | (:t-ret typ))) 293 | (ctx-drop ctx-elem))) 294 | :else (let [{typ' :type ctx' :ctx} (do "Giving up" (typesynth ctx expr))] 295 | (prn "synthed: " {:type typ' :ctx ctx'}) 296 | (subtype ctx' (type-apply ctx' typ') (type-apply ctx' typ))))) 297 | 298 | ;; Let anybody hijack invoke expressions using specific fn vars to dispatch. 299 | (defmulti typesynth-invoke (fn [ctx expr] (let [v (get-in expr [:fn :var])] 300 | (if (var? v) 301 | (symbol (-> v .ns .name name) 302 | (-> v .sym name)) 303 | nil)))) 304 | 305 | (defmethod typesynth-invoke 'bidirectional.bidirectional/ann 306 | [ctx expr] 307 | (assert (= 2 (count (:args expr))) "annotation should have two arguments: (ann expr type)") 308 | (assert (:literal? (second (:args expr))) "second argument to ann must be a type literal") 309 | (let [anned-expr (first (:args expr)) 310 | typ (:val (second (:args expr)))] 311 | {:type typ :ctx (typecheck ctx anned-expr typ)})) 312 | 313 | ;; Returns {:type typ :ctx ctx} 314 | (defmulti typesynth (fn [ctx expr] (prn "typesynth" [ctx expr]) (operator expr))) 315 | (defmethod typesynth :local [ctx expr] 316 | (if-let [typ (find-var-type ctx (:name expr))] ;; (fn and let vars are both :local) - those bound by the env are inlined it seems? (why would these be and not let-bounds vars? 317 | {:type typ :ctx ctx} 318 | (throw (ex-info "var not found in context" {:ctx ctx :expr expr})))) 319 | (defmethod typesynth :with-meta [ctx expr] (typesynth ctx (:expr expr))) 320 | (defmethod typesynth :invoke [ctx expr] (typesynth-invoke ctx expr)) 321 | 322 | 323 | 324 | (defn flip [dir] 325 | (case dir :left :right :right :left)) 326 | 327 | (declare instantiate-poly) 328 | (defn instantiate 329 | "returns a context. 330 | direction is which side of < the existential is on that we're trying to instantiate." 331 | [ctx t-var-name dir typ] 332 | (prn "instantiate-l" [ctx t-var-name typ]) 333 | (if-let [ctx' (:solved (and (monotype? typ) 334 | (solve ctx t-var-name typ)))] 335 | ctx' 336 | (instantiate-poly ctx t-var-name dir typ))) 337 | 338 | (defmulti instantiate-poly 339 | "Called for types where monotype? has returned false." 340 | (fn [ctx t-var-name dir typ] (:t-op typ))) 341 | 342 | (defmethod instantiate-poly ::t-exists 343 | [ctx t-var-name dir typ] 344 | (if (ordered? ctx t-var-name (:t-var-name typ)) ;; I guess this has to succeed? This seems to just be careful control over the ctx order. 345 | (:solved (solve ctx (:t-var-name typ) {:t-op ::t-exists 346 | :t-var-name t-var-name})) 347 | (do (throw (ex-info "Weird case hit (this should have been handled by the first call to instantiate?):" 348 | {:t-var-name t-var-name :typ typ})) 349 | #_(:solved (solve ctx t-var-name typ))))) 350 | 351 | 352 | 353 | (defmethod instantiate-poly ::t-forall 354 | [ctx t-var-name dir typ] 355 | (case dir 356 | :left 357 | , (let [var-name' (gensym) 358 | ctx-elem {:c-op :c-forall 359 | :c-var-name var-name'}] 360 | (-> (instantiate (ctx-concat ctx [ctx-elem]) ; Why wasn't this a ctx-conj? added to the other end? 361 | t-var-name 362 | :left 363 | (type-substitute {:t-op ::t-var ; Is this fresh renaming necessary? 364 | :t-var-name var-name'} 365 | (:t-var-name typ) 366 | (:t-ret typ))) 367 | (ctx-drop ctx-elem))) 368 | :right 369 | , (let [var-name' (gensym) ; This one is the difference! it flips the forall to an existential!. 370 | ctx-marker (c-marker var-name') 371 | ctx-elem (c-exists-solved var-name')] 372 | (-> (instantiate (ctx-concat ctx [ctx-marker ctx-elem]) ; Why wasn't this a ctx-conj? added to the other end? 373 | t-var-name 374 | :right 375 | (type-substitute {:t-op ::t-exists ; and replacing with an exists here instead of forall. 376 | :t-var-name var-name'} 377 | (:t-var-name typ) 378 | (:t-ret typ))) 379 | (ctx-drop ctx-marker))))) 380 | 381 | (defmulti subtype 382 | "typ1 < typ2 - returns a new context" 383 | (fn [ctx typ1 typ2] [(:t-op typ1) (:t-op typ2)])) 384 | 385 | (defmethod subtype [::t-var ::t-var] 386 | [ctx typ1 typ2] 387 | (if (= (:t-var-name typ1) (:t-var-name typ1)) 388 | ctx 389 | (throw (ex-info "Vars don't match" {:ctx ctx :t1 typ1 :t2 typ2})))) 390 | 391 | (defmethod subtype :default 392 | [ctx typ1 typ2] 393 | (cond 394 | (= ::t-forall (:t-op typ2)) (let [var-name' (gensym "subtype-r") 395 | ctx-elem {:c-op :c-forall 396 | :c-var-name var-name'}] 397 | (-> (subtype (ctx-concat ctx [ctx-elem]) 398 | typ1 399 | (type-substitute {:t-op ::t-var 400 | :t-var-name var-name'} 401 | (:t-var-name typ2) 402 | (:t-ret typ2))) 403 | (ctx-drop ctx-elem))) 404 | (= ::t-forall (:t-op typ1)) (let [var-name' (gensym "subtype-l")] 405 | (-> (subtype (ctx-concat ctx [(c-marker var-name') 406 | {:c-op :c-exists 407 | :c-var-name var-name'}]) 408 | (type-substitute {:t-op ::t-exists 409 | :t-var-name var-name'} 410 | (:t-var-name typ1) 411 | (:t-ret typ1)) 412 | typ2) 413 | (ctx-drop (c-marker var-name')))) 414 | (and (= ::t-exists (:t-op typ1)) 415 | (= ::t-exists (:t-op typ2)) 416 | (= (:t-var-name typ1) (:t-var-name typ2)) 417 | (contains? (existentials ctx) (:t-var-name typ1))) 418 | , ctx 419 | (and (= ::t-exists (:t-op typ1)) 420 | (contains? (existentials ctx) (:t-var-name typ1)) 421 | (not (contains? (free-t-vars typ2) (:t-var-name typ1)))) 422 | , (instantiate ctx (:t-var-name typ1) :left typ2) 423 | (and (= ::t-exists (:t-op typ2)) 424 | (contains? (existentials ctx) (:t-var-name typ2)) 425 | (not (contains? (free-t-vars typ1) (:t-var-name typ2)))) 426 | , (instantiate ctx (:t-var-name typ2) :right typ1) 427 | :else (throw (ex-info "Type error. t1 is not a subtype of t2" {:ctx ctx :t1 typ1 :t2 typ2})))) 428 | 429 | ;;;;;;;;; Scratch ;;;;;;;;; 430 | 431 | (def builtin-env 432 | (-> (taj/empty-env) 433 | (assoc `annotations ::annotation))) ;; This doesn't seem to work, just defining it for real seems to work though. 434 | 435 | (def sample-env 436 | (assoc (taj/empty-env) 437 | :locals {'fun1 (taem/elide-meta (taj/analyze+eval '(fn [x] x) (taj/empty-env)))})) 438 | 439 | (defn ctx-infer 440 | [code] 441 | (let [ana (-> (taj/analyze+eval code (taj/empty-env)) 442 | (analyze-annotations)) 443 | {:keys [ctx type]} (typesynth [] ana)] 444 | {:type (-> (type-apply ctx type) 445 | (renumber-varnames)) 446 | :ctx ctx})) 447 | 448 | (defn infer 449 | [code] 450 | (:type (ctx-infer code))) 451 | 452 | (defn check 453 | "returns context if code typechecks" 454 | [code typ] 455 | (let [ana (-> (taj/analyze+eval code (taj/empty-env)) 456 | (analyze-annotations))] 457 | (typecheck [] ana typ))) 458 | 459 | #_(taj/analyze+eval '(+ 1 2) (taj/empty-env)) 460 | 461 | (def test-code '((fn [x] x) nil)) 462 | -------------------------------------------------------------------------------- /src/bidirectional/fn_type.clj: -------------------------------------------------------------------------------- 1 | (ns bidirectional.fn-type 2 | (:require [bidirectional.bidirectional :refer :all :as bi] 3 | [clojure.set :as set])) 4 | 5 | (derive ::t-fn ::bi/t-any-type) 6 | 7 | (defmethod type-wf ::t-fn [ctx typ] 8 | (and (type-wf ctx (:t-param typ)) 9 | (type-wf ctx (:t-ret typ)))) 10 | 11 | (defmethod map-type ::t-fn [f t] (update-keys t [:t-param :t-ret] f)) 12 | 13 | (defmethod monotype? ::t-fn [typ] (and (monotype? (:t-param typ)) 14 | (monotype? (:t-ret typ)))) 15 | 16 | (defmethod free-t-vars ::t-fn [typ] (set/union (free-t-vars (:t-param typ)) 17 | (free-t-vars (:t-ret typ)))) 18 | 19 | (defmethod rename-var :fn 20 | [new-name for-name expr] 21 | (<<- (update-in expr [:methods]) (fn [ms]) 22 | (vec) (for [m ms]) 23 | (update-in m [:body]) (fn [b]) 24 | (rename-var new-name for-name b))) 25 | 26 | (defn typesynth-invoke-default 27 | "type checks the actual argument of an invocation, given the type of the function." 28 | [ctx typ expr] 29 | (assert (vector? ctx)) 30 | (case (:t-op typ) 31 | :with-meta (typesynth-invoke ctx typ (:expr expr)) 32 | ::bi/t-forall (let [g (gensym "invokeforall")] 33 | (typesynth-invoke-default 34 | (ctx-conj ctx {:c-op :c-exists :c-var-name g}) 35 | (type-substitute {:t-op ::bi/t-exists :t-var-name g} 36 | (:t-var-name typ) 37 | (:t-ret typ)) 38 | expr)) 39 | ::bi/t-exists (let [garg (gensym "invoke-exarg") ;; refining our knowledge of an existential variable 40 | gret (gensym "invoke-gret") 41 | [ctx-l ctx-r] (ctx-break ctx {:c-op :c-exists :c-var-name (:t-var-name typ)}) 42 | ctx' (typecheck (ctx-concat ctx-l 43 | [{:c-op :c-exists :c-var-name garg} 44 | {:c-op :c-exists :c-var-name gret} 45 | {:c-op :c-exists-solved 46 | :c-var-name (:t-var-name typ) 47 | :c-typ {:t-op :bidirectional.fn-type/t-fn 48 | :t-param {:t-op ::bi/t-exists :t-var-name garg} 49 | :t-ret {:t-op ::bi/t-exists :t-var-name gret}}}] 50 | ctx-r) 51 | expr 52 | {:t-op ::bi/t-exists :t-var-name garg})] 53 | {:type {:t-op ::bi/t-exists :t-var-name gret} 54 | :ctx ctx'}) 55 | :bidirectional.fn-type/t-fn (let [ctx' (typecheck ctx expr (:t-param typ))] 56 | {:type (:t-ret typ) 57 | :ctx ctx'}) 58 | (throw (ex-info "Can't check this invoke" {:ctx ctx :typ typ :expr expr})))) 59 | 60 | (defmethod typesynth-invoke :default 61 | [ctx expr] 62 | (let [{typ :type ctx' :ctx} (typesynth ctx (:fn expr))] 63 | (assert (= 1 (count (:args expr))) "only supports single arguments right now") 64 | (typesynth-invoke-default ctx' (type-apply ctx' typ) (first (:args expr))))) 65 | 66 | (defmethod typesynth :fn [ctx expr] 67 | (assert (= 1 (count (:methods expr))) "only single-arity methods supported") 68 | (assert (= 1 (count (:params (first (:methods expr))))) "only single argument supported") 69 | (let [param-name (:name (first (:params (first (:methods expr))))) 70 | ctx-var-name (gensym param-name) ; Since param-name is gensymmed, I'm guessing we can just use the existing one and avoid the renaming? 71 | exists-param (gensym (str "e-" param-name)) 72 | exists-ret (gensym "ret") 73 | c-mk (c-marker exists-param) 74 | ctx-var {:c-op :c-var 75 | :c-var-name ctx-var-name 76 | :c-typ {:t-op ::bi/t-exists 77 | :t-var-name exists-param}} 78 | [ctx-l ctx-r] 79 | , (-> (typecheck (ctx-concat ctx [c-mk 80 | (c-exists exists-param) 81 | (c-exists exists-ret) 82 | ctx-var]) 83 | (rename-var ctx-var-name param-name (:body (first (:methods expr)))) 84 | {:t-op ::bi/t-exists 85 | :t-var-name exists-ret}) 86 | (ctx-break c-mk)) 87 | typ (type-apply ctx-r {:t-op ::t-fn 88 | :t-param {:t-op ::bi/t-exists 89 | :t-var-name exists-param} 90 | :t-ret {:t-op ::bi/t-exists 91 | :t-var-name exists-ret}}) 92 | evars (unsolved ctx-r) ;; I think this is becomes a big multi-var forall? 93 | freshes (repeatedly (count evars) #(gensym "freshes")) 94 | typ' (reduce (fn [t [f ev]] 95 | (type-substitute {:t-op ::bi/t-var :t-var-name f} (:c-var-name ev) typ)) 96 | typ 97 | (map vector freshes evars)) 98 | typ'' (reduce (fn [t f] {:t-op ::bi/t-forall 99 | :t-var-name f 100 | :t-ret t}) 101 | typ' 102 | freshes)] 103 | {:type typ'' 104 | :ctx ctx-l})) 105 | 106 | (defmethod instantiate-poly ::t-fn 107 | [ctx t-var-name dir typ] 108 | (let [param' (gensym) 109 | ret' (gensym) 110 | ctx' (instantiate 111 | (let [[ctx-l ctx-r] (ctx-break ctx (c-exists t-var-name))] 112 | (ctx-concat ctx-l 113 | [(c-exists ret') 114 | (c-exists param') 115 | (c-exists-solved t-var-name {:t-op ::t-fn 116 | :t-param {:t-op ::bi/t-exists 117 | :t-var-name param'} 118 | :t-ret {:t-op ::bi/t-exists 119 | :t-var-name ret'}})] 120 | ctx-r)) 121 | param' 122 | (flip dir) 123 | (:t-param typ))] 124 | (instantiate ctx' ret' dir (type-apply ctx' (:t-ret typ))))) 125 | 126 | (defmethod subtype [::t-fn ::t-fn] 127 | [ctx typ1 typ2] 128 | (let [ctx' (subtype ctx (:t-param typ2) (:t-param typ1))] ; Note polarity swap! 129 | (subtype ctx' (type-apply ctx' (:t-ret typ1)) (type-apply ctx' (:t-ret typ2))))) 130 | 131 | (defmethod typecheck [:fn ::t-fn] 132 | [ctx expr typ] 133 | (assert (= 1 (count (:methods expr))) "only single-arity methods supported") 134 | (assert (= 1 (count (:params (first (:methods expr))))) "only single argument supported") 135 | (let [param-name (:name (first (:params (first (:methods expr))))) 136 | ctx-var-name (gensym param-name) ; Since param-name is gensymmed, I'm guessing we can just use the existing one and avoid the renaming? 137 | ctx-elem {:c-op :c-var 138 | :c-var-name ctx-var-name 139 | :c-typ (:t-param typ)}] 140 | (-> (typecheck (ctx-conj ctx ctx-elem) 141 | (rename-var ctx-var-name param-name (:body (first (:methods expr)))) 142 | (:t-ret typ)) 143 | (ctx-drop ctx-elem)))) 144 | -------------------------------------------------------------------------------- /src/bidirectional/hmap_type.clj: -------------------------------------------------------------------------------- 1 | (ns bidirectional.hmap-type 2 | (:require [bidirectional.bidirectional :refer :all :as bi] 3 | [bidirectional.fn-type :as fn] 4 | [clojure.tools.analyzer.jvm :as taj] 5 | [clojure.set :as set]) 6 | (:import clojure.lang.ExceptionInfo)) 7 | 8 | (derive ::t-hmap ::bi/t-any-type) 9 | 10 | (defmethod type-wf ::t-hmap [ctx typ] 11 | (every? identity (for [[fld typ] (:t-fields typ)] (type-wf ctx typ)))) 12 | 13 | (defmethod map-type ::t-hmap [f t] 14 | (<<- (update-in t [:t-fields]) (fn [flds]) 15 | (update-keys flds (keys flds) f))) 16 | 17 | (defmethod monotype? ::t-hmap [typ] 18 | (every? monotype? (for [[fld typ] (:t-fields typ)] typ))) 19 | 20 | (defmethod free-t-vars ::t-hmap [typ] 21 | (apply set/union 22 | (map free-t-vars (for [[fld typ] (:t-fields typ)] typ)))) 23 | 24 | (defmethod rename-var :map 25 | [new-name for-name expr] 26 | (if (= :const (:op expr)) ;; :op :const contains no variabls 27 | expr 28 | (<<- (update-in expr [:vals]) (fn [vals]) 29 | (vec) (for [v vals]) 30 | (rename-var new-name for-name v)))) 31 | 32 | (defn hmap-typ? 33 | [typ] 34 | (= ::t-hmap (:t-op typ))) 35 | 36 | (defn hmap-exists? 37 | [typ] 38 | (= ::t-hmap-exists (:t-op typ))) 39 | 40 | (defn hmap-nil? 41 | [typ] 42 | (= ::t-hmap-nil (:t-op typ))) 43 | 44 | ;; TODO unify approach to handling existentials of different sorts 45 | (defn hmap-existentials 46 | "returns the free hmap-exists c-var-names in the context" 47 | [ctx] 48 | (->> ctx 49 | (filter #(#{::c-hmap-exists} (:c-op %))) 50 | (map :c-var-name) 51 | (into #{}))) 52 | 53 | ;; TODO unify approach to handling existentials of different sorts 54 | (defn hmap-ordered? 55 | "true if r doesn't occur to the left of l in the context" 56 | [ctx c-var-name-l c-var-name-r] 57 | (let [[ctx-l ctx-r] (c-var-name-break ctx c-var-name-l)] 58 | (not (contains? (hmap-existentials ctx-l) c-var-name-r)))) 59 | 60 | (defn hmap-apply 61 | "pulls together all the existential row constraints, as well as resolving actual existentials. 62 | returns the normalized type based on the context." 63 | [ctx typ] 64 | (let [typ (type-apply ctx typ)] 65 | (cond 66 | (hmap-typ? typ) 67 | ,(if (hmap-nil? (:t-rest typ)) 68 | typ 69 | (let [c-exts (loop [c-exts (c-find-var ctx (:t-var-name (:t-rest typ)))] 70 | (if (= ::c-hmap-exists-solved (:c-op c-exts)) 71 | (recur (c-find-var ctx (:c-equal-to-var-name c-exts))) 72 | c-exts))] 73 | (when (not-empty (set/intersection (set (keys (:c-fields c-exts))) 74 | (set (keys (:t-fields typ))))) 75 | (throw (ex-info "Not sure what to do when constraints redundantly talk about the same keys. Is it okay as long as they're coherent?" {:ctx ctx :typ typ}))) 76 | {:t-op ::t-hmap 77 | :t-fields (merge (:t-fields typ) (:c-fields c-exts)) 78 | :t-rest (if (:c-principal? c-exts) 79 | {:t-op ::t-hmap-nil} 80 | {:t-op ::t-exists 81 | :t-var-name (:c-var-name c-exts)})})) 82 | (hmap-exists? typ) (throw (ex-info "TODO" {})) 83 | (hmap-nil? typ) typ))) 84 | 85 | (defn refine-existential 86 | "returns updated ctx" 87 | [ctx hmap-exst key typ] 88 | (throw (ex-info "TODO" {}))) 89 | 90 | (defn nil-existential 91 | [ctx hmap-exst] 92 | (c-update-var ctx (:t-var-name hmap-exst) 93 | (fn [c-exst] 94 | (when-not (= {} (:c-fields c-exst)) 95 | (throw (ex-info "Not sure about this case. hmap existential carries constraints?" {:ctx ctx :hmap-exst hmap-exst}))) 96 | (assoc c-exst :c-principal? true)))) 97 | 98 | (defn intersect-constraints 99 | "c-hmap-exists don't, themselves, have :rest fields so unlike subtype this 100 | only intersects the field constraints. 101 | 102 | returns {:ctx ctx :fields intersected-field-constraints}" 103 | [ctx c-hmap-exst-l c-hmap-exst-r] 104 | (let [allkeys (set (concat (keys (:c-fields c-hmap-exst-l)) 105 | (keys (:c-fields c-hmap-exst-r)))) 106 | ret 107 | ,(reduce (fn [{ctx :ctx fields :fields} key] 108 | (let [left-t (get key (:c-fields c-hmap-exst-l)) 109 | right-t (get key (:c-fields c-hmap-exst-r))] 110 | (cond 111 | ;; normal case 112 | (and left-t right-t) 113 | ,(try {:ctx (subtype ctx left-t right-t) :fields (assoc fields key left-t)} 114 | (catch ExceptionInfo e 115 | {:ctx (subtype ctx right-t left-t) :fields (assoc fields key right-t)})) 116 | (and left-t (nil? right-t) (not (:c-principal? c-hmap-exst-r))) 117 | ,{:ctx ctx :fields (assoc fields key left-t)} 118 | (and right-t (nil? left-t) (not (:c-principal? c-hmap-exst-l))) 119 | ,{:ctx ctx :fields (assoc fields key right-t)} 120 | :else (throw (ex-info "Can't intersect hmap field constraint" {:ctx ctx :key key :c-hmap-exst-l c-hmap-exst-l :c-hmap-exst-r c-hmap-exst-r}))))) 121 | {:ctx ctx :fields {}} 122 | allkeys)] 123 | (assoc ret :principal? (or (:c-principal? c-hmap-exst-l) 124 | (:c-principal? c-hmap-exst-r))))) 125 | 126 | (defn unify-existential 127 | "returns updated context" 128 | [ctx hmap-exst-1 hmap-exst-2] 129 | (let [{ctx :ctx fields :fields principal? :principal?} 130 | ,(intersect-constraints ctx hmap-exst-1 hmap-exst-2) 131 | [hmap-exst-l hmap-exst-r] (if (hmap-ordered? (:c-var-name hmap-exst-1) (:c-var-name hmap-exst-2)) 132 | [hmap-exst-1 hmap-exst-2] 133 | [hmap-exst-2 hmap-exst-1]) 134 | ctx (c-update-var ctx (:c-var-name hmap-exst-r) 135 | (fn [_] 136 | {:c-op ::c-hmap-exists-solved 137 | :c-var-name (:c-var-name hmap-exst-r) 138 | :c-equal-to-var-name (:c-var-name hmap-exst-l)})) 139 | ctx (c-update-var ctx (:c-var-name hmap-exst-l) 140 | (fn [c-elem] 141 | (-> c-elem 142 | (assoc :c-fields fields) 143 | (assoc :c-principal? principal?))))] 144 | ctx)) 145 | 146 | ;;; Not sure the best way to normalize between :op :map and :op :const :type :map 147 | (defn unconst-map 148 | "Analyzes a :op :const map one more level into the keys and values." 149 | [expr] 150 | (if (= :const (:op expr)) 151 | (-> expr 152 | (assoc :op :map) 153 | (assoc :vals (vec (map #(taj/analyze+eval % (taj/empty-env)) (vals (:val expr))))) 154 | (assoc :keys (vec (map #(taj/analyze+eval % (taj/empty-env)) (keys (:val expr)))))) 155 | expr)) 156 | 157 | (defmethod typesynth :map [ctx expr] 158 | (let [expr (unconst-map expr) 159 | [ctx fields] (reduce (fn [[ctx fields] [k v]] 160 | (when-not (= :keyword (:type k)) 161 | (throw (ex-info "Non-keywords can't be used as HMap keys" {:ctx ctx :k k}))) 162 | (let [{:keys [ctx type]} (typesynth ctx v)] 163 | [ctx (assoc fields (:val k) type)])) 164 | [ctx {}] 165 | (map vector (:keys expr) (:vals expr)))] 166 | {:type {:t-op ::t-hmap 167 | :t-fields fields 168 | :t-rest {:t-op ::t-hmap-nil}} 169 | :ctx ctx})) 170 | 171 | #_ 172 | (defmethod typecheck [:map ::t-hmap] 173 | [ctx expr typ] 174 | (let [expr (unconst-map expr) 175 | expr-map (into {} (map vector (map :val (:keys expr)) (:vals expr))) 176 | ctx (reduce (fn [ctx [k v]] 177 | (typecheck ctx (get expr-map k) v)) 178 | ctx 179 | (:t-fields typ))] 180 | ctx)) 181 | 182 | ;; TODO This probably won't play nice with keywords as just raw enum values? 183 | ;; besides, we have :keyword-invoke as a distinguished form 184 | (defmethod typesynth :keyword [ctx expr] 185 | (let [exists-ret (gensym (:val expr)) 186 | typ {:t-op ::fn/t-fn 187 | :t-param {:t-op ::t-hmap 188 | :t-fields {(:val expr) (t-exists exists-ret)}} 189 | :t-ret {:t-op ::bi/t-exists 190 | :t-var-name exists-ret} 191 | :t-field (:val expr)}] 192 | {:type typ 193 | :ctx (ctx-conj ctx (c-exists exists-ret))})) 194 | 195 | (defmethod typesynth :keyword-invoke 196 | [ctx expr] 197 | (when-not (= 1 (count (:args expr))) (throw (ex-info "Keyword invocation is meant to have exactly one argument (no default return value)" {:ctx ctx :expr expr}))) 198 | (let [exists-ret (gensym (:val expr)) 199 | rest (gensym "hmap-rest") 200 | argtype {:t-op ::t-hmap 201 | :t-fields {(:val (:fn expr)) (t-exists exists-ret)} 202 | :t-rest {:t-op ::t-hmap-exists 203 | :t-var-name rest}} 204 | ctx' (typecheck (ctx-concat ctx [(c-exists exists-ret) 205 | {:c-op ::c-hmap-exists 206 | :c-fields {} 207 | :c-principal? false 208 | :c-var-name rest}]) 209 | (first (:args expr)) argtype) 210 | rettype (type-apply ctx' (t-exists exists-ret))] 211 | {:type rettype 212 | :ctx ctx'})) 213 | 214 | ;; TODO we probably want a statically safe assoc for hmaps and a dynamic assoc for normal maps? 215 | ;; This disallows type-changing assocs. 216 | (defmethod typesynth-invoke 'clojure.core/assoc 217 | [ctx expr] 218 | (assert (= 3 (count (:args expr))) "annotation should have two arguments: (ann expr type)") 219 | (let [{ctx :ctx proj :type} (typesynth ctx (second (:args expr))) 220 | _ (when-not (:t-field proj) (throw (ex-info "Can only assoc hmaps with literal keyword as 2nd arg." 221 | {:expr expr :type proj}))) 222 | field-v (gensym "assoc-field") 223 | rest (gensym "hmap-rest") 224 | ctx (typecheck (ctx-concat ctx [(c-exists field-v) 225 | {:c-op ::c-hmap-exists 226 | :c-fields {} 227 | :c-principal? false 228 | :c-var-name rest}]) 229 | (first (:args expr)) 230 | {:t-op ::t-hmap 231 | :t-fields {(:t-field proj) (t-exists field-v)} 232 | :t-rest {:t-op ::t-hmap-exists 233 | :t-var-name rest}}) 234 | ctx (typecheck ctx 235 | (nth (:args expr) 2) 236 | (t-exists field-v))] 237 | {:ctx ctx 238 | :type (hmap-apply ctx 239 | {:t-op ::t-hmap 240 | :t-fields {(:t-field proj) (t-exists field-v)} 241 | :t-rest {:t-op ::t-hmap-exists 242 | :t-var-name rest}})})) 243 | 244 | (defmethod instantiate-poly ::t-hmap 245 | [ctx t-var-name dir typ] 246 | (throw (ex-info "TODO instantiate-poly for hmap" {:ctx ctx :typ typ}))) 247 | 248 | ;; A <: B if A has all fields of B, and all A's fields are subtypes of B's matching fields. 249 | ;; Existential "rest" variables are instantiated as accurately as possible (which means we don't get silent upcasting) 250 | ;; we let the silent upcasts through if the supertype is closed to extra fields. 251 | (defmethod subtype [::t-hmap ::t-hmap] 252 | [ctx typ1 typ2] 253 | (let [allkeys (set (concat (keys (:t-fields typ1)) (keys (:t-fields typ2)))) 254 | left-existential (let [r (:t-rest typ1)] (when (hmap-exists? r) r)) 255 | right-existential (let [r (:t-rest typ2)] (when (hmap-exists? r) r)) 256 | ctx (reduce (fn [ctx key] 257 | (let [left-t (get (:t-fields typ1) key) 258 | right-t (get (:t-fields typ2) key)] 259 | (cond 260 | ;; normal case 261 | (and left-t right-t) 262 | ,(subtype ctx left-t right-t) 263 | ;; We need to refine the right with an extra field 264 | (and left-t right-existential) 265 | ,(refine-existential ctx right-existential key left-t) 266 | ;; We need to refine the left with an extra field 267 | (and left-existential right-t) 268 | ,(refine-existential ctx left-existential key right-t) 269 | ;; We let this implicit upcast through. 270 | (and left-t (nil? right-t) (nil? right-existential)) 271 | ,ctx 272 | :else (throw (ex-info "Type error. hmap t1 is not a subtype of hmap t2" {:ctx ctx :key key :typ1 typ1 :typ2 typ2})) 273 | ))) 274 | ctx 275 | allkeys) 276 | ;; and check -rests 277 | ctx (cond 278 | (and (nil? left-existential) (nil? right-existential)) 279 | ,ctx 280 | (and left-existential (nil? right-existential)) 281 | ,(nil-existential ctx left-existential) 282 | (and (nil? left-existential) right-existential) 283 | ,(nil-existential ctx right-existential) 284 | (and left-existential right-existential 285 | (= (:t-var-name left-existential) 286 | (:t-var-name right-existential))) 287 | ,ctx 288 | (and left-existential right-existential 289 | (not= (:t-var-name left-existential) 290 | (:t-var-name right-existential))) 291 | ,(unify-existential ctx left-existential right-existential) 292 | :else (throw (ex-info "Type error. hmap t1 is not a subtype of hmap t2" {:ctx ctx :key ::t-rest :typ1 typ1 :typ2 typ2})) 293 | )] 294 | ctx)) 295 | -------------------------------------------------------------------------------- /src/bidirectional/unit_type.clj: -------------------------------------------------------------------------------- 1 | (ns bidirectional.unit-type 2 | (:require [bidirectional.bidirectional :refer :all :as bi])) 3 | 4 | (derive ::t-unit ::bi/t-any-type) 5 | 6 | (defmethod type-wf ::t-unit [ctx typ] 7 | true) 8 | 9 | (defmethod map-type ::t-unit [f t] t) 10 | 11 | (defmethod monotype? ::t-unit [_] true) 12 | 13 | (defmethod free-t-vars ::t-unit [_] #{}) 14 | 15 | (defmethod rename-var :nil 16 | [new-name for-name expr] expr) 17 | 18 | (defmethod typesynth :nil [ctx expr] 19 | (if (= (:val expr) nil) 20 | {:type {:t-op ::t-unit} :ctx ctx} 21 | (throw (ex-info "Can't synth type for " expr)))) 22 | 23 | (defmethod subtype [::t-unit ::t-unit] 24 | [ctx typ1 typ2] 25 | ctx) 26 | 27 | (defmethod typecheck [:nil ::t-unit] 28 | [ctx expr typ] 29 | ctx) 30 | -------------------------------------------------------------------------------- /test/bidirectional/bidirectional_test.clj: -------------------------------------------------------------------------------- 1 | (ns bidirectional.bidirectional-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.tools.analyzer.jvm :as taj] 4 | [bidirectional.bidirectional :refer :all :as bi] 5 | [bidirectional.fn-type :as ft] 6 | [bidirectional.hmap-type :as ht] 7 | [bidirectional.unit-type :as ut]) 8 | (:import clojure.lang.ExceptionInfo)) 9 | 10 | (deftest checks 11 | (is (= (infer '(fn [x] x)) 12 | '{:t-op ::bi/t-forall, :t-var-name freshes, 13 | :t-ret {:t-op ::ft/t-fn, 14 | :t-param {:t-op ::bi/t-var, :t-var-name freshes}, 15 | :t-ret {:t-op ::bi/t-var, :t-var-name freshes}}})) 16 | (is (= (infer 'nil) 17 | {:t-op ::ut/t-unit})) 18 | (is (= (infer '(fn [x] nil)) 19 | {:t-op ::bi/t-forall, :t-var-name 'freshes, 20 | :t-ret {:t-op ::ft/t-fn, 21 | :t-param {:t-op ::bi/t-var, :t-var-name 'freshes}, 22 | :t-ret {:t-op ::ut/t-unit}}})) 23 | (is (= (infer '((fn [x] (x nil)) (fn [x] x))) 24 | {:t-op ::ut/t-unit}) 25 | "higher order fns work") 26 | (is (= (check '(fn [x] nil) 27 | {:t-op ::bi/t-forall :t-var-name 'a 28 | :t-ret {:t-op ::ft/t-fn 29 | :t-param {:t-op ::bi/t-var :t-var-name 'a} 30 | :t-ret {:t-op ::ut/t-unit}}}) 31 | []) 32 | "Checking agrees with inference") 33 | (is (= (infer '(bidirectional.bidirectional/ann 34 | (fn [x] nil) {:t-op ::ft/t-fn 35 | :t-param {:t-op ::ut/t-unit} 36 | :t-ret {:t-op ::ut/t-unit}})) 37 | {:t-ret {:t-op ::ut/t-unit}, :t-param {:t-op ::ut/t-unit}, :t-op ::ft/t-fn}) 38 | "explicit annotations synthesize the annotated type") 39 | (is (= (infer '((fn [x] (x nil)) (bidirectional.bidirectional/ann 40 | (fn [x] x) {:t-op ::bi/t-forall, :t-var-name 'a, 41 | :t-ret {:t-op ::ft/t-fn, 42 | :t-param {:t-op ::bi/t-var, :t-var-name 'a}, 43 | :t-ret {:t-op ::bi/t-var, :t-var-name 'a}}}))) 44 | {:t-op ::ut/t-unit}) 45 | "You can annotate argument sub-expressions") 46 | (is (thrown? clojure.lang.ExceptionInfo 47 | (check '(fn [x] nil) 48 | {:t-op ::bi/t-forall :t-var-name 'a 49 | :t-ret {:t-op ::ft/t-fn 50 | :t-param {:t-op ::bi/t-var :t-var-name 'a} 51 | :t-ret {:t-op ::bi/t-var :t-var-name 'a}}})) 52 | "you can't wrongly promise polymorphic return") 53 | ;; Q: Following examples, typesynth doesn't type-apply its return value, you have to remember. Is this important or incidental? 54 | (is (= (renumber-varnames (:type (typesynth [] (taj/analyze+eval '((fn [x] x) nil) (taj/empty-env))))) 55 | {:t-op ::bi/t-exists, :t-var-name 'invokeforall})) 56 | (is (= (infer '((fn [x] x) nil)) 57 | {:t-op ::ut/t-unit}) 58 | "function application fixes polymorphic fns") 59 | (is (= (check '(fn [x] x) {:t-op ::ft/t-fn :t-param {:t-op ::ut/t-unit} :t-ret {:t-op ::ut/t-unit}}) 60 | []) 61 | "can check a polymorphic fn at a less polymorphic type") 62 | (is (= (check '(fn [x] nil) {:t-op ::bi/t-forall :t-var-name 'a :t-ret {:t-op ::ft/t-fn :t-param {:t-op ::ut/t-unit} :t-ret {:t-op ::ut/t-unit}}}) 63 | []) 64 | "un-used polymorphic variables are OK") 65 | ;; Is this right? due to prenex polymorphism it must resolve to some monotype? 66 | (is (= (infer '((fn [x] x) (fn [x] x))) 67 | {:t-op ::ft/t-fn, 68 | :t-param {:t-op ::bi/t-exists, :t-var-name 'G}, 69 | :t-ret {:t-op ::bi/t-exists, :t-var-name 'G}})) 70 | ;; and is THIS right as well? 71 | (is (= (infer '(bidirectional.bidirectional/ann 72 | ((fn [x] x) (fn [x] x)) {:t-op ::bi/t-forall :t-var-name 'a 73 | :t-ret {:t-op ::ft/t-fn 74 | :t-param {:t-op ::bi/t-var :t-var-name 'a} 75 | :t-ret {:t-op ::bi/t-var :t-var-name 'a}}})) 76 | {:t-op ::bi/t-forall :t-var-name 'a 77 | :t-ret {:t-op ::ft/t-fn 78 | :t-param {:t-op ::bi/t-var :t-var-name 'a} 79 | :t-ret {:t-op ::bi/t-var :t-var-name 'a}}}) 80 | "If we explicitly ask for polymorphism on the fancy application we get it") 81 | (is (= (infer '(bidirectional.bidirectional/ann 82 | ((fn [x] x) (fn [x] x)) {:t-op ::bi/t-forall :t-var-name 'a 83 | :t-ret {:t-op ::ft/t-fn 84 | :t-param {:t-op ::ut/t-unit} 85 | :t-ret {:t-op ::ut/t-unit}}})) 86 | {:t-op ::bi/t-forall :t-var-name 'a 87 | :t-ret {:t-op ::ft/t-fn 88 | :t-param {:t-op ::ut/t-unit} 89 | :t-ret {:t-op ::ut/t-unit}}}) 90 | "fancy application can be fixed to a monotype with an annotation")) 91 | 92 | (deftest hmap-test 93 | (is (= (infer '{:x nil}) 94 | {:t-op ::ht/t-hmap, :t-fields {:x {:t-op ::ut/t-unit}}, :t-rest {:t-op ::ht/t-hmap-nil}}) 95 | "infer basic hmaps") 96 | (is (= (infer '(:x {:x {:y nil}})) 97 | {:t-op ::ht/t-hmap, :t-fields {:y {:t-op ::ut/t-unit}}, :t-rest {:t-op ::ht/t-hmap-nil}}) 98 | "infer projections") 99 | (is (thrown-with-msg? ExceptionInfo #"is not a subtype" 100 | (infer '(assoc {:x nil} :x (fn [x] x)))) 101 | "can't use assoc to change type") 102 | (is (= (infer '(assoc {:x nil} :x nil)) 103 | {:t-op ::ht/t-hmap, :t-fields {:x {:t-op ::ut/t-unit}}, :t-rest {:t-op ::ht/t-hmap-nil}}) 104 | "don't forget principality") 105 | ;;; TODO Waiting on instantiate-poly 106 | #_(infer '(((fn [x] (fn [y] (x y))) :x) {:x nil}))) 107 | --------------------------------------------------------------------------------