Initial commit

4 files changed, 1271 insertions, 0 deletions

diff --git a/src/jester/comparisons.clj b/src/jester/comparisons.clj
new file mode 100644
index 0000000..c47469e
--- /dev/null
+++ b/src/jester/comparisons.clj
@@ -0,0 +1,36 @@
+(ns jester.comparisons
+  "Comparison functions to specify how Jester comparisons work.")
+
+(defn string=
+  "Compare two (potentially-nil) strings. If either is nil, return nil.
+  Otherwise, return true iff a = b, ignoring case, and false
+  otherwise."
+  [^String a, ^String b]
+  (boolean (and a b (.equalsIgnoreCase a b))))
+
+(defn string<
+  "Compare two (potentially-nil) strings. If either is nil, return nil.
+  Otherwise, return true iff a < b, ignoring case, and false
+  otherwise."
+  [^String a, ^String b]
+  (and a b (< (.compareToIgnoreCase a b) 0)))
+
+(defn number=
+  "Compare two (potentially-nil) numbers. If either is nil, return nil.
+  If either is NaN, return false. Otherwise, return true iff a = b,
+  and false otherwise."
+  [a b]
+  (boolean (and a b (== a b))))
+
+(defn number<
+  "Compare two (potentially-nil) numbers. If either is nil, return nil.
+  If either is NaN, return false. Otherwise, return true iff a < b,
+  and false otherwise."
+  [a b]
+  (boolean (and a b (< a b))))
+
+(defn boolean=
+  "Compare two (potentially-nil) booleans. If either is nil, return nil.
+  Otherwise, return true iff a = b, and false otherwise."
+  [a b]
+  (boolean (and (some? a) (some? b) (= a b))))
diff --git a/src/jester/expansion.clj b/src/jester/expansion.clj
new file mode 100644
index 0000000..b6c915b
--- /dev/null
+++ b/src/jester/expansion.clj
@@ -0,0 +1,460 @@
+(ns jester.expansion
+  (:require [clojure.string :as str]
+            [clojure.walk :as walk]
+            [jester.comparisons :refer [string= string<
+                                        number= number<
+                                        boolean=]]
+            [jester.match :refer [type-match]]
+            [jester.types :refer [in-constraint-environment
+                                  constrain
+                                  ground-type
+                                  type-variable]]))
+
+(defn ^:private type-of
+  "Return the type of an expanded form. This relies on the metadata,
+  except for primitive types where metadata can't be stored."
+  [expanded-form]
+  (cond (number? expanded-form)  `(enum ~expanded-form)
+        (string? expanded-form)  `(enum ~expanded-form)
+        (boolean? expanded-form) `(enum ~expanded-form)
+        (nil? expanded-form)     `(optional ~(type-variable))
+        :else                    (::type (meta expanded-form))))
+
+(defn ^:private with-type [object type]
+  (with-meta object {::type type}))
+
+(def ^:private ^:dynamic *parameters*)
+
+(declare expand-form*)
+
+(defn regex-start-index
+  "Return the index of the first character in `string` which matches the
+  start of an instance of `regex`."
+  [regex string]
+  (let [matcher (re-matcher #"\??\." string)]
+    (when (.find matcher)
+      (.start matcher))))
+
+(defn expand-symbol [form]
+  (let [string (name form)]
+    (if-let [sep-index (regex-start-index #"\??\." string)]
+      (let [root     (.substring string 0 sep-index)
+            rest     (.substring string sep-index)
+            root-sym (symbol root)]
+        (expand-form* `(~(symbol rest)
+                        ~root-sym)))
+      (with-type form
+        (or (get *parameters* form)
+            (let [type (type-variable)]
+              (set! *parameters* (assoc *parameters* form type))
+              type))))))
+
+(defn getter-expander [form]
+  (let [[head arg] form
+        string     (name head)]
+    (when-not (or (str/starts-with? string ".")
+                  (str/starts-with? string "?."))
+      (throw (ex-info "Unknown value in head of form"
+                      {:form form})))
+    (let [;; This complicated regex splits the string into parts
+          ;; starting with either "?" or "?."
+          parts (str/split string #"(?=\?\.|(?<!\?)\.)")
+          part  ^String (last parts)
+          rest  (butlast parts)]
+      (cond
+        (str/starts-with? part ".")
+        (let [type     (type-variable)
+              part-sym (symbol (.substring part 1))
+              expanded (expand-form*
+                        (if (empty? rest)
+                          arg
+                          `(~(symbol (str/join rest)) ~arg)))]
+          (constrain (type-of expanded) {part-sym type})
+          (with-type `(get ~expanded '~part-sym)
+            type))
+        (str/starts-with? part "?.")
+        (let [type     (type-variable)
+              part-sym (symbol (.substring part 2))
+              expanded (expand-form*
+                        (if (empty? rest)
+                          arg
+                          `(~(symbol (str/join rest)) ~arg)))]
+          (constrain (type-of expanded)
+                                `(optional {~part-sym (optional ~type)}))
+          (with-type `(get ~expanded '~part-sym)
+            `(optional ~type)))
+        :else
+        (throw (ex-info "Invalid head for getter"
+                        {:head head
+                         :part part
+                         :rest rest}))))))
+
+(defn expand-map [form]
+  (let [expressions (reduce-kv (fn [acc k value-form]
+                                 (assoc acc (list 'quote k) (expand-form* value-form)))
+                               {} form)]
+    (with-type expressions
+      (reduce-kv (fn [acc k expanded]
+                   (assoc acc (second k) (type-of expanded)))
+                 {} expressions))))
+
+(defn expand-vector [form]
+  (let [terms (mapv expand-form* form)]
+    (with-type terms
+      (mapv #(type-of %) terms))))
+
+(def expanders {})
+(def operators {})
+
+(defn expand-operator-form [operator form]
+  (let [result (type-variable)
+        args   (map expand-form* (rest form))]
+    (constrain ((:type operator)) `(-> ~(mapv type-of args) ~result))
+    (with-type `(~(:name operator) ~@args)
+      result)))
+
+(defn expand-form* [form]
+  (cond
+    (number? form)  form
+    (string? form)  form
+    (boolean? form) form
+    (nil? form)     form
+    (symbol? form)  (expand-symbol form)
+    (map? form)     (expand-map form)
+    (vector? form)  (expand-vector form)
+    (seq? form)     (if (symbol? (first form))
+                      (if-let [operator (get operators (first form))]
+                        (if (get expanders (first form))
+                          (throw (ex-info (format "Found both an operator and an expander for %s"
+                                                  (pr-str (first form)))
+                                          {:head (first form)
+                                           :form form}))
+                          (expand-operator-form operator form))
+                        (if-let [expander (get expanders (first form))]
+                          (expander form)
+                          (getter-expander form)))
+                      (throw (ex-info "Invalid form"
+                                      {:form form})))
+    :else           (throw (ex-info "Invalid form"
+                                    {:form form}))))
+
+(defn ^:private force-all
+  "Walk over a structure, iterating over child objects and forcing
+  sequences. The result is identical the input object.
+
+    (let [x ...]
+      (identical? x (force-all x)))
+    ;;=> true "
+  [obj]
+  (cond
+    ;; Reduce over sequences, vectors, and sets
+    (or (seq? obj)
+        (vector? obj)
+        (set? obj))
+    (reduce (fn [result item]
+              (force-all item)
+              result)
+            obj obj)
+    ;; Reduce over the keys and values in maps
+    (map? obj)
+    (reduce-kv (fn [result key value]
+                 (force-all key)
+                 (force-all value)
+                 result)
+               obj obj)
+    ;; Return everything else unchanged.
+    :else
+    obj))
+
+(defn expand-form [form]
+  (binding [*parameters* {}]
+    (in-constraint-environment
+      (let [expanded (force-all (expand-form* form))
+            grounded (ground-type *parameters* :argument)]
+        ;; Once we've solved the input types, add constraints to
+        ;; ensure that information is captured when we solve the
+        ;; output type. We only need to add them as lower bounds,
+        ;; because :return grounding solves for the greatest lower
+        ;; bound.
+        (doseq [[param type] grounded]
+          (constrain type (get *parameters* param)))
+        (if (instance? clojure.lang.IMeta expanded)
+          (with-meta expanded
+            {:input  grounded
+             :output (ground-type (type-of expanded) :return)})
+          expanded)))))
+
+(defmacro define-expander
+  {:style/indent 2}
+  [operator-name [& args] & body]
+  `(alter-var-root #'expanders
+                   assoc '~operator-name (fn [[_# ~@args]]
+                                           ~@body)))
+
+(defn ^:private resolve-symbol [sym]
+  (let [resolved (meta (ns-resolve *ns* sym))
+        ns       (:ns resolved)]
+    (when resolved
+      (symbol (-> ns ns-name name)
+              (-> resolved :name name)))))
+
+(defmacro define-simple-operator
+  {:style/indent :defn}
+  ([name type]
+   (if-let [resolved (resolve-symbol name)]
+     `(define-simple-operator ~name ~resolved ~type)
+     (throw (ex-info (format "Cannot resolve symbol for operator: %s" (pr-str name))
+                     {:namespace *ns*
+                      :symbol    name}))))
+  ([name operator-symbol type]
+   (let [type (type-match type
+                (∀ args value)
+                `(let [~@(mapcat #(list % `(list 'var (gensym '~%))) args)]
+                   ~(quote-type value (set args)))
+                _
+                (list 'quote type))]
+     (if (namespace operator-symbol)
+       `(alter-var-root #'operators assoc '~name
+                        {:type (fn [] ~type)
+                         :name '~operator-symbol})
+       (throw (ex-info (format "Operator symbol must have a namespace" (pr-str name))
+                       {:symbol operator-symbol}))))))
+
+(defn ^:private e-use [form type]
+  (let [result (expand-form* form)]
+    (constrain (type-of result) type)
+    result))
+
+(defmacro ^:private with-temporary-parameter-type [[parameter type] & body]
+  `(try
+     (let [old# (get *parameters* ~parameter)]
+       (try
+         (set! *parameters* (assoc *parameters* ~parameter ~type))
+         (force-all (do ~@body))
+         (finally
+           (if old#
+             (set! *parameters* (assoc *parameters* ~parameter old#))
+             (set! *parameters* (dissoc *parameters* ~parameter))))))))
+
+(defn ? [optional default]
+  (if (nil? optional) default optional))
+
+(define-simple-operator ?
+    (∀ [x] (-> [(optional x) x] x)))
+
+(define-simple-operator string= (-> [string string] boolean))
+(define-simple-operator string=? (-> [(optional string) (optional string)] (optional boolean)))
+
+(define-expander find [[var & {list :in condition :when}] value]
+  (let [type   (type-variable)
+        result (with-temporary-parameter-type [var type]
+                 (expand-form* value))]
+    (with-type `(reduce (fn [_# ~var]
+                          (when ~(with-temporary-parameter-type [var type]
+                                   (e-use (or condition true) '(optional boolean)))
+                            (reduced ~result)))
+                        nil ~(e-use list `(list ~type)))
+      `(optional ~(type-of result)))))
+
+(define-expander for [[var & {list :in condition :when}] value]
+  (let [type (type-variable)
+        result (with-temporary-parameter-type [var type]
+                 (expand-form* value))]
+    (with-type `(reduce (fn [acc# ~var]
+                          (if ~(with-temporary-parameter-type [var type]
+                                 (e-use (or condition true) '(optional boolean)))
+                            (conj acc# ~result)
+                            acc#))
+                        [] ~(e-use list `(list ~type)))
+      `(list ~(type-of result)))))
+
+(define-expander all-of [[var & {list :in condition :when}] value]
+  (let [type (type-variable)]
+    (with-type `(reduce (fn [_# ~var]
+                          (if ~(with-temporary-parameter-type [var type]
+                                 `(or (not ~(e-use (or condition true) '(optional boolean)))
+                                      ~(e-use value 'boolean)))
+                            true
+                            (reduced false)))
+                        true ~(e-use list `(list ~type)))
+      'boolean)))
+
+(define-expander one-of [[var & {list :in condition :when}] value]
+  (let [type (type-variable)]
+    (with-type `(reduce (fn [_# ~var]
+                          (if ~(with-temporary-parameter-type [var type]
+                                 `(or (not ~(e-use (or condition true) '(optional boolean)))
+                                      ~(e-use value 'boolean)))
+                            true
+                            (reduced false)))
+                        true ~(e-use list `(list ~type)))
+      'boolean)))
+
+(define-expander with-optional [[var optional] value]
+  (assert (symbol? var) "Binding in with-optional must be a symbol")
+  (let [type   (type-variable)
+        result (with-temporary-parameter-type [var type]
+                 (expand-form* value))]
+    (with-type `(let [~var ~(e-use optional `(optional ~type))]
+                  (when (some? ~var)
+                    ~result))
+      `(optional ~(type-of result)))))
+
+(defn ^:private quote-type [type escape?]
+  (cond
+    (escape? type)
+    type
+    (seq? type)
+    (cons 'list (map #(quote-type % escape?) type))
+    ;; Reduce over sequences, vectors, and sets
+    (or (vector? type))
+    (reduce (fn [result item]
+              (conj result (quote-type item escape?)))
+            [] type)
+    ;; Reduce over the values in maps
+    (map? type)
+    (reduce-kv (fn [result key value]
+                 (assoc result key (quote-type value)))
+               {} type)
+    ;; Return everything else quoted.
+    :else
+    (list 'quote type)))
+
+(define-simple-operator number= (-> [number number] boolean))
+(def number=? number=)
+(define-simple-operator number=? (-> [(optional number) (optional number)] (optional boolean)))
+
+;; Working out how exactly these should behave in the presence of
+;; optionals is a bit tricky, mostly because of short-circuiting. The
+;; easiest option is to not short circuit and define it as: "and? is
+;; nil if any argument is nil, false if any argument is false, and
+;; true otherwise". The obvious question then is "why does nil win
+;; over false? Why not have it false, then nil, then true?" Working
+;; out which makes the most sense might require some thinking.
+;; TODO: work this out.
+(define-simple-operator and
+  (-> [& (list boolean)] boolean))
+(define-simple-operator and? clojure.core/and
+  (-> [& (list (optional boolean))] (optional boolean)))
+
+(define-simple-operator or
+  (-> [& (list boolean)] boolean))
+(defmacro or? [& values]
+  (if-let [[x & xs] (seq values)]
+    `(let [val# ~x]
+       (cond (nil? val#)  nil
+             (true? val#) true
+             :else `(or? ~@xs)))
+    false))
+(define-simple-operator or?
+  (-> [& (list (optional boolean))] (optional boolean)))
+
+(define-simple-operator not
+  (-> [boolean] boolean))
+(defn not? [value]
+  (cond (nil? value)  nil
+        (true? value) false
+        :else         true))
+(define-simple-operator not?
+  (-> [(optional boolean)] (optional boolean)))
+
+(define-simple-operator get
+  (∀ [k v] (-> [(map k v) k] (optional v))))
+
+(define-simple-operator str
+  (-> [& (list string)] string))
+
+(def str? str)
+(define-simple-operator str?
+  (-> [& (list (optional string))] string))
+
+(define-simple-operator count
+  (-> [(list any)] number))
+
+(def has? some?)
+(define-simple-operator has?
+  (-> [(optional any)] boolean))
+
+
+
+(import java.time.OffsetDateTime
+        java.time.ZonedDateTime
+        java.time.temporal.ChronoField
+        java.time.format.DateTimeFormatterBuilder)
+
+(def date-time-format
+  (-> (DateTimeFormatterBuilder.)
+      (.parseCaseInsensitive)
+      (.appendValue ChronoField/YEAR)
+      (.appendLiteral "-")
+      (.appendValue ChronoField/MONTH_OF_YEAR)
+      (.appendLiteral "-")
+      (.appendValue ChronoField/DAY_OF_MONTH)
+      (-> .optionalStart
+          (.appendLiteral "T")
+          (.appendValue ChronoField/HOUR_OF_DAY)
+          (.appendLiteral ":")
+          (.appendValue ChronoField/MINUTE_OF_HOUR)
+          (-> .optionalStart
+              (.appendLiteral ":")
+              (.appendValue ChronoField/SECOND_OF_MINUTE)
+              .optionalEnd)
+          .optionalEnd)
+      (-> .optionalStart
+          (.appendOffset "+HH:mm" "Z")
+          .optionalEnd)
+      (.parseDefaulting ChronoField/HOUR_OF_DAY 0)
+      (.parseDefaulting ChronoField/MINUTE_OF_HOUR 0)
+      (.parseDefaulting ChronoField/SECOND_OF_MINUTE 0)
+      (.toFormatter)
+      (.withZone java.time.ZoneOffset/UTC)))
+
+(defn parse-timestamp [string]
+  (.withOffsetSameInstant (OffsetDateTime/parse string date-time-format)
+                          (java.time.ZoneOffset/UTC)))
+
+(parse-timestamp "2021-02-23")
+
+(define-simple-operator parse-timestamp
+  (-> [string] timestamp))
+
+(defn time-unit->chrono-unit [time-unit]
+  (condp #(.equalsIgnoreCase ^String %1 ^String %2)
+      time-unit
+    "second"  java.time.temporal.ChronoUnit/SECONDS
+    "minute"  java.time.temporal.ChronoUnit/MINUTES
+    "hour"    java.time.temporal.ChronoUnit/HOURS
+    "day"     java.time.temporal.ChronoUnit/DAYS
+    "month"   java.time.temporal.ChronoUnit/MONTHS
+    "year"    java.time.temporal.ChronoUnit/YEARS))
+(defn truncate-timestamp [^OffsetDateTime time time-unit]
+  (.truncatedTo time (time-unit->chrono-unit time-unit)))
+(defn truncate-timestamp? [time time-unit]
+  (and time time-unit (truncate-timestamp time time-unit)))
+
+(define-simple-operator truncate-timestamp
+  (-> [timestamp (enum "second" "minute" "hour" "day" "month" "year")] timestamp))
+(define-simple-operator truncate-timestamp?
+  (-> [(optional timestamp)
+       (optional (enum "second" "minute" "hour" "day" "month" "year"))]
+      (optional timestamp)))
+
+(define-simple-operator then jester.core/then
+  (∀ [x y] (-> [x y] y)))
+
+;; (alter-var-root #'operators
+;;                 assoc 'str {:type #(quote (-> [& (list string)] string))
+;;                             :name 'str})
+
+;; ;; (alter-var-root #'operators
+;; ;;                 assoc 'get {:type #(let [k (type-variable)
+;; ;;                                          v (type-variable)]
+;; ;;                                      `(-> [(map ~k ~v) ~k] (optional ~v)))})
+
+;; (alter-var-root #'operators
+;;                 assoc 'str? {:type #(quote (-> [& (list (optional string))] string))
+;;                              :name 'str})
+
+;; (alter-var-root #'operators
+;;                 assoc 'count {:type #(quote (-> [(list any)] number))
+;;                              :name 'count})
diff --git a/src/jester/match.clj b/src/jester/match.clj
new file mode 100644
index 0000000..5d18aec
--- /dev/null
+++ b/src/jester/match.clj
@@ -0,0 +1,142 @@
+(ns jester.match
+  "A simple pattern matcher, to avoid pulling in core.match. It is also
+  designed to specifically match against types, so it has some special
+  symbol handling."
+  (:require [clojure.walk :as walk]))
+
+(def ^:dynamic ^:private *seen-vars*)
+
+(defn ^:private special-type-symbol? [symbol]
+  (and (symbol? symbol)
+       (contains? #{"string" "number" "boolean" "any" "none" "_" "&"}
+                  (name symbol))))
+
+(defmacro ^:private ensuring-unique-vars
+  {:style/indent 0}
+  [& body]
+  `(binding [*seen-vars* {}]
+     (let [result# (do ~@body)
+           multiple-vars# (into #{}
+                                (comp (filter (fn [[_# v#]] (> v# 1)))
+                                      (map key))
+                                *seen-vars*)]
+       (when-not (empty? multiple-vars#)
+         (throw (ex-info "Variables are bound multiple times"
+                         {:names (mapv symbol multiple-vars#)})))
+       result#)))
+
+(declare pattern->condition)
+
+(defn seq-pattern->condition [pattern value]
+  (if-let [[pat-head & pat-tail] (seq pattern)]
+    (if (= pat-head '&)
+      (pattern->condition (first pat-tail) value)
+      (let [head-s (gensym "head")
+            tail-s (gensym "tail")]
+        `(let [[~head-s & ~tail-s] ~value]
+           (and ~(pattern->condition pat-head head-s)
+                ~(seq-pattern->condition pat-tail tail-s)))))
+    true))
+
+(defn ^:private pattern->condition [pattern value]
+  (cond
+    (vector? pattern)
+    (let [value-s (gensym "value")]
+      `(let [~value-s ~value]
+         (and (vector? ~value-s)
+              ~@(->> pattern
+                     (take-while #(not= % '&))
+                     (map-indexed (fn [i p]
+                                    (pattern->condition p `(get ~value-s ~i))))
+                     doall)
+              ~@(when (seq (drop-while #(not= % '&) pattern))
+                  [(pattern->condition (second (drop-while #(not= % '&) pattern))
+                                       `(subvec ~value-s
+                                                ~(count
+                                                  (take-while #(not= % '&)
+                                                              pattern))))]))))
+    (seq? pattern)
+    (let [[head & tail] pattern]
+      (assert (symbol? head) (str "Head of a seq pattern must be a symbol, not " (pr-str head)))
+      (let [head-s (gensym "head")
+            tail-s (gensym "tail")]
+        `(let [v# ~value]
+           (when (seq? v#)
+             (let [[~head-s & ~tail-s] v#]
+               (and (symbol? ~head-s)
+                    (= ~(name head) (name ~head-s))
+                    ~(seq-pattern->condition tail tail-s)))))))
+    (special-type-symbol? pattern)
+    (if (= (name pattern) "_")
+      true
+      `(let [v# ~value]
+         (and (symbol? v#)
+              (= ~(name pattern) (name v#)))))
+    (symbol? pattern)
+    (do (when-not (= (name pattern) "_")
+          (set! *seen-vars* (update *seen-vars* (name pattern) (fnil inc 0))))
+        true)
+    :else
+    `(= ~pattern ~value)))
+
+(defn ^:private pattern->destructuring-form [pattern]
+  (cond
+    (vector? pattern) (into [] (map pattern->destructuring-form) pattern)
+    (seq? pattern)    (into ['_] (map pattern->destructuring-form) (rest pattern))
+    (symbol? pattern) (if (= pattern '&)
+                        '&
+                        (if (special-type-symbol? pattern)
+                          '_
+                          pattern))
+    :else             '_))
+
+(defmacro type-match-let
+  {:style/indent 1}
+  [[pattern value] & body]
+  (ensuring-unique-vars
+    (let [value-s       (gensym "value")]
+      `(let [~value-s ~value]
+                           (if ~(pattern->condition pattern value-s)
+                             (let [~(pattern->destructuring-form pattern) ~value-s]
+                               ~@body)
+                             (throw (ex-info "Value did not match pattern"
+                                             {:pattern '~pattern
+                                              :value   ~value-s})))))))
+
+(defmacro type-match
+  {:style/indent 1}
+  [value & clauses]
+  (let [value-s (gensym "value")]
+    `(let [~value-s ~value]
+       (cond
+         ~@(mapcat (fn [[pattern result]]
+                     (ensuring-unique-vars
+                       [(pattern->condition pattern value-s)
+                        `(let [~(pattern->destructuring-form pattern)
+                               ~value-s]
+                           ~result)]))
+                   (partition 2 clauses))
+         :else
+         (throw (ex-info "Value did not match any pattern"
+                         {:patterns '~(mapv first (partition 2 clauses))
+                          :value    ~value-s}))))))
+
+(defmacro defn-type-match [fn-name & clauses]
+  (let [[doc clauses]    (if (and (string? (first clauses))
+                                  (odd? (count clauses)))
+                           [(first clauses) (rest clauses)]
+                           [nil clauses])
+        patterns         (map first (partition 2 clauses))
+        all-symbols?     (fn [pattern]
+                           (every? (fn [s]
+                                     (and (symbol? s) (not (special-type-symbol? s))))
+                                   pattern))
+        argument-symbols (or (seq (first (filter all-symbols? patterns)))
+                             (map #(do % (gensym "arg")) (first patterns)))]
+    (assert (every? vector? patterns) "All patterns in a defn-type-match must be a vector")
+    (assert (apply = (map count patterns)) "All patterns in a defn-type-match must have the same number of items")
+    `(defn ~fn-name
+       ~@(when doc [doc])
+       [~@argument-symbols]
+       (type-match [~@argument-symbols]
+         ~@clauses))))
diff --git a/src/jester/types.clj b/src/jester/types.clj
new file mode 100644
index 0000000..9451ea5
--- /dev/null
+++ b/src/jester/types.clj
@@ -0,0 +1,633 @@
+(ns jester.types
+  (:require [clojure.string :as str]
+            [jester.comparisons :refer [string= number= boolean=]]
+            [jester.match :refer [type-match-let type-match defn-type-match]]))
+
+;; Valid jester types are:
+;;
+;; These types are all "atomic":
+;; - any (supertype of all types)
+;; - none (subtype of all types)
+;; - number, string, boolean
+;; - (enum "a" ...), subtype of string
+;; - (enum 0 ...), subtype of number
+;; - (enum true ...), subtype of boolean
+
+;; These types are all "compound":
+;; - (optional α)
+;; - (list α), a list of values satisfying α
+;; - [α β], a tuple of α and β
+;; - [α β & γ], a tuple of α and β, and an additional sequence which matches γ
+;; - (map α β), a map of αs to βs
+;; - (-> [α β & γ] δ), a function taking an α, a β, and a sequence matching γ to δ
+;; - records, denoted by a map of property names to types
+
+;; Subtyping relationships are:
+;;
+;; - α                ≤ any
+;; - (enum "a" ...)   ≤ string
+;; - (enum 0 ...)     ≤ number
+;; - (enum true ...)  ≤ boolean
+;; - α                ≤ (optional α)
+;; - [α α]            ≤ (list α)
+;; - [α α & (list α)] ≤ (list α)
+;; - {l₁ α, l₂ β}     ≤ {l₁ α}
+;; ... and more!
+
+(defn ^:private split-rest [coll]
+  (let [[main rest] (split-with #(not= % '&) coll)]
+    (if (seq rest)
+      (do (assert (= (count rest) 2) "Tail must consist of only one element")
+          [main (second rest)])
+      [main nil])))
+
+(defn ^:private assert-type*
+  [object type path root-object root-type]
+  (letfn [(type-error [message & format-args]
+            (throw (ex-info (apply format message format-args)
+                            {:object object, :root-object root-object
+                             :type   type,   :root-type   root-type
+                             :path   path})))]
+    (type-match type
+      any  true
+      none (type-error "No value can satisfy none, but got %s" (pr-str object))
+
+      string  (when-not (string? object)
+                (type-error "Expected a string, but got %s" (pr-str object)))
+      number  (when-not (number? object)
+                (type-error "Expected a number, but got %s" (pr-str object)))
+      boolean (when-not (boolean? object)
+                (type-error "Expected a boolean, but got %s" (pr-str object)))
+
+      (enum & values)
+      (when-not (some #(cond
+                         (string? %)  (and (string? object) (string= % object))
+                         (number? %)  (and (number? object) (number= % object))
+                         (boolean? %) (and (boolean? object) (boolean= % object))
+                         :else        (assert false "Invalid enum value"))
+                      values)
+        (if (empty? values)
+          (type-error "Empty enumeration type cannot have a value, but got %s"
+                      (pr-str object))
+          (type-error "Expected %s, but got %s"
+                      (cond
+                        (= (count values) 1) (pr-str (first values))
+                        (= (count values) 2) (str (pr-str (first values)) " or " (pr-str (second values)))
+                        :else                (str (str/join ", " (map pr-str (butlast values))) ", or " (pr-str (last values))))
+                      (pr-str object))))
+
+      (optional t)
+      (when-not (nil? object)
+        (assert-type* object t path root-object root-type))
+
+      [& types]
+      (if (sequential? object)
+        (let [[main rest] (split-rest types)]
+          (if (< (count object) (count main))
+            (type-error "Expected at least %s item%s, but got %s" (count main) (if (> (count main) 1) "s" "") (count object))
+            (do (reduce (fn [index [item-type item]]
+                          (assert-type* item item-type (conj path index) root-object root-type)
+                          (inc index))
+                        0 (map vector main object))
+                (if rest
+                  (assert-type* (drop (count main) object) rest (conj path (list 'drop (count main))) root-object root-type)
+                  (when-not (= (count object) (count main))
+                    (type-error "Expected at most %s item%s, but got %s" (count main) (if (> (count main) 1) "s" "") (count object)))))))
+        (type-error "Expected a sequential object, but got %s" (pr-str object)))
+
+      (list item-type)
+      (if (sequential? object)
+        (reduce (fn [index item]
+                  (assert-type* item item-type (conj path index) root-object root-type)
+                  (inc index))
+                0 object)
+        (type-error "Expected a sequential object, but got %s" (pr-str object)))
+
+      (map k v)
+      (if (map? object)
+        (reduce-kv (fn [_ key value]
+                     (assert-type* key k type root-object root-type)
+                     (assert-type* value v (conj path key) root-object root-type))
+                   nil object)
+        (type-error "Expected a map, but got %s" (pr-str object)))
+
+      (-> args result)
+      (type-error "Cannot verify function type of %s for %s" (pr-str type) (pr-str object))
+
+      _
+      (if (map? type)
+        (if (map? object)
+          (reduce-kv (fn [_ key key-type]
+                       (assert-type* (get object key) key-type (conj path key) root-object root-type))
+                     nil type)
+          (type-error "Expected an object (map), but got %s" (pr-str object)))
+        (type-error "Invalid type: %s" (pr-str type))))))
+
+(defn assert-type
+  "Assert that `object` is of type `type`. Throws an exception with
+  failure details if this is not the case. Returns nil otherwise."
+  [object type]
+  (assert-type* object type [] object type)
+  nil)
+
+(defn-type-match subtype?
+  "Returns true if every object of type `sub` also satisfies the type
+  `super`. Returns false otherwise."
+
+  [_ any]  true
+  [none _] true
+
+  [(enum & values) string]  (every? string? values)
+  [(enum & values) number]  (every? number? values)
+  [(enum & values) boolean] (every? boolean? values)
+
+  [(enum & sub-values) (enum & super-values)]
+  (every? (fn [sub-value]
+            (cond (string? sub-value)  (some #(and (string? %) (string= sub-value %))
+                                             super-values)
+                  (number? sub-value)  (some #(and (number? %) (number= sub-value %))
+                                             super-values)
+                  (boolean? sub-value) (some #(and (boolean? %) (boolean= sub-value %))
+                                             super-values)
+                  :else                (assert false "We should not reach here.")))
+          sub-values)
+
+  [(optional subtype) (optional supertype)]
+  (subtype? subtype supertype)
+
+  [subtype (optional supertype)]
+  (subtype? subtype supertype)
+
+  ;; This is unfortunately quite complicated. :(
+  [[& subtypes] [& supertypes]]
+  (let [[sub-main sub-rest]     (split-rest subtypes)
+        [super-main super-rest] (split-rest supertypes)]
+    (and
+     ;; The subtype must guarantree at least as many elements as the
+     ;; supertype.
+     (>= (count sub-main) (count super-main))
+     ;; Any compulsory types from both arrays are subtypes
+     (every? true? (map subtype? sub-main super-main))
+     (or
+      ;; If there are no excess compulsory subtypes then we're good.
+      (= (count sub-main) (count super-main))
+      ;; Otherwise, we need to check them against the super-rest.
+      (if super-rest
+        (subtype? (->> sub-main
+                       (drop (count super-main))
+                       vec)
+                  super-rest)
+        ;; If there's no super-rest, then we just have excess types,
+        ;; which means there's no subtype relationship here.
+        false))
+     ;; If the subtype has a rest, then the supertype does too and
+     ;; they have an appropriate subtyping relationship
+     (if sub-rest
+       (and super-rest
+            (subtype? sub-rest super-rest))
+       true)))
+
+  [[& subtypes] (list supertype)]
+  (let [[sub-main sub-rest] (split-rest subtypes)]
+    (and (every? #(subtype? % supertype) sub-main)
+         (if sub-rest
+           (subtype? sub-rest `(list ~supertype))
+           true)))
+
+  [(list subtype) (list supertype)]
+  (subtype? subtype supertype)
+
+  [(map sub-key sub-val) (map super-key super-val)]
+  (and (subtype? super-key sub-key)
+       (subtype? sub-val super-val))
+
+  [(-> sub-args sub-result) (-> super-args super-result)]
+  (and (subtype? super-args sub-args)
+       (subtype? sub-result super-result))
+
+  [subtype supertype]
+  (cond
+    (and (map? subtype) (map? supertype))
+    (reduce-kv (fn [_ prop prop-type]
+                 (or (subtype? (get subtype prop) prop-type)
+                     (reduced false)))
+               nil supertype)
+
+    (and (symbol? subtype) (symbol? supertype))
+    (= (name subtype) (name supertype))
+
+    :else
+    false))
+
+(def ^:private ^:dynamic *upper-bounds*)
+(def ^:private ^:dynamic *lower-bounds*)
+
+(defn call-in-constraint-environment [thunk]
+  (binding [*upper-bounds* {}
+            *lower-bounds* {}]
+    (thunk)))
+
+(defmacro in-constraint-environment
+  {:style/indent 0}
+  [& body]
+  `(call-in-constraint-environment #(do ~@body)))
+
+(defn-type-match constrain
+  "Add a constraint that `sub` is a subtype of `super` within the
+  current constraint environment (see `in-constraint-environment`).
+  The return value of this function is meaningless, and it will throw
+  an exception if the provided constraint leads to a contradiction."
+
+  ;; No point doing anything for the constraints that aren't really constraints.
+  [_ any]  nil
+  [none _] nil
+
+  [subtype (var n)]
+  (when-not (contains? (get *lower-bounds* n) subtype)
+    (set! *lower-bounds* (update *lower-bounds* n (fnil conj #{}) subtype))
+    (doseq [upper (get *upper-bounds* n)]
+      (constrain subtype upper))
+    ;; The type hierarchy splits for all of the "atomic" types, so if
+    ;; we're constrained to be a supertype of one of the divisions
+    ;; then add a constraint on the top as well. While there is still
+    ;; the `any` type at the top of the hierachy, we only want it to
+    ;; show up for truly unconstrained types. This makes things like
+    ;; (? a 10) infer `a` to be (optional number) rather than the less
+    ;; accurate/helpful (optional any).
+    (type-match subtype
+      string          (constrain `(var ~n) `(optional string))
+      number          (constrain `(var ~n) `(optional number))
+      boolean         (constrain `(var ~n) `(optional boolean))
+      (enum & values) (do (when (some string? values)
+                            (constrain `(var ~n) `(optional string)))
+                          (when (some number? values)
+                            (constrain `(var ~n) `(optional number)))
+                          (when (some boolean? values)
+                            (constrain `(var ~n) `(optional boolean))))
+      _               nil))
+
+  [(var n) supertype]
+  (when-not (contains? (get *upper-bounds* n) supertype)
+    (set! *upper-bounds* (update *upper-bounds* n (fnil conj #{}) supertype))
+    (doseq [lower (get *lower-bounds* n)]
+      (constrain lower supertype))
+    ;; If we're a subtype of an optional type then add an artificial
+    ;; "unoptional" constraint to track the constraint against the
+    ;; wrapped type variable.
+    (type-match supertype
+      (optional x) (constrain `(unoptional (var ~n))
+                              x)
+      _            nil))
+
+  [subtype (optional super)]
+  (constrain (loop [subtype subtype]
+               (type-match subtype
+                 (optional sub) (recur sub)
+                 _              subtype))
+             super)
+
+  [(unoptional _) _]
+  nil ;; This is a weird extra constraint we add to propagate the
+      ;; restrictions imposed by having an optional on the RHS. It
+      ;; doesn't impose any other constraint, so just ingore it.
+
+  [[& subtypes] [& supertypes]]
+  (let [[sub-main sub-rest]     (split-rest subtypes)
+        [super-main super-rest] (split-rest supertypes)]
+    (when (< (count sub-main) (count super-main))
+      (throw (ex-info "Constraint error: cannot solve type relation"
+                      {:subtype   (vec subtypes)
+                       :supertype (vec supertypes)})))
+    (doall (map constrain sub-main super-main))
+    (when-not (= (count sub-main) (count super-main))
+      (if super-rest
+        (constrain (->> sub-main
+                        (drop (count super-main))
+                        vec)
+                   super-rest)
+        (throw (ex-info "Constraint error: cannot solve type relation"
+                        {:subtype   (vec subtypes)
+                         :supertype (vec supertypes)}))))
+    (when sub-rest
+      (if super-rest
+        (constrain sub-rest super-rest)
+        (throw (ex-info "Constraint error: cannot solve type relation"
+                        {:subtype   (vec subtypes)
+                         :supertype (vec supertypes)})))))
+
+  [[& subtypes] (list supertype)]
+  (let [[sub-main sub-rest] (split-rest subtypes)]
+    (doall (map #(constrain % supertype) sub-main))
+    (when sub-rest
+      (constrain sub-rest `(list ~supertype))))
+
+  [(list sub) (list super)]
+  (constrain sub super)
+
+  [(map subk subv) (map superk superv)]
+  (do (constrain superk subk)
+      (constrain subv superv))
+
+  [(-> sub-args sub-result) (-> super-args super-result)]
+  (do (constrain super-args sub-args)
+      (constrain sub-result super-result))
+
+  [subtype supertype]
+  (cond
+    (and (map? subtype) (map? supertype))
+    (doseq [[property super-value] supertype
+            :let                   [sub-value (get subtype property)]]
+      (if (nil? sub-value)
+        (throw (ex-info "Object type does not meet subtype constraint"
+                        {:subtype   subtype
+                         :supertype supertype}))
+        (constrain sub-value super-value)))
+
+    (not (subtype? subtype supertype))
+    (throw (ex-info "Constraint error: cannot solve type relation"
+                    {:subtype   subtype
+                     :supertype supertype}))))
+
+;; ;; This helper just prints out all the constraints that get added.
+;; (def constrain (let [c constrain]
+;;                  (fn [a b]
+;;                    (prn a '≤ b)
+;;                    (c a b))))
+
+(declare union-types)
+
+(defn-type-match ^:private intersect-types
+  "Return a type that is a subtype of both `t1` and `t2`. The
+  resulting type should be the greatest such type (that is, for all x
+  that are subtypes of both t1 and t2, x is a subtype of, or equal
+  to, (intersect-types t1 t2))."
+
+  [any t]  t
+  [t any]  t
+  [none _] 'none
+  [_ none] 'none
+
+  [(enum & t1values) (enum & t2values)]
+  (if-let [common-values (seq (filter (fn [t1value]
+                                        (cond (string? t1value)  (some #(and (string? %) (string= t1value %))
+                                                                       t2values)
+                                              (number? t1value)  (some #(and (number? %) (number= t1value %))
+                                                                       t2values)
+                                              (boolean? t1value) (some #(and (boolean? %) (boolean= t1value %))
+                                                                       t2values)
+                                              :else              (assert false "We should not reach here.")))
+                                      t1values))]
+    (cons 'enum common-values)
+    'none)
+
+  [(optional t1) (optional t2)]
+  (list 'optional (intersect-types t1 t2))
+
+  [(optional t1) t2]
+  (intersect-types t1 t2)
+  [t1 (optional t2)]
+  (intersect-types t1 t2)
+
+  [[& t1s] [& t2s]]
+  (let [[t1-main t1-rest] (split-rest t1s)
+        [t2-main t2-rest] (split-rest t2s)]
+    (cond
+      (empty? t1-main)
+      (intersect-types t1-rest t2s)
+      (empty? t2-main)
+      (intersect-types t1s t2-rest)
+      (= (count t1-main) (count t2-main))
+      (into (mapv intersect-types t1-main t2-main)
+            (when (and t1-rest t2-rest)
+              ['& (intersect-types t1-rest t2-rest)]))
+      (< (count t1-main) (count t2-main))
+      (if t1-rest
+        (into (mapv intersect-types t1-main t2-main)
+              (concat (intersect-types t1-rest
+                                       (->> t2-main
+                                            (drop (count t1-main))
+                                            vec))
+                      (when t2-rest
+                        ['& (intersect-types t1-rest t2-rest)])))
+        (throw (ex-info "No value can possible satisfy type"
+                        {:type (list 'intersect t1 t2)})))
+      (> (count t1-main) (count t2-main))
+      (if t2-rest
+        (into (mapv intersect-types t1-main t2-main)
+              (concat (intersect-types (->> t1-main
+                                            (drop (count t2-main))
+                                            vec)
+                                       t2-rest)
+                      (when t1-rest
+                        ['& (intersect-types t1-rest t2-rest)])))
+        (throw (ex-info "No value can possible satisfy type"
+                        {:type (list 'intersect t1 t2)})))
+      :else
+      (throw (ex-info "No value can possible satisfy type"
+                      {:type (list 'intersect t1 t2)}))))
+
+  [[& t1s] (list t2)]
+  (mapv #(intersect-types % t2) t1s)
+
+  [(list t1) [& t2s]]
+  (mapv #(intersect-types t1 %) t2s)
+
+  [(list t1) (list t2)]
+  (list 'list (intersect-types t1 t2))
+
+  [(map t1k t1v) (map t2k t2v)]
+  (list 'map
+        (union-types t1k t2k)
+        (intersect-types t1v t2v))
+
+  [(-> t1k t1v) (-> t2k t2v)]
+  (list '->
+        (union-types t1k t2k)
+        (intersect-types t1v t2v))
+
+  [t1 t2]
+  (cond
+    (and (map? t1) (map? t2)) (merge-with intersect-types t1 t2)
+    (subtype? t1 t2)          t1
+    (subtype? t2 t1)          t2
+    :else                     (throw (ex-info "No value can possible satisfy type"
+                                              {:type (list 'intersect t1 t2)}))))
+
+(defn-type-match ^:private union-types
+  "Return a type that is a supertype of both `t1` and `t2`. The
+  resulting type should be the least such type (that is, for all x
+  that are supertypes of both t1 and t2, x is a supertype of, or equal
+  to, (union-types t1 t2))."
+
+  [any _]  'any
+  [_ any]  'any
+  [none t] t
+  [t none] t
+
+  [(enum & t1values) (enum & t2values)]
+  (cons 'enum
+        (concat (remove (fn [t1value]
+                          (cond (string? t1value)  (some #(and (string? %) (string= t1value %))
+                                                         t2values)
+                                (number? t1value)  (some #(and (number? %) (number= t1value %))
+                                                         t2values)
+                                (boolean? t1value) (some #(and (boolean? %) (boolean= t1value %))
+                                                         t2values)
+                                :else              (assert false "We should not reach here.")))
+                        t1values)
+                t2values))
+
+  [(optional t1) (optional t2)]
+  (list 'optional (union-types t1 t2))
+
+  [(optional t1) t2]
+  (list 'optional (union-types t1 t2))
+  [t1 (optional t2)]
+  (list 'optional (union-types t1 t2))
+
+  [[& t1s] [& t2s]]
+  (let [[t1-main t1-rest] (split-rest t1s)
+        [t2-main t2-rest] (split-rest t2s)]
+    (cond
+      (empty? t1-main)
+      (union-types t1-rest t2s)
+      (empty? t2-main)
+      (union-types t1s t2-rest)
+      (= (count t1-main) (count t2-main))
+      (into (mapv union-types t1-main t2-main)
+            (when (and t1-rest t2-rest)
+              ['& (union-types t1-rest t2-rest)]))
+      (< (count t1-main) (count t2-main))
+      (if t1-rest
+        (into (mapv union-types t1-main t2-main)
+              (concat (union-types t1-rest
+                                   (->> t2-main
+                                        (drop (count t1-main))
+                                        vec))
+                      (when t2-rest
+                        ['& (union-types t1-rest t2-rest)])))
+        (throw (ex-info "Cannot construct type union"
+                        {:type (list 'union t1 t2)})))
+      (> (count t1-main) (count t2-main))
+      (if t2-rest
+        (into (mapv union-types t1-main t2-main)
+              (concat (union-types (->> t1-main
+                                        (drop (count t2-main))
+                                        vec)
+                                   t2-rest)
+                      (when t1-rest
+                        ['& (union-types t1-rest t2-rest)])))
+        (throw (ex-info "Cannot construct type union"
+                        {:type (list 'union t1 t2)})))
+      :else
+      (throw (ex-info "Cannot construct type union"
+                        {:type (list 'union t1 t2)}))))
+
+  [[& t1s] (list t2)]
+  (let [[t1-main t1-rest] (split-rest t1s)]
+    (into (mapv #(union-types % t2) t1-main)
+          (if t1-rest
+            ['& (union-types t1-rest t2)]
+            ['& `(list ~t2)])))
+
+  [(list t1) [& t2s]]
+  (let [[t2-main t2-rest] (split-rest t2s)]
+    (into (mapv #(union-types t1 %) t2-main)
+          (if t2-rest
+            ['& (union-types t1 t2-rest)]
+            ['& `(list ~t1)])))
+
+  [(list t1) (list t2)]
+  (list 'list (union-types t1 t2))
+
+  [(map t1k t1v) (map t2k t2v)]
+  (list 'map
+        (intersect-types t1k t2k)
+        (union-types t1v t2v))
+
+  [(-> t1k t1v) (-> t2k t2v)]
+  (list '->
+        (intersect-types t1k t2k)
+        (union-types t1v t2v))
+
+  [t1 t2]
+  (cond
+    (subtype? t1 t2) t2
+    (subtype? t2 t1) t1
+    :else            (throw (ex-info "Cannot construct type union"
+                                     {:type (list 'union t1 t2)}))))
+
+(defn-type-match ground-type
+  "Attempt to eliminate type-variables from `type` by solving any
+  constraints that can be solved. If `position` is :argument then
+  variables will be solved for their least upper bound, if `position`
+  is :return
+  bound."
+
+  [(var n) position]
+  (do (when-not (or (= position :argument) (= position :return))
+        (throw (ex-info (str "Invalid position: " (pr-str position))
+                        {:position position})))
+      (if-let [type-bounds (->> (get (case position
+                                       :argument *upper-bounds*
+                                       :return   *lower-bounds*)
+                                     n)
+                                (map #(ground-type % position))
+                                seq)]
+        (reduce (case position
+                  :argument intersect-types
+                  :return   union-types)
+                type-bounds)
+        'any))
+
+  [(enum & values) _]
+  (cons 'enum values)
+
+  [(optional t) position]
+  (list 'optional
+        (type-match (ground-type t position)
+          (optional t2) t2
+          t2            t2))
+
+  [(unoptional t) position]
+  (type-match (ground-type t position)
+    (optional t2) t2
+    t2            t2)
+
+  [[& ts] position]
+  (let [[t-main t-rest] (split-rest ts)]
+    (into (mapv #(ground-type % position) t-main)
+          (when t-rest
+            ['& (ground-type t-rest position)])))
+
+  [(list t) position]
+  (list 'list (ground-type t position))
+
+  [(map k v) position]
+  (list 'map
+        (ground-type k (case position
+                         :argument :return
+                         :return   :argument))
+        (ground-type v position))
+
+  [(-> k v) position]
+  (list '->
+        (ground-type k (case position
+                         :argument :return
+                         :return   :argument))
+        (ground-type v position))
+
+  [type position]
+  (cond
+    (map? type)    (persistent!
+                    (reduce-kv (fn [acc prop prop-type]
+                                 (assoc! acc prop (ground-type prop-type position)))
+                               (transient {}) type))
+    (symbol? type) (symbol (name type))
+    :else          (throw (ex-info "Cannot ground invalid type" {:type type}))))
+
+(defn type-variable
+  "Create a new type variable, distinct from all existing type
+  variables."
+  []
+  (list 'var (gensym "type")))