├── .gitignore ├── LICENSE ├── README.md ├── build.clj ├── deps.edn ├── src └── erp12 │ └── schema_inference │ ├── api.clj │ └── impl │ ├── algo_w.clj │ ├── ground.clj │ └── util.clj └── test └── erp12 └── schema_inference └── impl ├── algo_w_test.clj └── util_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | # Clojure 2 | pom.xml 3 | pom.xml.asc 4 | *.jar 5 | *.class 6 | /lib/ 7 | /classes/ 8 | /target/ 9 | /checkouts/ 10 | .nrepl-port 11 | .cpcache/ 12 | .lsp/ 13 | .clj-kondo/ 14 | 15 | # Clojurescript 16 | out/ 17 | node_modules/ 18 | .shadow-cljs/ 19 | 20 | # Intellij / Cursive 21 | .idea/ 22 | ga-clj.iml 23 | 24 | # VS Codes / Calva 25 | .calva/ 26 | 27 | # OS 28 | *~ 29 | .DS_Store 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Edward R. Pantridge 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Schema Inference 2 | 3 | An experiment in implementing a Hindley–Milner inference framework for Malli schemas, as well as other functionality for 4 | reasoning about the relationships between schemas at runtime. 5 | 6 | > WARNING: This is not (currently) a fully fleshed out library, but rather a 7 | > proof-of-concept intended to foster discussion in the community. 8 | 9 | ## Motivation & Prior Art 10 | 11 | Clojure has been using schema/spec tools to describe the data flowing through our applications, and the transformations 12 | which manipulate this data. The Clojure ecosystem has no shortage of schema/spec/type systems, 13 | with [clojure.spec](https://clojure.org/about/spec), [malli](https://github.com/metosin/malli), 14 | [plumatic schema](https://github.com/plumatic/schema), and [typed clojure](https://github.com/typedclojure/typedclojure) 15 | being the most popular. 16 | 17 | Most of these projects are primarily meant to be used at runtime to validate data. The exception is Typed Clojure, which 18 | provides a type system that is used to analyze code and flag errors at development time. 19 | 20 | The short feedback loop of detecting errors via static code analysis is hugely beneficial for programmer productivity. 21 | The Clojure community has historically accepted having less of this ability in favor of a different kind of short 22 | feedback loop; the repl. Again, there are notable exceptions such as Typed Clojure and clj-kondo. 23 | 24 | This project hopes to demonstrate that the same schema declarations used at runtime can be used during static analysis 25 | using a few minor extensions inspired by type theory. However, this project aim to increase the amount of thinking in 26 | terms of types, or schemas. 27 | 28 | **Type systems have historically been concerned with proving "correctness".** Clojurists typically agree that in a 29 | data-oriented world type safety is often a poor approximation of correctness, and the constructs required to prove 30 | comprehensive type safety introduce coupling and complexity that we prefer to avoid in our abstraction. 31 | 32 | With respect to developer productivity, **type systems excel when they prove incorrectness**. Much like a 33 | "gradual typing" system, this project aims to put Clojure's existing à la carte schema/spec constructs to use at 34 | development time for faster, and richer, developer feedback. 35 | 36 | ### Goals 37 | 38 | 3. Introduce the concept of parameterized schema "schemes". 39 | 4. Implement schema-inference that can catch errors in Clojure forms. 40 | 5. Provide functionality to reason about and compose schemas. 41 | 42 | ### Non-Goals 43 | 44 | 1. Create yet another type/spec/schema system for Clojure. Stand on the shoulders of Malli. 45 | 2. Create a full static code analysis tool. Instead, this work might be used by an existing static code analyzer. 46 | 47 | ## Malli Schemas as "types" 48 | 49 | This project uses malli's [map-syntax](https://github.com/metosin/malli#map-syntax) to represent schemas. 50 | 51 | **Ground Schemas** - Any predicate is a valid ground (aka atomic) schema, however a commonly used set of schemas are 52 | also given symbol aliases. For example `{:type 'int?}`. In the current state, this project assumes all schemas are 53 | compositions of the ground schemas with given symbol aliases. 54 | 55 | **Schema Constructors** - Some schemas are logically a compositions other schemas. For example, we can think of 56 | `:vector` and `:map-of` as schema constructors (or "type constructors" from type theory) that take some number of 57 | schemas as arguments to return a new concrete schema. 58 | 59 | ```clojure 60 | {:type :vector, 61 | :child {:type 'int}} 62 | 63 | {:type :map-of, 64 | :key {:type :string?}, 65 | :value {:type :double?}} 66 | ``` 67 | 68 | Function schemas can be thought of as instances of the schema constructor `:=>`. 69 | 70 | ```clojure 71 | {:type :=> 72 | :input {:type :cat 73 | :children [{:type 'string?}]} 74 | :output {:type 'int?}} 75 | ``` 76 | 77 | ## Current Features 78 | 79 | > ANOTHER WARNING: All of these features are probably buggy and incomplete in the current prototype. 80 | > The primary goal is to get feedback. Please report any bugs on via Github issues. 81 | 82 | ### Parametric Schema Polymorphism 83 | 84 | What is the logical schema for the `identity` function? One might be tempted to say 85 | `[:=> [:cat any?] any?` but that is not correct. If it is given a value of schema `S`, it will _always_ return a value 86 | of schema `S`. Thus, `identity` is a polymorphic function; its concrete schema is potentially different at every calling 87 | location. 88 | 89 | This project proposes the construct of a schema "scheme" (terminology borrowed from the 90 | [Hindley–Milner type system](https://en.wikipedia.org/wiki/Hindley%E2%80%93Milner_type_system)). They are parameterized 91 | schemas that can be used to describe values that are polymorphic with respect to their schema (for example, functions 92 | like `identity`). 93 | 94 | Let's look at the scheme of the `identity` function... 95 | 96 | ```clojure 97 | {:type :scheme 98 | :s-vars ['T] 99 | :body {:type :=> 100 | :input {:type :cat 101 | :children [{:type :s-var, :sym 'T}]} 102 | :output {:type :s-var, :sym 'T}}} 103 | ``` 104 | 105 | This says: "for all possible values of a schema parameter `T` there is a concrete schema 106 | of a function that takes 1 argument of schema `T` and will return a value of schema `T`". 107 | 108 | Notice that there is something that looks like a malli function schema (`{:type :=>, ...}`) but it contains something 109 | new: A schema variable (`{:type :s-var, :sym 'T}`) that must be bound to a real schema in order to turn the entire 110 | scheme into a concrete schema. 111 | 112 | We can get a concrete schema from a parametric scheme by supplying bindings for all the type variables. 113 | 114 | ```clojure 115 | (use 'erp12.schema-inference.api) 116 | 117 | (concretize {'T {:type 'int?}} 118 | {:type :scheme 119 | :s-vars ['T] 120 | :body {:type :=> 121 | :input {:type :cat 122 | :children [{:type :s-var, :sym 'T}]} 123 | :output {:type :s-var, :sym 'T}}}) 124 | ;;{:type :=>, 125 | ;; :input {:type :cat, :children [{:type int?}]}, 126 | ;; :output {:type int?}} 127 | ``` 128 | 129 | Common [extensions of the Hindley-Milner type system](https://users.cs.fiu.edu/~smithg/papers/thesis91.pdf) 130 | allow schemes to have constraints. For example, the schema for `cons` might be as follows: 131 | 132 | ```clojure 133 | {:type :scheme 134 | :s-vars ['A 'B] 135 | ;; A vector of constraints. In this case only 1. 136 | :with [{:type :sub-type 137 | :child {:type :s-var, :sym 'A} 138 | :parent {:type :s-var, :sym 'B}}] 139 | :body {:type :=>, 140 | :input {:type :cat, 141 | :children [{:type :s-var, :sym 'B} 142 | {:type :vector, :child {:type :s-var, :sym 'A}}]}, 143 | :output {:type :vector, :child {:type :s-var, :sym 'B}}}} 144 | ``` 145 | 146 | The constraint of the above schema can be read as: `A` must be a sub-schema (like subtype) of `B`. 147 | 148 | > WARNING: Scheme constraints are not yet implemented. 149 | 150 | These parametric schemes are the logical representation for generic functions and data structures. There is currently 151 | little value in writing schemas for this kind of code. However, with parametric schemes we can properly annotate generic 152 | code which will allow schema information to "flow" through our code, and enables schema inference. 153 | 154 | ### Schema Inference 155 | 156 | Now that we can properly annotate all (or most) of our code, it is possible to run standard type-inference algorithms 157 | across our forms to 1) understand what the structure of the output is and 2) check for any "type errors" in the code. 158 | 159 | This project assumes the code to type check is presented as an AST as produced 160 | by [tools.analyzer](https://github.com/clojure/tools.analyzer). 161 | 162 | ```clojure 163 | (require '[malli.core :as m] 164 | '[clojure.tools.analyzer.jvm :as ana]) 165 | 166 | (defn square [i] 167 | (* i i)) 168 | 169 | (defn str-length [s] 170 | (.length s)) 171 | 172 | ;; Create a schema environment for the function we will know about ahead of time. 173 | ;; These would likely come from user annotations. 174 | (def env 175 | {`square (m/ast [:=> [:cat 'int?] 'int?]) 176 | `str-length (m/ast [:=> [:cat 'string?] 'int?])}) 177 | 178 | ;; Run type inference on a form. 179 | (infer-schema 180 | (ana/analyze `(square (str-length "clojure"))) 181 | env) 182 | ;; {:type 'int?} 183 | 184 | ;; Let's try on bad piece of bad code. 185 | (infer-schema 186 | (ana/analyze `(str-length (square 2))) 187 | env) 188 | ;; clojure.lang.ExceptionInfo: Schema inference failure. 189 | ;; #:erp12.schema-inference.impl.algo_w{:failure {:unification-failure {:schema-1 {:type string?}, :schema-2 {:type int?}, :mgu-failure :non-equal}}} 190 | ``` 191 | 192 | The error message could use some work! ... but hopefully you get the idea. 193 | 194 | Of course, schema-inference can help us understand individual calls to polymorphic functions that are annotated with 195 | parametric schemes. 196 | 197 | ```clojure 198 | ;; Annotate the `identity` symbol as having a parametric schema. 199 | (def env 200 | {`square (m/ast [:=> [:cat 'int?] 'int?]) 201 | `str-length (m/ast [:=> [:cat 'string?] 'int?]) 202 | `rand-int (m/ast [:=> [:cat 'int?] 'int?]) 203 | `identity {:type :scheme 204 | :s-vars ['a] 205 | :body {:type :=> 206 | :input {:type :cat 207 | :children [{:type :s-var :sym 'a}]} 208 | :output {:type :s-var :sym 'a}}}}) 209 | 210 | (infer-schema 211 | (ana/analyze '(identity 1)) 212 | env) 213 | ;; {:type 'int?} 214 | 215 | (infer-schema 216 | (ana/analyze '(identity :hello)) 217 | env) 218 | ;; {:type 'keyword?} 219 | 220 | (infer-schema 221 | (ana/analyze '((identity square) (str-length "malli"))) 222 | env) 223 | ;; {:type 'int?} 224 | 225 | ``` 226 | 227 | Type inference of local variables, via `let`, is also supported. 228 | 229 | ```clojure 230 | (infer-schema 231 | (ana/analyze '(let [x (rand-int 100)] 232 | x)) 233 | env) 234 | ;; {:type 'int?} 235 | ``` 236 | 237 | ## Potential Future Features 238 | 239 | If this concept were to be pursued further, there are a number of useful features that I would like to see implemented. 240 | 241 | ### Function Overloading 242 | 243 | Sometimes we use multiple signatures to denote a polymorphic function. 244 | 245 | ```clojure 246 | ;; NOT CURRENTLY WORKING CODE 247 | 248 | (def env 249 | ;; The `+` variable has a collection of type annotations. 250 | {'+ [(m/ast [:=> [:cat int? int?] int?]) 251 | (m/ast [:=> [:cat int? float?] float?]) 252 | (m/ast [:=> [:cat float? int?] float?]) 253 | (m/ast [:=> [:cat float? float?] float?])]}) 254 | ;; Register multiple signatures for the + function. 255 | 256 | (infer-schema '(+ 1 2.3) env) 257 | ;; [:type float?] 258 | ``` 259 | 260 | ### Schema Compatibility 261 | 262 | Schemas are _not_ types, but up until this point we have been treating them as equivalent constructs. Things diverge 263 | when we ask "Do all values of schema X conform to schema Y?" or in other words "Is schema X a sub-schema of schema Y?". 264 | 265 | In many type systems, this would be answered by checking if type "X" extends the class "Y" or implements the 266 | interface "Y". 267 | 268 | With schemas things are entirely structural. Let's look at some examples: 269 | 270 | ```clojure 271 | ;; NOT CURRENTLY WORKING CODE 272 | 273 | (sub-schema? [:enum :A :C] 274 | [:enum :A :B :C]) 275 | ;; true 276 | ``` 277 | 278 | Obviously the first schema (`[:enum :A :C]`) is a sub-schema of the second schema (`[:enum :A :B :C]`) 279 | because the first schema's finite set of members is a subset of the second schema's members. 280 | 281 | The same can be trivially determined for some non-enum schemas. 282 | 283 | ```clojure 284 | ;; NOT CURRENTLY WORKING CODE 285 | 286 | (sub-schema? int? 287 | [:or int? float?]) 288 | ;; true 289 | 290 | (sub-schema? [:or int? float?] 291 | float?) 292 | ;; false 293 | 294 | (sub-schema? keyword? 295 | [:and qualified-ident? keyword?]) 296 | ;; false 297 | 298 | (sub-schema? [:and qualified-ident? keyword?] 299 | keyword?) 300 | ;; true 301 | ``` 302 | 303 | We can extend this logic to maps by checking that: 304 | 305 | 1. All the (required) keys of the super-schema are present in the sub-schema. 306 | 2. For all keys shared by the sub and super schemas, the field's schema according to the sub-schema is a sub-schema of 307 | the field's schema super-schema. 308 | 309 | ```clojure 310 | ;; NOT CURRENTLY WORKING CODE 311 | 312 | (sub-schema? [:map ;; date-time 313 | [:year int?] 314 | [:month int?] 315 | [:day int?] 316 | [:hour int?] 317 | [:minute int?] 318 | [:second int?]] 319 | [:map ;; date 320 | [:year int?] 321 | [:month int?] 322 | [:day int?]]) 323 | ;; true - All date-times have a complete set of date attributes. 324 | 325 | (sub-schema? [:map ;; Ranked product recommendations from an ML model that outputs probabilities. 326 | [:product-id keyword?] 327 | [:rank float?]] 328 | [:map ;; Any numeric ranking system. 329 | [:product-id keyword?] 330 | [:rank number?]]) 331 | ;; true - All probability rankings are numeric rankings. 332 | ``` 333 | 334 | We can assume that all other collections (lists, vectors, sets) are covariant with respect to their element schemas. 335 | 336 | ```clojure 337 | ;; NOT CURRENTLY WORKING CODE 338 | 339 | (sub-schema? [:vector int?] 340 | [:vector number?]) 341 | ;; true 342 | 343 | (sub-schema? [:set string?] 344 | [:set [:maybe string?]]) 345 | ;; true 346 | 347 | (sub-schema? [:vector boolean?] 348 | [:sequential boolean?]) 349 | ;; true 350 | ``` 351 | 352 | If we have a sufficiently robust implementation of schema compatibility checking, we also have a naive implementation of 353 | schema equivalence via `(and (sub-schema? a b) (sub-schema? b a))`. 354 | -------------------------------------------------------------------------------- /build.clj: -------------------------------------------------------------------------------- 1 | (ns build 2 | (:require [clojure.tools.build.api :as b] 3 | [org.corfield.build :as bb])) 4 | 5 | (defn tests 6 | [opts] 7 | (bb/run-tests opts)) 8 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src"] 2 | :deps {metosin/malli {:mvn/version "0.8.9"}} 3 | :aliases {:build {:extra-deps {io.github.seancorfield/build-clj {:git/tag "v0.5.0" :git/sha "2ceb95a"}} 4 | :ns-default build} 5 | :test {:extra-paths ["test"] 6 | :extra-deps {expectations/clojure-test {:mvn/version "1.2.1"} 7 | com.cognitect/test-runner {:git/url "https://github.com/cognitect-labs/test-runner.git" 8 | :git/tag "v0.5.0" :git/sha "b3fd0d2"} 9 | org.clojure/tools.analyzer.jvm {:mvn/version "1.2.2"}} 10 | :main-opts ["-m" "cognitect.test-runner"] 11 | :exec-fn cognitect.test-runner.api/test}}} 12 | -------------------------------------------------------------------------------- /src/erp12/schema_inference/api.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.api 2 | (:require [erp12.schema-inference.impl.algo_w :as algo-w])) 3 | 4 | (defn infer-schema 5 | "Infer the schema of the expression given the environment." 6 | [ast env] 7 | (algo-w/infer-schema ast env)) 8 | -------------------------------------------------------------------------------- /src/erp12/schema_inference/impl/algo_w.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.impl.algo_w 2 | (:require [clojure.datafy :refer [datafy]] 3 | [erp12.schema-inference.impl.util :as u] 4 | [malli.core :as m] 5 | [malli.provider :as mp])) 6 | 7 | (defmulti algo-w (fn [{:keys [op]} & _] op)) 8 | 9 | (defn- algo-w-failure? 10 | [x] 11 | (and (map? x) (some? (::failure x)))) 12 | 13 | (defn infer-schema 14 | [ast env] 15 | (let [{::keys [schema] :as result} (algo-w ast env)] 16 | (if (algo-w-failure? result) 17 | (throw (ex-info "Schema inference failure." result)) 18 | schema))) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;; Lambda Calc 22 | 23 | ;; @todo Propagate ::throw 24 | ;; @todo Provide more context info about failures. 25 | 26 | (defmethod algo-w :LIT 27 | [{:keys [type val]} _] 28 | {::subs {} 29 | ::schema (case type 30 | :class {:type Class} 31 | (m/ast (mp/provide [val])))}) 32 | 33 | (defmethod algo-w :VAR 34 | [{:keys [sym]} env] 35 | (let [sym (symbol sym)] 36 | (if (contains? env sym) 37 | {::subs {} 38 | ::schema (u/instantiate (get env sym))} 39 | {::failure {:var-not-found sym}}))) 40 | 41 | (defmethod algo-w :APP 42 | [{:keys [fn args]} env] 43 | (let [s-var {:type :s-var :sym (gensym "s-")} 44 | {f-subs ::subs f-schema ::schema :as fn-result} (algo-w fn env)] 45 | (if (algo-w-failure? fn-result) 46 | fn-result 47 | (let [args-ti (loop [remaining-args args 48 | env' (u/substitute-env f-subs env) 49 | args-ti []] 50 | (if (empty? remaining-args) 51 | args-ti 52 | (let [arg (first remaining-args) 53 | {a-subs ::subs :as arg-ti} (algo-w arg env')] 54 | (if (algo-w-failure? arg-ti) 55 | arg-ti 56 | (recur (rest remaining-args) 57 | (u/substitute-env a-subs env') 58 | (conj args-ti arg-ti))))))] 59 | (if (algo-w-failure? args-ti) 60 | args-ti 61 | (let [subs (->> args-ti 62 | (map ::subs) 63 | reverse 64 | (reduce u/compose-substitutions {})) 65 | subs' (u/mgu (u/substitute subs f-schema) 66 | {:type :=> 67 | :input {:type :cat 68 | :children (mapv ::schema args-ti)} 69 | :output s-var})] 70 | (if (u/mgu-failure? subs') 71 | {::failure {:unification-failure subs'}} 72 | {::subs (u/compose-substitutions subs' subs) 73 | ::schema (u/substitute subs' s-var)}))))))) 74 | 75 | (defmethod algo-w :ABS 76 | [{:keys [params body] :as ast} env] 77 | ;; @todo Support variadic functions. 78 | (when (some :variadic? params) 79 | (throw (ex-info "Variadic functions not supported." {:ast ast}))) 80 | (let [param-names (map :name params) 81 | s-vars (vec (repeatedly (count params) #(hash-map :type :s-var :sym (gensym "s-")))) 82 | env' (into env (map vector param-names s-vars)) 83 | {::keys [subs schema] :as result} (algo-w body env')] 84 | (if (algo-w-failure? result) 85 | result 86 | {::subs subs 87 | ::schema {:type :=> 88 | :input {:type :cat 89 | :children (mapv #(u/substitute subs %) s-vars)} 90 | :output schema}}))) 91 | 92 | (defmethod algo-w :LET 93 | [{:keys [bindings body]} env] 94 | (loop [remaining bindings 95 | env' env 96 | subs {}] 97 | (if (empty? remaining) 98 | (let [{body-subs ::subs body-schema ::schema :as result} (algo-w body (u/substitute-env subs env'))] 99 | (if (algo-w-failure? result) 100 | result 101 | {::subs (u/compose-substitutions body-subs subs) 102 | ::schema body-schema})) 103 | (let [{:keys [name init]} (first remaining) 104 | {local-subs ::subs local-schema ::schema :as result} (algo-w init env')] 105 | (if (algo-w-failure? result) 106 | result 107 | (let [env' (dissoc env' name) 108 | local-schema' (u/generalize (u/substitute-env local-subs env) local-schema)] 109 | (recur (rest remaining) 110 | (assoc env' name local-schema') 111 | (u/compose-substitutions local-subs subs)))))))) 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | ;; Clojure 115 | 116 | (defmethod algo-w :binding [_ _] (assert false "Should be unreachable.")) 117 | 118 | ;(defmethod algo-w :case [ast env]) 119 | ;(defmethod algo-w :case-test [ast env]) 120 | ;(defmethod algo-w :case-then [ast env]) 121 | 122 | (defmethod algo-w :catch 123 | [{:keys [body]} env] 124 | (algo-w body env)) 125 | 126 | (defmethod algo-w :const 127 | [ast env] 128 | (algo-w (assoc ast :op :LIT) env)) 129 | 130 | (defmethod algo-w :def 131 | [{:keys [name init]} env] 132 | {::subs (if (nil? init) 133 | {} 134 | {name (infer-schema init env)}) 135 | ::schema {:type 'var?}}) 136 | 137 | ;(defmethod algo-w :deftype [ast env] {::subs }) 138 | 139 | (defmethod algo-w :do 140 | [{:keys [ret]} env] 141 | (algo-w ret env)) 142 | 143 | (defmethod algo-w :fn 144 | [{:keys [methods] :as ast} env] 145 | ;; @todo Support multiple methods (aka overloading). 146 | (if (= (count methods) 1) 147 | (algo-w (first methods) env) 148 | (throw (ex-info "Cannot infer schema of functions with multiple methods." 149 | {:ast ast})))) 150 | 151 | (defmethod algo-w :fn-method 152 | [ast env] 153 | (algo-w (assoc ast :op :ABS) env)) 154 | 155 | ;; @todo Support classes as ground types! 156 | ;; @todo Consider reflection instead of the type environment for interop ASTs. (JVM only). 157 | ;(defmethod algo-w :host-interop 158 | ; [{:keys [target m-or-f]} env]) 159 | 160 | (defmethod algo-w :if 161 | [{:keys [test then else]} env] 162 | (algo-w {:op :APP 163 | :fn {:op :var 164 | :var 'clojure.core/if} 165 | :args [test then else]} 166 | env)) 167 | 168 | (defmethod algo-w :import 169 | [_ _] 170 | ;; @todo Should this check the AST is a symbol constant? 171 | {::subs {} ::schema nil?}) 172 | 173 | ;(defmethod algo-w :instance-call [ast env]) 174 | ;(defmethod algo-w :instance-field [ast env]) 175 | 176 | (defmethod algo-w :instance? 177 | [_ _] 178 | ;; This AST node is used when a Class constant is in the AST, therefore we don't need to type check. 179 | ;; When a non-const AST is provided for the Class argument to instance?, an :invoke node will be used. 180 | {::subs {} ::schema 'boolean?}) 181 | 182 | (defmethod algo-w :invoke 183 | [ast env] 184 | (algo-w (assoc ast :op :APP) env)) 185 | 186 | ;; @todo Implement record-like theory (HMaps, relational algebra, etc.) 187 | ;(defmethod algo-w :keyword-invoke [ast env]) 188 | 189 | (defmethod algo-w :let 190 | [ast env] 191 | (algo-w (assoc ast :op :LET) env)) 192 | 193 | (defmethod algo-w :letfn 194 | [ast env] 195 | ;; @todo This incorrectly fails to allow ahead-of-definition use of functions. 196 | (algo-w (assoc ast :op :LET) env)) 197 | 198 | (defmethod algo-w :local 199 | [{:keys [name]} env] 200 | (algo-w {:op :VAR :sym name} env)) 201 | 202 | ;(defmethod algo-w :loop [ast env]) 203 | ;(defmethod algo-w :map [{:keys [keys vals}} env]) 204 | ;(defmethod algo-w :method [ast env]) 205 | ;(defmethod algo-w :new 206 | ; [{:keys [class args]} env] 207 | ; (let [fn-var (symbol (.getName String) "")] 208 | ; (algo-w {:op :APP 209 | ; :fn {:op :var :var fn-var} 210 | ; :args args} 211 | ; (assoc env 212 | ; fn-var {:type :=> 213 | ; :input (-> class datafy :members 214 | ; (get (symbol (.getName class))) 215 | ; first :parameter-types 216 | ; (map (fn [sym] (c/cls-name->schema (c/sym->cls sym))))) 217 | ; :output (c/cls-name->schema class)})))) 218 | 219 | (defmethod algo-w :prim-invoke 220 | [ast env] 221 | (algo-w (assoc ast :op :APP) env)) 222 | 223 | (defmethod algo-w :protocol-invoke 224 | [{:keys [target protocol-fn args]} env] 225 | (let [protocol (-> protocol-fn :meta :protocol deref :on-interface) 226 | {fn-schema ::schema fn-subs ::subs :as result} (algo-w protocol-fn env)] 227 | (if (algo-w-failure? result) 228 | result 229 | (let [env' (u/substitute-env fn-subs env) 230 | {target-schema ::schema target-subs ::subs :as result} (algo-w target env')] 231 | (cond 232 | (algo-w-failure? result) 233 | result 234 | 235 | ;; Use "currying-ish" strategy to check the rest of the args except the instance 236 | ;; of the protocol. 237 | (u/sub-schema? target-schema {:type protocol}) 238 | (let [tmp-f (gensym "f-")] 239 | (algo-w {:op :APP 240 | :fn {:op :local :name tmp-f} 241 | :args args} 242 | (assoc env' 243 | tmp-f (u/substitute target-subs (update-in fn-schema [:input :children] rest))))) 244 | 245 | :else 246 | {::failure {:must-extend-protocol (.getName protocol) 247 | :protocol-fn protocol-fn 248 | :got target-schema}}))))) 249 | 250 | (defmethod algo-w :quote 251 | [{:keys [expr]} env] 252 | (algo-w expr env)) 253 | 254 | ;(defmethod algo-w :recur [ast env]) 255 | ;(defmethod algo-w :reify [ast env]) 256 | ;(defmethod algo-w :set [{:keys [items]} env]) 257 | 258 | (defmethod algo-w :set! 259 | [{:keys [val]} env] 260 | (algo-w val env)) 261 | 262 | (defmethod algo-w :static-call 263 | [{:keys [class method] :as ast} env] 264 | (algo-w (assoc ast 265 | :op :APP 266 | :fn {:op :var 267 | :var (symbol (.getName class) (name method))}) 268 | env)) 269 | 270 | (defmethod algo-w :static-field 271 | [{:keys [class field]} _] 272 | {::subs {} 273 | ::schema {:type (-> (datafy class) 274 | :members 275 | (get field) 276 | first 277 | :type 278 | name 279 | Class/forName)}}) 280 | 281 | (defmethod algo-w :the-var 282 | [_ _] 283 | {::subs {} 284 | ::schema {:type 'var?}}) 285 | 286 | (defmethod algo-w :throw 287 | [_ _] 288 | ;; @todo Should type check the `exception` child AST, and confirm subtype of Throwable. 289 | {::subs {} ::schema ::throw}) 290 | 291 | (defmethod algo-w :try 292 | [{:keys [body]} env] 293 | ;; @todo Type check the catch clauses. 294 | (algo-w body env)) 295 | 296 | (defmethod algo-w :var 297 | [{:keys [var]} env] 298 | (algo-w {:op :VAR :sym var} env)) 299 | 300 | ;(defmethod algo-w :vector [{:keys [items]} env]) 301 | 302 | (defmethod algo-w :with-meta 303 | [{:keys [expr]} env] 304 | (algo-w expr env)) -------------------------------------------------------------------------------- /src/erp12/schema_inference/impl/ground.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.impl.ground) 2 | 3 | (def canonical-ground 4 | ;; @todo Expand this map to include more schemas. 5 | {:boolean 'boolean? 6 | :int 'int? 7 | :float 'float? 8 | :double 'double? 9 | :string 'string? 10 | :char 'char? 11 | :keyword 'keyword? 12 | :symbol 'symbol?}) 13 | 14 | (defn cls->schema 15 | [cls] 16 | {:type (case (.getName cls) 17 | "boolean" 'boolean? 18 | "byte" 'int? 19 | "short" 'int? 20 | "int" 'int? 21 | "long" 'int? 22 | "double" 'double? 23 | "float" 'float? 24 | "char" 'char? 25 | "[B" 'bytes? 26 | "java.lang.String" 'string? 27 | "clojure.lang.Keyword" 'keyword? 28 | "clojure.lang.Symbol" 'symbol? 29 | "java.util.UUID" 'uuid? 30 | ;; @todo 'inst? 31 | cls)}) 32 | -------------------------------------------------------------------------------- /src/erp12/schema_inference/impl/util.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.impl.util 2 | (:require [clojure.set :as set] 3 | [erp12.schema-inference.impl.ground :as g])) 4 | 5 | (defn ground? 6 | [{:keys [type] :as schema}] 7 | (and (= (count schema) 1) 8 | (or (ident? type) (class? type)) 9 | (not= type :s-var))) 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | (defmulti free-type-vars (fn [s] (if (ground? s) :ground (:type s)))) 14 | 15 | (defmethod free-type-vars :ground [_] #{}) 16 | (defn- free-type-vars-ctor1 [{:keys [child]}] (free-type-vars child)) 17 | (defmethod free-type-vars :vector [schema] (free-type-vars-ctor1 schema)) 18 | (defmethod free-type-vars :set [schema] (free-type-vars-ctor1 schema)) 19 | (defmethod free-type-vars :sequential [schema] (free-type-vars-ctor1 schema)) 20 | (defmethod free-type-vars :maybe [schema] (free-type-vars-ctor1 schema)) 21 | 22 | (defn- free-type-vars-ctorN 23 | [{:keys [children]}] 24 | (reduce #(set/union %1 (free-type-vars %2)) #{} children)) 25 | 26 | (defmethod free-type-vars :tuple [schema] (free-type-vars-ctorN schema)) 27 | (defmethod free-type-vars :cat [schema] (free-type-vars-ctorN schema)) 28 | 29 | (defmethod free-type-vars :map-of 30 | [{:keys [key value]}] 31 | (set/union (free-type-vars key) (free-type-vars value))) 32 | 33 | (defmethod free-type-vars :=> 34 | [{:keys [input output]}] 35 | (set/union (free-type-vars input) (free-type-vars output))) 36 | 37 | (defmethod free-type-vars :s-var [{:keys [sym]}] #{sym}) 38 | 39 | (defmethod free-type-vars :scheme 40 | [{:keys [s-vars body]}] 41 | (set/difference (free-type-vars body) 42 | (set (map :sym s-vars)))) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | 46 | (defn free-type-vars-env 47 | [env] 48 | (reduce #(set/union %1 (free-type-vars (val %2))) 49 | #{} 50 | env)) 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | ;; @todo Consider generic substitution function (ie. clojure.walk/postwalk-replace) that replaces more than s-vars. 55 | 56 | (defmulti substitute (fn [_ x] (if (ground? x) :ground (:type x)))) 57 | 58 | (defmethod substitute :ground [_ schema] 59 | (update schema :type #(get g/canonical-ground % %))) 60 | 61 | (defmethod substitute :=> 62 | [subs {:keys [input output]}] 63 | {:type :=> 64 | :input (substitute subs input) 65 | :output (substitute subs output)}) 66 | 67 | (defmethod substitute :s-var 68 | [subs s-var] 69 | (get subs (:sym s-var) s-var)) 70 | 71 | (defn- substitute-ctor1 72 | [subs {:keys [child] :as schema}] 73 | (assoc schema :child (substitute subs child))) 74 | 75 | (defmethod substitute :vector [subs schema] (substitute-ctor1 subs schema)) 76 | (defmethod substitute :set [subs schema] (substitute-ctor1 subs schema)) 77 | (defmethod substitute :sequential [subs schema] (substitute-ctor1 subs schema)) 78 | (defmethod substitute :maybe [subs schema] (substitute-ctor1 subs schema)) 79 | 80 | (defn- substitute-ctorN 81 | [subs {:keys [children] :as schema}] 82 | (assoc schema :children (mapv #(substitute subs %) children))) 83 | 84 | (defmethod substitute :tuple [subs schema] (substitute-ctorN subs schema)) 85 | (defmethod substitute :cat [subs schema] (substitute-ctorN subs schema)) 86 | 87 | (defmethod substitute :map-of 88 | [subs {:keys [key value] :as map-of}] 89 | (assoc map-of 90 | :key (substitute subs key) 91 | :value (substitute subs value))) 92 | 93 | (defmethod substitute :scheme 94 | [subs {:keys [s-vars body] :as scheme}] 95 | (assoc scheme 96 | :body (substitute (apply dissoc subs (map :sym s-vars)) 97 | body))) 98 | 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | 101 | (defn substitute-env 102 | [subs env] 103 | (->> env 104 | (map (fn [[sym schema]] [sym (substitute subs schema)])) 105 | (into {}))) 106 | 107 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 | 109 | (defn compose-substitutions 110 | "Combines 2 sets of type substitutions." 111 | [subs1 subs2] 112 | (into subs1 113 | (->> subs2 114 | (map (fn [[k v]] 115 | [k (substitute subs1 v)])) 116 | (into {})))) 117 | 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | 120 | (defmulti instantiate :type) 121 | 122 | (defmethod instantiate :scheme 123 | [{:keys [s-vars body]}] 124 | (let [fresh-vars (repeatedly (count s-vars) (fn [] {:type :s-var :sym (gensym "s-")})) 125 | subs (zipmap (map :sym s-vars) fresh-vars)] 126 | (substitute subs body))) 127 | 128 | (defmethod instantiate :default [schema] schema) 129 | 130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 131 | 132 | (defn generalize 133 | [env schema] 134 | (let [schema (instantiate schema) 135 | s-vars (sort (set/difference (free-type-vars schema) (free-type-vars-env env)))] 136 | (if (empty? s-vars) 137 | schema 138 | {:type :scheme 139 | :s-vars (vec (map (fn [sym] {:sym sym}) s-vars)) 140 | :body schema}))) 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | ;; Most General Unifier 144 | 145 | (defn- mgu-dispatch 146 | [{a-type :type :as a} {b-type :type :as b}] 147 | (cond 148 | (and (= a-type :maybe) 149 | (= b-type :maybe)) 150 | [:maybe :maybe] 151 | 152 | (= a-type :s-var) [:s-var :_] 153 | (= b-type :s-var) [:_ :s-var] 154 | :else [a-type b-type])) 155 | 156 | (defn mgu-failure? 157 | [x] 158 | (and (map? x) (some? (:mgu-failure x)))) 159 | 160 | (defmulti mgu mgu-dispatch) 161 | 162 | (defn- with-mgu 163 | [schema1 schema2 fn] 164 | (let [result (mgu schema1 schema2)] 165 | (if (mgu-failure? result) 166 | result 167 | (fn result)))) 168 | 169 | (defn- bind-var 170 | [{:keys [sym] :as s-var} schema] 171 | (cond 172 | (= s-var schema) {} 173 | 174 | (contains? (free-type-vars schema) sym) 175 | {:mgu-failure :occurs-check 176 | :schema-1 s-var 177 | :schema-2 schema} 178 | 179 | :else {sym schema})) 180 | 181 | (defmethod mgu [:s-var :_] [a b] (bind-var a b)) 182 | (defmethod mgu [:_ :s-var] [a b] (bind-var b a)) 183 | 184 | (defn- mgu-schema-ctor1 185 | [{a-type :type a-child :child :as a} {b-type :type b-child :child :as b}] 186 | (if (not= a-type b-type) 187 | {:mgu-failure :mismatched-schema-ctor 188 | :schema-1 a 189 | :schema-2 b} 190 | (mgu a-child b-child))) 191 | 192 | (defmethod mgu [:vector :vector] [a b] (mgu-schema-ctor1 a b)) 193 | (defmethod mgu [:set :set] [a b] (mgu-schema-ctor1 a b)) 194 | (defmethod mgu [:sequential :sequential] [a b] (mgu-schema-ctor1 a b)) 195 | (defmethod mgu [:maybe :maybe] [a b] (mgu-schema-ctor1 a b)) 196 | 197 | (defn- mgu-schema-ctorN 198 | [{a-type :type a-children :children :as a} 199 | {b-type :type b-children :children :as b}] 200 | (cond 201 | (not= a-type b-type) 202 | {:mgu-failure :mismatched-schema-ctor 203 | :schema-1 a 204 | :schema-2 b} 205 | 206 | (not= (count a-children) (count b-children)) 207 | {:mgu-failure :mismatched-arity 208 | :schema-1 a 209 | :schema-2 b} 210 | 211 | :else 212 | (->> (map vector a-children b-children) 213 | (reduce (fn [subs [a-child b-child]] 214 | (if (mgu-failure? subs) 215 | subs 216 | (with-mgu (substitute subs a-child) 217 | (substitute subs b-child) 218 | #(compose-substitutions % subs)))) 219 | {})))) 220 | 221 | (defmethod mgu [:tuple :tuple] [a b] (mgu-schema-ctorN a b)) 222 | (defmethod mgu [:cat :cat] [a b] (mgu-schema-ctorN a b)) 223 | 224 | (defmethod mgu [:map-of :map-of] 225 | [{a-key :key a-value :value} {b-key :key b-value :value}] 226 | (with-mgu a-key b-key 227 | (fn [key-subs] 228 | (with-mgu (substitute key-subs a-value) 229 | (substitute key-subs b-value) 230 | (fn [value-subs] 231 | (compose-substitutions value-subs key-subs)))))) 232 | 233 | (defmethod mgu [:=> :=>] 234 | [{a-input :input a-output :output :as a} {b-input :input b-output :output :as b}] 235 | ;; @todo Support other function args (named, variatic) aside from :cat 236 | (if (or (not= (:type a-input) :cat) 237 | (not= (:type b-input) :cat)) 238 | {:mgu-failure :non-positional-args 239 | :schema-1 a 240 | :schema-2 b} 241 | (with-mgu a-input b-input 242 | (fn [subs] 243 | (with-mgu (substitute subs a-output) 244 | (substitute subs b-output) 245 | #(compose-substitutions % subs)))))) 246 | 247 | (defmethod mgu :default 248 | [a b] 249 | (if (= a b) 250 | {} 251 | {:schema-1 a 252 | :schema-2 b 253 | :mgu-failure :non-equal})) 254 | 255 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 256 | ;; Sub-schema 257 | 258 | ;; @todo Add support for 'any? 259 | 260 | (defn- sub-schema?-sub-dispatch 261 | [{:keys [type] :as schema}] 262 | (cond 263 | (class? type) :class 264 | (ground? schema) :ground 265 | :else type)) 266 | 267 | (defn- sub-schema?-dispatch 268 | [sub sup] 269 | [(sub-schema?-sub-dispatch sub) 270 | (sub-schema?-sub-dispatch sup)]) 271 | 272 | (defmulti sub-schema? sub-schema?-dispatch) 273 | 274 | (defmethod sub-schema? :default 275 | [sub sup] 276 | (throw (ex-info "sub-schema? not yet supported for non-class schemas." 277 | {:sub sub :sup sup}))) 278 | 279 | (defmethod sub-schema? [:class :class] 280 | [{sub-type :type} {sup-type :type}] 281 | (contains? (supers sub-type) sup-type)) 282 | -------------------------------------------------------------------------------- /test/erp12/schema_inference/impl/algo_w_test.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.impl.algo_w-test 2 | (:require [clojure.test :refer [deftest is testing]] 3 | [clojure.tools.analyzer.jvm :as ana] 4 | [erp12.schema-inference.impl.algo_w :refer [algo-w] :as a]) 5 | (:import (java.io PrintStream))) 6 | 7 | ;; Keep some empty vars to be used arbitrarily in test ASTs. 8 | (declare f) 9 | 10 | ;; @todo Test type checker failures 11 | 12 | (def test-env 13 | {'clojure.lang.Numbers/inc 14 | {:type :=> 15 | :input {:type :cat 16 | :children [{:type 'int?}]} 17 | :output {:type 'int?}} 18 | 19 | 'clojure.core/inc 20 | {:type :=> 21 | :input {:type :cat 22 | :children [{:type 'int?}]} 23 | :output {:type 'int?}} 24 | 25 | 'clojure.core/if 26 | {:type :scheme 27 | :s-vars [{:sym 'a}] 28 | :body {:type :=> 29 | :input {:type :cat 30 | :children [{:type 'boolean?} 31 | {:type :s-var :sym 'a} 32 | {:type :s-var :sym 'a}]} 33 | :output {:type :s-var :sym 'a}}} 34 | 35 | 'clojure.core/map 36 | {:type :scheme 37 | :s-vars [{:sym 'a} {:sym 'b}] 38 | :body {:type :=> 39 | :input {:type :cat 40 | :children [{:type :=> 41 | :input {:type :cat 42 | :children [{:type :s-var :sym 'a}]} 43 | :output {:type :s-var :sym 'b}} 44 | {:type :vector 45 | :child {:type :s-var :sym 'a}}]} 46 | :output {:type :vector 47 | :child {:type :s-var :sym 'b}}}}}) 48 | 49 | (deftest algo-w-const-test 50 | (is (= (algo-w (ana/analyze :a) test-env) 51 | {::a/subs {} 52 | ::a/schema {:type 'keyword?}}))) 53 | 54 | (deftest algo-w-do-test 55 | (is (= (algo-w (ana/analyze '(do (println "!") 1)) test-env) 56 | {::a/subs {} 57 | ::a/schema {:type 'int?}}))) 58 | 59 | (deftest algo-w-fn-test 60 | (let [{::a/keys [subs schema failure]} 61 | (algo-w (ana/analyze '(fn [x] (inc x))) test-env)] 62 | (is (nil? failure)) 63 | (is (= schema {:type :=> 64 | :input {:type :cat 65 | :children [{:type 'int?}]} 66 | :output {:type 'int?}})) 67 | (is (= (count subs) 2))) 68 | (let [{::a/keys [subs schema failure]} 69 | (algo-w (ana/analyze `(fn [x#] (f (inc x#) 1))) 70 | (assoc test-env 71 | `f {:type :scheme 72 | :s-vars [{:sym 'a}] 73 | :body {:type :=> 74 | :input {:type :cat 75 | :children [{:type :s-var :sym 'a} 76 | {:type :s-var :sym 'a}]} 77 | :output {:type :s-var :sym 'a}}}))] 78 | (is (nil? failure)) 79 | (is (= schema {:type :=> 80 | :input {:type :cat 81 | :children [{:type 'int?}]} 82 | :output {:type 'int?}})) 83 | (is (= (count subs) 4))) 84 | (testing "nullary" 85 | (let [{::a/keys [subs schema failure]} 86 | (algo-w (ana/analyze `((fn [] 1))) {})] 87 | (is (nil? failure)) 88 | (is (= schema {:type 'int?})) 89 | (is (= (count subs) 1)))) 90 | (testing "polymorphic" 91 | (let [{::a/keys [subs schema failure]} 92 | (algo-w (ana/analyze `(fn [x# y#] (f x# y#))) 93 | (assoc test-env 94 | `f {:type :scheme 95 | :s-vars [{:sym 'a} {:sym 'b}] 96 | :body {:type :=> 97 | :input {:type :cat 98 | :children [{:type :s-var :sym 'a} 99 | {:type :s-var :sym 'b}]} 100 | :output {:type :s-var :sym 'b}}})) 101 | inputs (set (get-in schema [:input :children])) 102 | output (:output schema)] 103 | (is (nil? failure)) 104 | ;; @todo Find better way to test. Meander? 105 | (is (= (:type schema) :=>)) 106 | (is (= (count inputs) 2)) 107 | (is (contains? inputs output)) 108 | (is (every? #(= (:type %) :s-var) (cons output inputs))) 109 | (is (= (count subs) 3))))) 110 | 111 | (deftest algo-w-if-test 112 | (let [{::a/keys [subs schema failure]} 113 | (algo-w (ana/analyze `(if true 1 2)) test-env)] 114 | (is (nil? failure)) 115 | (is (= schema {:type 'int?})) 116 | (is (= (count subs) 2))) 117 | (testing "failure" 118 | (let [{::a/keys [subs schema failure]} 119 | (algo-w (ana/analyze `(if true 1 "2")) test-env)] 120 | (is (= failure 121 | {:unification-failure {:mgu-failure :non-equal 122 | :schema-1 {:type 'int?} 123 | :schema-2 {:type 'string?}}})) 124 | (is (nil? schema)) 125 | (is (nil? subs))))) 126 | 127 | (deftest algo-w-import-test 128 | (is (= (algo-w (ana/analyze `(import 'clojure.lang.Keyword)) test-env) 129 | {::a/subs {} ::a/schema nil?}))) 130 | 131 | (deftest algo-w-instance?-test 132 | (is (= (algo-w (ana/analyze `(instance? String "")) test-env) 133 | {::a/subs {} ::a/schema 'boolean?}))) 134 | 135 | (deftest algo-w-invoke-test 136 | (let [{::a/keys [subs schema failure]} 137 | (algo-w (ana/analyze `(map inc [0])) test-env)] 138 | (is (nil? failure)) 139 | (is (= schema {:type :vector :child {:type 'int?}})) 140 | (is (= (count subs) 3)))) 141 | 142 | (deftest algo-w-let-test 143 | (let [{::a/keys [subs schema failure]} 144 | (algo-w (ana/analyze `(let [f# inc 145 | a# 1] 146 | (f# a#))) 147 | test-env)] 148 | (is (nil? failure)) 149 | (is (= schema {:type 'int?})) 150 | (is (= (count subs) 1)))) 151 | 152 | (deftest algo-w-letfn-test 153 | (let [{::a/keys [subs schema failure]} 154 | (algo-w (ana/analyze `(letfn [(f# [x#] (inc x#)) 155 | (g# [y#] (f# (f# y#)))] 156 | (g# 0))) 157 | test-env)] 158 | (is (nil? failure)) 159 | (is (= schema {:type 'int?})) 160 | (is (= (count subs) 6))) 161 | ; @todo (testing "ahead-of-definition") 162 | ) 163 | 164 | ;; Implicitly tested 165 | ;(deftest algo-w-local-test) 166 | 167 | (deftest algo-w-prim-invoke-test 168 | (let [{::a/keys [subs schema failure]} 169 | (algo-w (ana/analyze '((fn [^long x] x) 1)) test-env)] 170 | (is (nil? failure)) 171 | (is (= schema {:type 'int?})) 172 | (is (= (count subs) 2)))) 173 | 174 | (defprotocol P 175 | (foo [_ x])) 176 | 177 | (defrecord R [y] 178 | P 179 | (foo [_ x] (+ x y))) 180 | 181 | (deftest algo-w-protocol-invoke-test 182 | (let [{::a/keys [subs schema failure] :as r} 183 | (algo-w (ana/analyze `(foo (->R 1) 2)) 184 | (assoc test-env 185 | `->R {:type :=> 186 | :input {:type :cat 187 | :children [{:type 'int?}]} 188 | :output {:type R}} 189 | `foo {:type :=> 190 | :input {:type :cat 191 | :children [{:type (:on-interface P)} 192 | {:type 'int?}]} 193 | :output {:type 'int?}}))] 194 | (is (nil? failure)) 195 | (is (= schema {:type 'int?})) 196 | (is (= (count subs) 1)))) 197 | 198 | (deftest algo-w-quote-test 199 | (is (= (algo-w (ana/analyze `(quote (+ 1 2))) test-env) 200 | {::a/subs {} 201 | ::a/schema {:type :sequential 202 | :child {:type 'some?}}}))) 203 | 204 | ;(deftest algo-w-set!-test) 205 | 206 | (deftest algo-w-static-call-test 207 | (let [{::a/keys [subs schema failure]} (algo-w (ana/analyze '(inc 1)) test-env)] 208 | (is (nil? failure)) 209 | (is (= schema {:type 'int?})) 210 | (is (= (count subs) 1)))) 211 | 212 | (deftest algo-w-static-field-test 213 | (let [{::a/keys [subs schema failure]} (algo-w (ana/analyze `System/out) test-env)] 214 | (is (nil? failure)) 215 | (is (= schema {:type PrintStream})) 216 | (is (= (count subs) 0)))) 217 | 218 | (deftest algo-w-the-var-test 219 | (let [{::a/keys [subs schema failure]} (algo-w (ana/analyze `(var +)) test-env)] 220 | (is (nil? failure)) 221 | (is (= schema {:type 'var?})) 222 | (is (= (count subs) 0)))) 223 | 224 | ;(deftest algo-w-throw-test) 225 | ;(deftest algo-w-try-test) 226 | 227 | (deftest algo-w-var-test 228 | (let [{::a/keys [subs schema failure]} (algo-w (ana/analyze `clojure.core/inc) test-env)] 229 | (is (nil? failure)) 230 | (is (= schema {:type :=> 231 | :input {:type :cat 232 | :children [{:type 'int?}]} 233 | :output {:type 'int?}})) 234 | (is (= (count subs) 0)))) -------------------------------------------------------------------------------- /test/erp12/schema_inference/impl/util_test.clj: -------------------------------------------------------------------------------- 1 | (ns erp12.schema-inference.impl.util-test 2 | (:require [clojure.string :as str] 3 | [clojure.test :refer :all] 4 | [erp12.schema-inference.impl.util :as u])) 5 | 6 | (deftest ground?-test 7 | (is (u/ground? {:type 'string?})) 8 | (is (not (u/ground? {:type :vector 9 | :child {:type 'int?}}))) 10 | (is (not (u/ground? {:type :=> 11 | :input {:type :cat 12 | :children [{:type 'int?}]} 13 | :output {:type 'float?}}))) 14 | (is (not (u/ground? {:type :scheme 15 | :s-vars [{:sym 'x}] 16 | :body {:type :=> 17 | :input {:type :cat 18 | :children [{:type 'int?}]} 19 | :output {:type 'float?}}})))) 20 | 21 | (deftest substitute-test 22 | (let [x->y #(u/substitute {'x {:type :s-var :sym 'y}} %)] 23 | (is (= {:type :s-var :sym 'y} 24 | (x->y {:type :s-var :sym 'x}))) 25 | (is (= {:type :s-var :sym 'z} 26 | (x->y {:type :s-var :sym 'z}))) 27 | (testing "tuple schema" 28 | (is (= {:type :tuple :children [{:type :s-var :sym 'y} {:type :s-var :sym 'y}]} 29 | (x->y {:type :tuple :children [{:type :s-var :sym 'x} {:type :s-var :sym 'x}]})))) 30 | (testing "function schema" 31 | (is (= {:type :=> 32 | :input {:type :cat 33 | :children [{:type :s-var :sym 'y}]} 34 | :output {:type :s-var :sym 'y}} 35 | (x->y {:type :=> 36 | :input {:type :cat 37 | :children [{:type :s-var :sym 'x}]} 38 | :output {:type :s-var :sym 'x}})))) 39 | (testing "scheme" 40 | (is (= {:type :scheme 41 | :s-vars [{:sym 'z}] 42 | :body {:type :s-var :sym 'y}} 43 | (x->y {:type :scheme 44 | :s-vars [{:sym 'z}] 45 | :body {:type :s-var :sym 'x}}))) 46 | ;; Occurs check 47 | (is (= {:type :scheme 48 | :s-vars [{:sym 'x}] 49 | :body {:type :s-var :sym 'x}} 50 | (x->y {:type :scheme 51 | :s-vars [{:sym 'x}] 52 | :body {:type :s-var :sym 'x}})))))) 53 | 54 | (deftest substitute-env-test 55 | (is {'a {:type :scheme 56 | :s-vars [{:sym 'z}] 57 | :body {:type :vector 58 | :child {:type :s-var :sym 'y}}} 59 | 'b {:type :scheme 60 | :s-vars [{:sym 'x}] 61 | :body {:type :set 62 | :child {:type :s-var :sym 'x}}}} 63 | (u/substitute-env {'x {:type :s-var :sym 'y}} 64 | {'a {:type :scheme 65 | :s-vars [{:sym 'z}] 66 | :body {:type :vector 67 | :child {:type :s-var :sym 'x}}} 68 | 'b {:type :scheme 69 | :s-vars [{:sym 'x}] 70 | :body {:type :set 71 | :child {:type :s-var :sym 'x}}}}))) 72 | 73 | (deftest compose-substitutions-test 74 | (is (= (u/compose-substitutions {} {}) 75 | {})) 76 | (is (= (u/compose-substitutions {'a {:type :s-var, :sym 'b}} 77 | {'b {:type 'boolean?}}) 78 | {'a {:sym 'b :type :s-var} 79 | 'b {:type 'boolean?}})) 80 | (is (= (u/compose-substitutions {'x {:type 'string?} 81 | 'y {:type 'int?}} 82 | {'y {:type :s-var :sym 'x}}) 83 | {'x {:type 'string?} 84 | 'y {:type 'string?}}))) 85 | 86 | (deftest free-type-vars-test 87 | (is (= #{'x} (u/free-type-vars {:type :s-var :sym 'x}))) 88 | (is (= #{} (u/free-type-vars {:type 'string?}))) 89 | (testing "function schemas" 90 | (is (= #{'x 'y} (u/free-type-vars {:type :=> 91 | :input {:type :cat 92 | :children [{:type :s-var :sym 'x}]} 93 | :output {:type :s-var :sym 'y}}))) 94 | (is (= #{'x 'y} (u/free-type-vars {:type :=> 95 | :input {:type :cat 96 | :children [{:type :s-var :sym 'x} 97 | {:type :s-var :sym 'y}]} 98 | :output {:type :s-var :sym 'x}})))) 99 | (is (= #{} 100 | (u/free-type-vars {:type :map-of :key {:type 'int?} :value {:type 'string?}}))) 101 | (testing "scheme" 102 | (is (= #{'y} 103 | (u/free-type-vars {:type :scheme 104 | :s-vars [{:sym 'x}] 105 | :body {:type :=> 106 | :input {:type :cat 107 | :children [{:type :s-var :sym 'x}]} 108 | :output {:type :s-var :sym 'y}}}))) 109 | (is (= #{} 110 | (u/free-type-vars {:type :scheme 111 | :s-vars [{:sym 'x} {:sym 'y}] 112 | :body {:type :=> 113 | :input {:type :cat 114 | :children [{:type :s-var :sym 'x}]} 115 | :output {:type :s-var :sym 'y}}}))))) 116 | 117 | (deftest free-type-vars-env-test 118 | (is (= (u/free-type-vars-env {'a {:type :scheme 119 | :s-vars [{:sym 'z}] 120 | :body {:type :vector 121 | :child {:type :s-var :sym 'x}}} 122 | 'b {:type :scheme 123 | :s-vars [{:sym 'x}] 124 | :body {:type :set 125 | :child {:type :s-var :sym 'x}}}}) 126 | #{'x}))) 127 | 128 | (deftest instantiate-test 129 | (is (= (u/instantiate {:type 'int?}) 130 | {:type 'int?})) 131 | (is (= (u/instantiate {:type :s-var :sym 'x}) 132 | {:type :s-var :sym 'x})) 133 | (let [s (u/instantiate {:type :scheme 134 | :s-vars [{:sym 'x}] 135 | :body {:type :vector 136 | :child {:type :s-var :sym 'x}}})] 137 | (is (= (:type s) :vector)) 138 | (is (= (get-in s [:child :type]) :s-var)) 139 | (is (str/starts-with? (name (get-in s [:child :sym])) "s-")))) 140 | 141 | (deftest generalize-test 142 | (let [env {'a {:type 'int?} 143 | 'b {:type :s-var :sym 'x}}] 144 | (is (= {:type 'int?} 145 | (u/generalize env {:type 'int?}))) 146 | (is (= {:type :s-var :sym 'x} 147 | (u/generalize env {:type :s-var :sym 'x}))) 148 | (is (= {:type :scheme 149 | :s-vars [{:sym 'y}] 150 | :body {:type :vector 151 | :child {:type :s-var :sym 'y}}} 152 | (u/generalize env 153 | {:type :vector 154 | :child {:type :s-var :sym 'y}}))))) 155 | 156 | (deftest mgu-test 157 | (testing "atomic types" 158 | (is (= (u/mgu {:type 'int?} {:type 'int?}) 159 | {})) 160 | (is (= (u/mgu {:type 'int?} {:type 'string?}) 161 | {:mgu-failure :non-equal 162 | :schema-1 {:type 'int?} 163 | :schema-2 {:type 'string?}}))) 164 | (testing "s-vars" 165 | (is (= (u/mgu {:type :s-var :sym 'a} 166 | {:type :s-var :sym 'b}) 167 | {'a {:type :s-var :sym 'b}})) 168 | (is (= (u/mgu {:type 'int?} 169 | {:type :s-var :sym 'a}) 170 | {'a {:type 'int?}})) 171 | (is (= (u/mgu {:type :s-var :sym 'a} 172 | {:type :s-var :sym 'a}) 173 | {}))) 174 | (testing "function types" 175 | (is (= (u/mgu {:type :=>, 176 | :input {:type :cat, 177 | :children [{:type :s-var, :sym 'a}]}, 178 | :output {:type :s-var, :sym 'a}} 179 | {:type :=>, 180 | :input {:type :cat, 181 | :children [{:type :s-var, :sym 'b}]}, 182 | :output {:type :s-var, :sym 'b}}) 183 | {'a {:type :s-var :sym 'b}})) 184 | (is (= (u/mgu {:type :=>, 185 | :input {:type :cat, 186 | :children [{:type :s-var, :sym 'a} 187 | {:type :s-var, :sym 'a}]}, 188 | :output {:type :s-var, :sym 'a}} 189 | {:type :=>, 190 | :input {:type :cat, 191 | :children [{:type :s-var, :sym 'b} 192 | {:type :s-var, :sym 'b}]}, 193 | :output {:type :s-var, :sym 'b}}) 194 | {'a {:type :s-var :sym 'b}})) 195 | (is (= (u/mgu {:type :=>, 196 | :input {:type :cat, 197 | :children [{:type :s-var, :sym 'a}]}, 198 | :output {:type :s-var, :sym 'a}} 199 | {:type :=>, 200 | :input {:type :cat, 201 | :children [{:type :s-var, :sym 'b}]}, 202 | :output {:type :vector 203 | :child {:type :s-var, :sym 'b}}}) 204 | {:mgu-failure :occurs-check 205 | :schema-1 {:type :s-var, :sym 'b} 206 | :schema-2 {:type :vector 207 | :child {:type :s-var, :sym 'b}}}))) 208 | (testing "map types" 209 | (is (= (u/mgu {:type :map-of 210 | :key {:type 'string?} 211 | :value {:type :s-var, :sym 'v}} 212 | {:type :map-of 213 | :key {:type :s-var, :sym 'k} 214 | :value {:type 'boolean?}}) 215 | {'k {:type 'string?} 216 | 'v {:type 'boolean?}}))) 217 | (testing "tuple types" 218 | (is (= (u/mgu {:type :tuple 219 | :children [{:type :s-var, :sym 'a} 220 | {:type 'int?}]} 221 | {:type :tuple 222 | :children [{:type 'string?} 223 | {:type :s-var, :sym 'b}]}) 224 | {'a {:type 'string?} 225 | 'b {:type 'int?}})) 226 | (is (u/mgu-failure? (u/mgu {:type :tuple 227 | :children [{:type :s-var, :sym 'a} 228 | {:type 'int?} 229 | {:type :s-var, :sym 'c}]} 230 | {:type :tuple 231 | :children [{:type 'string?} 232 | {:type :s-var, :sym 'b}]})))) 233 | (testing "set types" 234 | (is (= (u/mgu {:type :set :child {:type :s-var, :sym 'a}} 235 | {:type :set :child {:type 'int?}}) 236 | {'a {:type 'int?}})))) 237 | --------------------------------------------------------------------------------