aboutsummaryrefslogtreecommitdiff
path: root/src/lang
diff options
context:
space:
mode:
authorEduardo Julian2014-12-11 01:24:39 -0400
committerEduardo Julian2014-12-11 01:24:39 -0400
commit9e2f13474246faebc0ab3126208b99acd715ec3c (patch)
treee0552c37b1165aa3f881ea12aa7aa2f4c9465dbf /src/lang
parent58bfb46ba16fc1db07e501be6fcc0c940ec7a350 (diff)
+ Added an analysis phase.
+ Added a type-system.
Diffstat (limited to 'src/lang')
-rw-r--r--src/lang/analyser.clj191
-rw-r--r--src/lang/compiler.clj207
-rw-r--r--src/lang/type.clj81
-rw-r--r--src/lang/util.clj9
4 files changed, 393 insertions, 95 deletions
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
new file mode 100644
index 000000000..a7f6a7dd5
--- /dev/null
+++ b/src/lang/analyser.clj
@@ -0,0 +1,191 @@
+(ns lang.analyser
+ (:refer-clojure :exclude [resolve])
+ (:require [clojure.core.match :refer [match]]
+ (lang [util :as &util :refer [exec return* return fail fail*
+ repeat-m try-m try-all-m map-m
+ apply-m within]]
+ [parser :as &parser]
+ [type :as &type])))
+
+(declare analyse-form)
+
+;; [Util]
+(defn ^:private with-env [env monad]
+ (fn [state]
+ (let [=return (monad (update-in state [:env] merge env))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ [::&util/ok [(assoc ?state :env (:env state)) ?value]]
+
+ _
+ =return))))
+
+(def ^:private module-name
+ (fn [state]
+ [::&util/ok [state (:name state)]]))
+
+(defn ^:private resolve [ident]
+ (fn [state]
+ (if-let [=ident (get-in state [:env ident])]
+ [::&util/ok [state =ident]]
+ [::&util/failure (str "Unresolved identifier: " ident)])))
+
+(defn ^:private define [name desc]
+ (fn [state]
+ [::&util/ok [(assoc-in state [:defs (:name state) name] desc) nil]]))
+
+(defn ^:private annotated [form type]
+ {:form form
+ :type type})
+
+(defmacro ^:private defanalyser [name match return]
+ `(def ~name
+ (fn [{[token# & left#] :forms :as state#}]
+ (match token#
+ ~match
+ (~return (assoc state# :forms left#))
+ _#
+ (fail* (str "Unmatched token: " token#))))))
+
+(defn analyse-form* [form]
+ (fn [state]
+ (let [old-forms (:forms state)
+ =return (analyse-form (assoc state :forms (list form)))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ [::&util/ok [(assoc ?state :forms old-forms) ?value]]
+
+ _
+ =return))))
+
+(defanalyser analyse-boolean
+ [::&parser/boolean ?boolean]
+ (return (annotated [::literal ?boolean] [::&type/object "java.lang.Boolean" []])))
+
+(defanalyser analyse-string
+ [::&parser/string ?string]
+ (return (annotated [::literal ?string] [::&type/object "java.lang.String" []])))
+
+(defanalyser analyse-variant
+ [::&parser/tagged ?tag ?value]
+ (exec [=value (analyse-form* ?value)]
+ (return (annotated [::variant ?tag =value] [::&type/variant ?tag (:type =value)]))))
+
+(defanalyser analyse-ident
+ [::&parser/ident ?name]
+ (exec [=ident (resolve ?name)]
+ (return (annotated [::ident ?name] =ident))))
+
+(defanalyser analyse-ann-class
+ [::&parser/ann-class ?class ?members]
+ (return (annotated [::ann-class ?class ?members] ::&type/nothing)))
+
+(defanalyser analyse-static-access
+ [::&parser/static-access ?class ?member]
+ (return (annotated [::static-access ?class ?member] ::&type/nothing)))
+
+(defanalyser analyse-dynamic-access
+ [::&parser/dynamic-access ?object ?member]
+ (exec [=object (analyse-form* ?object)]
+ (match ?member
+ [::&parser/fn-call [::&parser/ident ?method] ?args]
+ (exec [=args (map-m analyse-form* ?args)]
+ (return (annotated [::dynamic-access =object [?method =args]] ::&type/nothing))))))
+
+(defanalyser analyse-fn-call
+ [::&parser/fn-call [::&parser/ident ?fn] ?args]
+ (exec [name module-name
+ =args (map-m analyse-form* ?args)]
+ (return (annotated [::call [name ?fn] =args] ::&type/nothing))))
+
+(defanalyser analyse-if
+ [::&parser/if ?test ?then ?else]
+ (exec [=test (analyse-form* ?test)
+ =then (analyse-form* ?then)
+ =else (analyse-form* ?else)]
+ (return (annotated [::if =test =then =else] ::&type/nothing))))
+
+(defanalyser analyse-defclass
+ [::&parser/defclass ?name ?fields]
+ (let [=members {:fields (into {} (for [[class field] ?fields]
+ [field {:access ::public
+ :type class}]))}
+ =class [::class ?name =members]]
+ (exec [name module-name]
+ (return (annotated [::defclass [name ?name] =members] ::&type/nothing)))))
+
+(defanalyser analyse-definterface
+ [::&parser/definterface ?name ?members]
+ (let [=members {:methods (into {} (for [[method [inputs output]] ?members]
+ [method {:access ::public
+ :type [inputs output]}]))}
+ =interface [::interface ?name =members]]
+ (exec [name module-name]
+ (return (annotated [::definterface [name ?name] =members] ::&type/nothing)))))
+
+(defanalyser analyse-def
+ [::&parser/def ?usage ?value]
+ (match ?usage
+ [::&parser/ident ?name]
+ (exec [=value (analyse-form* ?value)
+ _ (define ?name {:mode ::constant
+ :access ::public
+ :type =value})]
+ (return (annotated [::def ?name =value] ::&type/nothing)))
+
+ [::&parser/fn-call [::&parser/ident ?name] ?args]
+ (let [args (for [a ?args]
+ (match a
+ [::&parser/ident ?ident]
+ ?ident))]
+ (exec [[=function =args =return] (within :types (&type/fresh-function (count args)))
+ :let [_ (prn '[=function =args =return] [=function =args =return])]
+ :let [env (-> {}
+ (assoc ?name =function)
+ (into (map vector args =args)))
+ _ (prn 'env env)]
+ =value (with-env env
+ (analyse-form* ?value))
+ :let [_ (prn '=value =value)]
+ =function (within :types (exec [_ (&type/solve =return (:type =value))]
+ (&type/clean =function)))
+ :let [_ (prn '=function =function)]
+ _ (define ?name {:mode ::function
+ :access ::public
+ :type =function})]
+ (return (annotated [::def [?name args] =value] ::&type/nothing))))
+ ))
+
+(defanalyser analyse-module
+ [::&parser/module]
+ (exec [name module-name]
+ (return (annotated [::module name] ::&type/nothing))))
+
+(def ^:private analyse-form
+ (try-all-m [analyse-boolean
+ analyse-string
+ analyse-variant
+ analyse-ident
+ analyse-ann-class
+ analyse-static-access
+ analyse-dynamic-access
+ analyse-fn-call
+ analyse-if
+ analyse-defclass
+ analyse-definterface
+ analyse-def
+ analyse-module]))
+
+;; [Interface]
+(defn analyse [module-name tokens]
+ (match ((repeat-m analyse-form) {:name module-name,
+ :forms tokens
+ :env {}
+ :types &type/+init+})
+ [::&util/ok [?state ?forms]]
+ (if (empty? (:forms ?state))
+ ?forms
+ (assert false (str "Unconsumed input: " (pr-str (:forms ?state)))))
+
+ [::&util/failure ?message]
+ (assert false ?message)))
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index dbc088668..1976c48e9 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -2,7 +2,9 @@
(:refer-clojure :exclude [compile])
(:require [clojure.string :as string]
[clojure.core.match :refer [match]]
- [lang.parser :as &parser]
+ (lang [type :as &type]
+ [parser :as &parser]
+ [analyser :as &analyser])
:reload)
(:import (org.objectweb.asm Opcodes
Label
@@ -12,21 +14,18 @@
(declare compile-form)
;; [Utils/General]
+(def ^:private +variant-class+ "test2.Tagged")
+
(defmacro ^:private defcompiler [name match body]
`(defn ~name [~'*state*]
- (let [~'*name* (:name ~'*state*)
- ~'*writer* (:writer ~'*state*)
- ~'*form* (:form ~'*state*)]
- (match ~'*form*
+ (let [~'*writer* (:writer ~'*state*)]
+ (match (:form (:form ~'*state*))
~match
(do ~body
true)
_#
false))))
-(defn compile-form* [writer form]
- (compile-form {:writer writer, :form form}))
-
(defn ^:private unwrap-ident [ident]
(match ident
[::&parser/ident ?label]
@@ -40,78 +39,98 @@
(defn ^:private ->class [class]
(string/replace class #"\." "/"))
+(def ^:private ->package ->class)
+
(defn ^:private ->type-signature [class]
(case class
"Void" "V"
;; else
(str "L" (->class class) ";")))
+(defn ^:private ->java-sig [type]
+ (match type
+ [::&type/object ?name []]
+ (->type-signature ?name)
+
+ [::&type/variant ?tag ?value]
+ (->type-signature +variant-class+)))
+
;; [Utils/Compilers]
-(defcompiler ^:private compile-boolean
- [::&parser/boolean ?boolean]
- (if ?boolean
- (.visitLdcInsn *writer* (int 1))
- (.visitLdcInsn *writer* (int 0))))
+(defcompiler ^:private compile-literal
+ [::&analyser/literal ?literal]
+ (cond (string? ?literal)
+ (.visitLdcInsn *writer* ?literal)
+
+ (instance? java.lang.Boolean ?literal)
+ (if ?literal
+ ;; (.visitLdcInsn *writer* (int 1))
+ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "TRUE" (->type-signature "java.lang.Boolean"))
+ ;; (.visitLdcInsn *writer* (int 0))
+ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") "FALSE" (->type-signature "java.lang.Boolean")))
-(defcompiler ^:private compile-string
- [::&parser/string ?string]
- (.visitLdcInsn *writer* ?string))
+ :else
+ (assert false (str "[Unknown literal type] " ?literal " : " (class ?literal)))))
(defcompiler ^:private compile-ident
- [::&parser/ident ?name]
+ [::&analyser/ident ?name]
(doto *writer*
- (.visitVarInsn Opcodes/ALOAD (int 0)))
- ;; nil
- )
+ (.visitVarInsn Opcodes/ALOAD (int 0))))
-(defcompiler ^:private compile-fn-call
- [::&parser/fn-call [::&parser/ident ?fn] ?args]
+(defcompiler ^:private compile-call
+ [::&analyser/call [?owner-class ?fn] ?args]
(do (doseq [arg ?args]
(compile-form (assoc *state* :form arg)))
(doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC (->class *name*) ?fn "(Ljava/lang/Object;)Ljava/lang/Object;"))))
+ (.visitMethodInsn Opcodes/INVOKESTATIC (->class ?owner-class) ?fn "(Ljava/lang/Object;)Ljava/lang/Object;"))))
(defcompiler ^:private compile-static-access
- [::&parser/static-access ?class ?member]
+ [::&analyser/static-access ?class ?member]
(doto *writer*
(.visitFieldInsn Opcodes/GETSTATIC (->class ?class) ?member (->type-signature "java.io.PrintStream"))))
(defcompiler ^:private compile-dynamic-access
- [::&parser/dynamic-access ?object ?access]
- (let [=object (compile-form (assoc *state* :form ?object))
- method (match ?access
- [::&parser/fn-call [::&parser/ident ?method] ?args]
- (do (doseq [arg ?args]
- (compile-form (assoc *state* :form arg)))
- ?method))]
+ [::&analyser/dynamic-access ?object [?method ?args]]
+ (do (compile-form (assoc *state* :form ?object))
+ (doseq [arg ?args]
+ (compile-form (assoc *state* :form arg)))
(doto *writer*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") method "(Ljava/lang/Object;)V"))))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V"))))
(defcompiler ^:private compile-ann-class
- [::&parser/ann-class ?class ?members]
+ [::&analyser/ann-class ?class ?members]
nil)
(defcompiler ^:private compile-if
- [::&parser/if ?test ?then ?else]
+ [::&analyser/if ?test ?then ?else]
(let [else-label (new Label)
end-label (new Label)]
- (compile-form (assoc *state* :form ?test))
- (.visitJumpInsn *writer* Opcodes/IFEQ else-label)
- (compile-form (assoc *state* :form ?then))
+ (println "PRE")
+ (assert (compile-form (assoc *state* :form ?test)) "CAN't COMPILE TEST")
+ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Boolean") "booleanValue" "()Z")
+ (.visitJumpInsn Opcodes/IFEQ else-label))
+ (assert (compile-form (assoc *state* :form ?then)) "CAN't COMPILE THEN")
(doto *writer*
(.visitJumpInsn Opcodes/GOTO end-label)
(.visitLabel else-label))
- (compile-form (assoc *state* :form ?else))
+ (assert (compile-form (assoc *state* :form ?else)) "CAN't COMPILE ELSE")
(.visitLabel *writer* end-label)))
(defcompiler ^:private compile-def
- [::&parser/def ?form ?body]
+ [::&analyser/def ?form ?body]
(match ?form
- [::&parser/fn-call [::&parser/ident ?name] ?args]
+ (?name :guard string?)
+ (let [=type (:type ?body)
+ _ (prn '?body ?body)]
+ (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name (->java-sig =type) nil nil)
+ (.visitEnd)))
+
+ [?name ?args]
(if (= "main" ?name)
(let [=method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name "([Ljava/lang/String;)V" nil nil)
(.visitCode))]
- (compile-form (assoc *state* :writer =method :form ?body))
+ (prn 'FN/?body ?body)
+ (assert (compile-form (assoc *state* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
(doto =method
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
@@ -123,23 +142,21 @@
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))))
- [::&parser/ident ?name]
- (doto (.visitField *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name "Ljava/lang/Object;" nil nil)
- (.visitEnd))
))
(defcompiler ^:private compile-module
- [::&parser/module]
+ [::&analyser/module ?name]
(.visit *writer* Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- (->class *name*) nil "java/lang/Object" nil))
+ (->class ?name) nil "java/lang/Object" nil))
(defcompiler ^:private compile-defclass
- [::&parser/defclass ?name ?fields]
- (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ [::&analyser/defclass [?package ?name] ?members]
+ (let [parent-dir (->package ?package)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- (->class (str *name* "." ?name)) nil "java/lang/Object" nil))]
- (doseq [[class field] ?fields]
- (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature class) nil nil)
+ (str parent-dir "/" ?name) nil "java/lang/Object" nil))]
+ (doseq [[field props] (:fields ?members)]
+ (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
(.visitEnd)))
(doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
(.visitCode)
@@ -149,46 +166,45 @@
(.visitMaxs 0 0)
(.visitEnd))
(.visitEnd =class)
- (let [parent-dir (->class *name*)]
- (.mkdirs (java.io.File. parent-dir))
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
- (.write stream (.toByteArray =class))))))
+ (.mkdirs (java.io.File. parent-dir))
+ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
+ (.write stream (.toByteArray =class)))))
(defcompiler ^:private compile-definterface
- [::&parser/definterface ?name ?members]
- (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ [::&analyser/definterface [?package ?name] ?members]
+ (let [parent-dir (->package ?package)
+ =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE)
- (->class (str *name* "." ?name)) nil "java/lang/Object" nil))]
- (doseq [[?method [?args ?return]] ?members
- :let [signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
+ (str parent-dir "/" ?name) nil "java/lang/Object" nil))]
+ (doseq [[?method ?props] (:methods ?members)
+ :let [[?args ?return] (:type ?props)
+ signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
(.visitMethod =interface (+ Opcodes/ACC_PUBLIC) ?method signature nil nil))
(.visitEnd =interface)
- (let [parent-dir (->class *name*)]
- (.mkdirs (java.io.File. parent-dir))
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
- (.write stream (.toByteArray =interface))))))
-
-(let [+tagged+ "test2/Tagged"]
- (defcompiler ^:private compile-tagged
- [::&parser/tagged ?tag ?value]
- (do (prn 'compile-tagged ?tag ?value)
- (doto *writer*
- (.visitTypeInsn Opcodes/NEW +tagged+)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL +tagged+ "<init>" "()V")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?tag)
- (.visitFieldInsn Opcodes/PUTFIELD +tagged+ "tag" "Ljava/lang/String;")
- (.visitInsn Opcodes/DUP))
- (compile-form (assoc *state* :form ?value))
- (doto *writer*
- (.visitFieldInsn Opcodes/PUTFIELD +tagged+ "value" "Ljava/lang/Object;"))
- )))
-
-(let [+compilers+ [compile-boolean
- compile-string
+ (.mkdirs (java.io.File. parent-dir))
+ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
+ (.write stream (.toByteArray =interface)))))
+
+(defcompiler ^:private compile-variant
+ [::&analyser/variant ?tag ?value]
+ (let [variant-class* (->class +variant-class+)]
+ (prn 'compile-variant ?tag ?value)
+ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW variant-class*)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?tag)
+ (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" "Ljava/lang/String;")
+ (.visitInsn Opcodes/DUP))
+ (assert (compile-form (assoc *state* :form ?value)) (pr-str "Can't compile value: " ?value))
+ (doto *writer*
+ (.visitFieldInsn Opcodes/PUTFIELD variant-class* "value" "Ljava/lang/Object;"))
+ ))
+
+(let [+compilers+ [compile-literal
compile-ident
- compile-fn-call
+ compile-call
compile-static-access
compile-dynamic-access
compile-ann-class
@@ -197,10 +213,11 @@
compile-module
compile-defclass
compile-definterface
- compile-tagged]]
+ compile-variant]]
(defn ^:private compile-form [state]
(prn 'compile-form/state state)
- (some #(% state) +compilers+)))
+ (or (some #(% state) +compilers+)
+ (assert false (str "Can't compile: " (pr-str (:form state)))))))
;; [Interface]
(defn compile [class-name inputs]
@@ -209,8 +226,7 @@
;; (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
;; (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
;; "output" nil "java/lang/Object" nil))
- state {:name class-name
- :writer =class
+ state {:writer =class
:form nil}]
;; (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
;; (.visitCode)
@@ -223,19 +239,22 @@
(when (not (compile-form (assoc state :form input)))
(assert false input)))
;; (doall (map #(compile-form (assoc state :form %)) inputs))
+ (prn 'inputs inputs)
(when-let [constants (seq (for [input inputs
- :let [payload (match input
- [::&parser/def [::&parser/ident ?name] ?body]
+ :let [payload (match (:form input)
+ [::&analyser/def (?name :guard string?) ?body]
[?name ?body]
_
nil)]
:when payload]
payload))]
(let [=init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (.visitCode))]
+ (.visitCode))
+ state* (assoc state :writer =init)
+ class-name* (->class class-name)]
(doseq [[?name ?body] constants]
- (do (compile-form (assoc state :writer =init :form ?body))
- (.visitFieldInsn =init Opcodes/PUTSTATIC (->class class-name) ?name "Ljava/lang/Object;")))
+ (do (assert (compile-form (assoc state* :form ?body)) (str "Couldn't compile init: " (pr-str ?body)))
+ (.visitFieldInsn =init Opcodes/PUTSTATIC class-name* ?name (->java-sig (:type ?body)))))
(doto =init
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
diff --git a/src/lang/type.clj b/src/lang/type.clj
index cab0ebeec..2f708867e 100644
--- a/src/lang/type.clj
+++ b/src/lang/type.clj
@@ -1,4 +1,83 @@
-(ns lang.type)
+(ns lang.type
+ (:refer-clojure :exclude [resolve])
+ (:require [clojure.core.match :refer [match]]
+ [lang.util :as &util :refer [exec return* return fail fail*
+ repeat-m try-m try-all-m map-m
+ apply-m]]))
+;; [Util]
+(def ^:private success (return nil))
+(defn ^:private resolve [id]
+ (fn [state]
+ (if-let [top+bottom (get-in state [::mappings id])]
+ [::&util/ok [state top+bottom]]
+ [::&util/failure (str "Unknown type-var: " id)])))
+(defn ^:private update [id top bottom]
+ (fn [state]
+ (if-let [top+bottom (get-in state [::mappings id])]
+ [::&util/ok [(assoc-in state [::mappings id] [top bottom]) nil]]
+ [::&util/failure (str "Unknown type-var: " id)])))
+
+;; [Interface]
+(def +init+ {::counter 0
+ ::mappings {}})
+
+(def fresh-var
+ (fn [state]
+ (let [id (::counter state)]
+ [::&util/ok [(-> state
+ (update-in [::counter] inc)
+ (assoc-in [::mappings id] [::any ::nothing]))
+ [::var id]]])))
+
+(defn fresh-function [num-args]
+ (exec [=args (map-m (constantly fresh-var) (range num-args))
+ =return fresh-var
+ :let [=function [::function =args =return]]]
+ (return [=function =args =return])))
+
+(defn solve [expected actual]
+ (match [expected actual]
+ [::any _]
+ success
+
+ [_ ::nothing]
+ success
+
+ [_ [::var ?id]]
+ (exec [[=top =bottom] (resolve ?id)]
+ (try-all-m [(exec [_ (solve expected =top)]
+ success)
+ (exec [_ (solve =top expected)
+ _ (solve expected =bottom)
+ _ (update ?id expected =bottom)]
+ success)]))
+
+ [[::var ?id] _]
+ (exec [[=top =bottom] (resolve ?id)]
+ (try-all-m [(exec [_ (solve =bottom actual)]
+ success)
+ (exec [_ (solve actual =bottom)
+ _ (solve =top actual)
+ _ (update ?id =top actual)]
+ success)]))
+
+ [_ _]
+ (fail (str "Can't solve types: " (pr-str expected actual)))
+ ))
+
+(defn clean [type]
+ (match type
+ [::var ?id]
+ (exec [[=top =bottom] (resolve ?id)]
+ (clean =top))
+
+ [::function ?args ?return]
+ (exec [=args (map-m clean ?args)
+ =return (clean ?return)]
+ (return [::function =args =return]))
+
+ _
+ (return type)))
diff --git a/src/lang/util.clj b/src/lang/util.clj
index d9745e9ab..ec93ac27f 100644
--- a/src/lang/util.clj
+++ b/src/lang/util.clj
@@ -112,3 +112,12 @@
(def get-state
(fn [state]
(return* state state)))
+
+(defn within [slot monad]
+ (fn [state]
+ (let [=return (monad (get state slot))]
+ (match =return
+ [::ok [?state ?value]]
+ [::ok [(assoc state slot ?state) ?value]]
+ _
+ =return))))