diff options
Diffstat (limited to 'luxc/src')
| -rw-r--r-- | luxc/src/lux/analyser.clj | 2 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/lux.clj | 54 | ||||
| -rw-r--r-- | luxc/src/lux/base.clj | 192 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/cache.clj | 2 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/core.clj | 4 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js.clj | 2 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/base.clj | 49 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/lux.clj | 3 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm.clj | 32 | ||||
| -rw-r--r-- | luxc/src/lux/type.clj | 89 |
10 files changed, 212 insertions, 217 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index e2aa64590..280085777 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -57,7 +57,7 @@ (return (&&/|meta =output-type ?output-cursor ?output-term)))) )))) -(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] +(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token] (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) [cursor token] ?token compile-def (aget compilers 0) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index af7f0f3f9..aee46a9cc 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -376,35 +376,33 @@ ))))) (defn analyse-apply [analyse cursor exo-type macro-caller =fn ?args] - (|do [loader &/loader - :let [[[=fn-type =fn-cursor] =fn-form] =fn]] - (|case =fn-form - (&&/$var (&/$Global ?module ?name)) - (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] - (|case (&&meta/meta-get &&meta/macro?-tag ?meta) - (&/$Some _) - (|do [macro-expansion (fn [state] - (|case (macro-caller ?value ?args state) - (&/$Right state* output) - (&/$Right (&/T [state* output])) - - (&/$Left error) - ((&/fail-with-loc error) state))) - ;; module-name &/get-module-name - ;; :let [[r-prefix r-name] real-name - ;; _ (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (|case =fn + [_ (&&/$var (&/$Global ?module ?name))] + (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] + (|case (&&meta/meta-get &&meta/macro?-tag ?meta) + (&/$Some _) + (|do [macro-expansion (fn [state] + (|case (macro-caller ?value ?args state) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) + ;; module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) - _ - (do-analyse-apply analyse exo-type =fn ?args))) - - _ - (do-analyse-apply analyse exo-type =fn ?args)) - )) + _ + (do-analyse-apply analyse exo-type =fn ?args))) + + _ + (do-analyse-apply analyse exo-type =fn ?args)) + ) (defn analyse-case [analyse exo-type ?value ?branches] (|do [:let [num-branches (&/|length ?branches)] diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index bbb5f3888..df4fb293f 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -137,6 +137,11 @@ ["compiler-version" "compiler-mode"]) +;; Hosts +(defvariant + ("Jvm" 1) + ("Js" 1)) + (deftuple ["info" "source" @@ -221,7 +226,6 @@ ;; [Exports] (def ^:const value-field "_value") -(def ^:const eval-field "_eval") (def ^:const module-class-name "_") (def ^:const +name-separator+ ";") @@ -659,6 +663,18 @@ (return* state unit-tag) (fail* msg))))) +(defn |some [f xs] + "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (|case (f x) + ($None) (|some f xs*) + output output) + )) + (defn ^:private normalize-char [char] (case char \* "_ASTER_" @@ -690,10 +706,6 @@ (defn normalize-name [ident] (reduce str "" (map normalize-char ident))) -(def classes - (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) - (def +init-bindings+ (T [;; "lux;counter" 0 @@ -711,9 +723,85 @@ +init-bindings+] )) -(def loader - (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) +(do-template [<tag> <host> <ask> <change> <with>] + (do (def <host> + (fn [compiler] + (|case (get$ $host compiler) + (<tag> host-data) + (return* compiler host-data) + + _ + (fail* "[Error] Wrong host.")))) + + (def <ask> + (fn [compiler] + (|case (get$ $host compiler) + (<tag> host-data) + (return* compiler true) + + _ + (return* compiler false)))) + + (defn <change> [slot updater] + (|do [host <host>] + (fn [compiler] + (return* (set$ $host (<tag> (update$ slot updater host)) compiler) + (get$ slot host))))) + + (defn <with> [slot updater body] + (|do [old-val (<change> slot updater) + ?output-val body + new-val (<change> slot (fn [_] old-val))] + (return ?output-val)))) + + $Jvm jvm-host jvm? change-jvm-host-slot with-jvm-host-slot + $Js js-host js? change-js-host-slot with-js-host-slot + ) + +(do-template [<name> <slot>] + (def <name> + (|do [host jvm-host] + (return (get$ <slot> host)))) + + loader $loader + classes $classes + get-type-env $type-env + ) + +(def get-writer + (|do [host jvm-host] + (|case (get$ $writer host) + ($Some writer) + (return writer) + + _ + (fail-with-loc "[Error] Writer hasn't been set.")))) + +(defn with-writer [writer body] + (with-jvm-host-slot $writer (fn [_] ($Some writer)) body)) + +(defn with-type-env [type-env body] + "(All [a] (-> TypeEnv (Lux a) (Lux a)))" + (with-jvm-host-slot $type-env (partial |++ type-env) body)) + +(defn push-dummy-name [real-name store-name] + (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name])))) + +(def pop-dummy-name + (change-jvm-host-slot $dummy-mappings |tail)) + +(defn de-alias-class [class-name] + (|do [host jvm-host] + (return (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (get$ $dummy-mappings host)) + ($Some store-name) + store-name + + _ + class-name)))) (defn with-no-catches [body] "(All [a] (-> (Lux a) (Lux a)))" @@ -800,16 +888,6 @@ (fn [state] (return* state (->> state (get$ $info) (get$ $compiler-mode))))) -(def get-writer - (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] - (|case writer* - ($Some datum) - (return* state datum) - - _ - ((fail-with-loc "[Error] Writer hasn't been set.") state))))) - (def get-top-local-env (fn [state] (try (let [top (|head (get$ $scopes state))] @@ -933,18 +1011,6 @@ _ output))))) -(defn with-writer [writer body] - (fn [state] - (let [old-writer (->> state (get$ $host) (get$ $writer)) - output (body (update$ $host #(set$ $writer ($Some writer) %) state))] - (|case output - ($Right ?state ?value) - (return* (update$ $host #(set$ $writer old-writer %) ?state) - ?value) - - _ - output)))) - (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] @@ -1333,40 +1399,6 @@ output output))) -(defn |some [f xs] - "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" - (|case xs - ($Nil) - $None - - ($Cons x xs*) - (|case (f x) - ($None) (|some f xs*) - output output) - )) - -(def get-type-env - "(Lux TypeEnv)" - (fn [state] - (return* state (->> state (get$ $host) (get$ $type-env))))) - -(defn with-type-env [type-env body] - "(All [a] (-> TypeEnv (Lux a) (Lux a)))" - (fn [state] - (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %) - state)] - (|case (body state*) - ($Right [state** output]) - ($Right (T [(update$ $host - #(set$ $type-env - (->> state (get$ $host) (get$ $type-env)) - %) - state**) - output])) - - ($Left msg) - ($Left msg))))) - (defn |take [n xs] (|case (T [n xs]) [0 _] $Nil @@ -1412,38 +1444,6 @@ ($Left msg) ($Left msg)))) -(defn push-dummy-name [real-name store-name] - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - (partial $Cons (T [real-name store-name])) - %) - state) - nil])))) - -(def pop-dummy-name - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - |tail - %) - state) - nil])))) - -(defn de-alias-class [class-name] - (fn [state] - ($Right (T [state - (|case (|some #(|let [[real-name store-name] %] - (if (= real-name class-name) - ($Some store-name) - $None)) - (->> state (get$ $host) (get$ $dummy-mappings))) - ($Some store-name) - store-name - - _ - class-name)])))) - (defn |eitherL [left right] (fn [compiler] (|case (run-state left compiler) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj index 77e4221e8..7299b7166 100644 --- a/luxc/src/lux/compiler/cache.clj +++ b/luxc/src/lux/compiler/cache.clj @@ -23,7 +23,7 @@ :when (not (.isDirectory f))] (.delete f))) -(defn ^:private module-path [module] +(defn ^:private ^String module-path [module] (str @&&core/!output-dir java.io.File/separator (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj index 6dacb4e54..15f03ea6e 100644 --- a/luxc/src/lux/compiler/core.clj +++ b/luxc/src/lux/compiler/core.clj @@ -4,9 +4,7 @@ [clojure.java.io :as io] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail*]] - [type :as &type] - [host :as &host]) + (lux [base :as & :refer [|let |do return* return fail*]]) (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler.cache [type :as &&&type] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 18b91f5bc..b43ab5b4d 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -137,7 +137,7 @@ (if module-exists? (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) (|do [_ (&&cache/delete name) - _ &&/init-buffer + _ (&&/init-buffer) _ (&a-module/create-module name file-hash) _ (&a-module/flag-active-module name) _ (if (= "lux" name) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 50ece15e6..329252798 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -24,49 +24,40 @@ "buffer"]) (defn js-host [] - (&/T [;; "interpreter" - (.getScriptEngine (new NashornScriptEngineFactory)) - ;; "buffer" - &/$None - ])) + (&/$Js (&/T [;; "interpreter" + (.getScriptEngine (new NashornScriptEngineFactory)) + ;; "buffer" + &/$None + ]))) (def ^String module-js-name "module.js") -(def init-buffer - (fn [compiler-state] - (&/$Right (&/T [(&/update$ &/$host - (fn [host] - (&/set$ $buffer - (&/$Some (new StringBuilder)) - host)) - compiler-state) - nil])))) +(defn init-buffer [] + (&/change-js-host-slot $buffer (fn [_] (&/$Some (new StringBuilder))))) (def get-buffer - (fn [compiler-state] - (|case (->> compiler-state (&/get$ &/$host) (&/get$ $buffer)) + (|do [host &/js-host] + (|case (&/get$ $buffer host) (&/$Some _buffer) - (&/$Right (&/T [compiler-state - _buffer])) + (return _buffer) (&/$None) - (&/$Left "[Error] No buffer available.")))) + (&/fail-with-loc "[Error] No buffer available.")))) (defn run-js! [^String js-code] - (fn [compiler-state] - (|let [^NashornScriptEngine interpreter (->> compiler-state (&/get$ &/$host) (&/get$ $interpreter))] - (try (&/$Right (&/T [compiler-state - (.eval interpreter js-code)])) - (catch Exception ex - (&/$Left (str ex))))))) + (|do [host &/js-host + :let [interpreter ^NashornScriptEngine (&/get$ $interpreter host)]] + (try (return (.eval interpreter js-code)) + (catch Exception ex + (&/fail-with-loc (str ex)))))) (def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) -(defn ^:private _slice_ [wrap-lux-obj value] +(defn ^:private _slice_ [wrap-lux-obj ^"[Ljava.lang.Object;" value] (reify JSObject (isFunction [self] true) (call [self this args] - (let [slice (java.util.Arrays/copyOfRange value (aget args 0) (alength value))] + (let [slice (java.util.Arrays/copyOfRange value ^int (aget args 0) ^int (alength value))] (wrap-lux-obj slice))))) (defn ^:private _toString_ [obj] @@ -102,7 +93,7 @@ ;; else (assert false (str "encode-char#getMember = " member)))))) -(deftype LuxJsObject [obj] +(deftype LuxJsObject [^"[Ljava.lang.Object;" obj] JSObject (isFunction [self] false) (getSlot [self idx] @@ -139,7 +130,7 @@ (.hasMember js-object "C")) (defn ^:private decode-char [^ScriptObjectMirror js-object] - (-> (.getMember js-object "C") + (-> ^String (.getMember js-object "C") (.charAt 0))) (defn ^:private parse-int64 [^ScriptObjectMirror js-object] diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 0f86d8a33..5103b2d2b 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -314,8 +314,7 @@ ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")")))) (defn compile-def [compile ?name ?body def-meta] - (|do [module-name &/get-module-name - class-loader &/loader] + (|do [module-name &/get-module-name] (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) (&/$Some (&/$IdentA [r-module r-name])) (if (= 1 (&/|length def-meta)) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index f09224c90..5cc3c1f79 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -140,7 +140,7 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) @@ -148,7 +148,7 @@ :let [_ (.visitCode *writer*)] _ (compile-expression nil expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -158,7 +158,7 @@ _ (&&/save-class! (str id) bytecode) loader &/loader] (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) - (.getField &/eval-field) + (.getField &/value-field) (.get nil) return)))) @@ -228,19 +228,19 @@ (defn jvm-host [] (let [store (atom {})] - (&/T [;; "lux;writer" - &/$None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; "lux;module-states" - (&/|table) - ;; lux;type-env - (&/|table) - ;; lux;dummy-mappings - (&/|table) - ]))) + (&/$Jvm (&/T [;; "lux;writer" + &/$None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; "lux;module-states" + (&/|table) + ;; lux;type-env + (&/|table) + ;; lux;dummy-mappings + (&/|table) + ])))) (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index d3805cabc..ad185e284 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -649,7 +649,7 @@ (def ^:private init-fixpoints &/$Nil) -(defn ^:private check* [class-loader fixpoints invariant?? expected actual] +(defn ^:private check* [fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) (return fixpoints) (&/with-attempt @@ -677,13 +677,13 @@ (return fixpoints)) [(&/$Some etype) (&/$None _)] - (check* class-loader fixpoints invariant?? etype actual) + (check* fixpoints invariant?? etype actual) [(&/$None _) (&/$Some atype)] - (check* class-loader fixpoints invariant?? expected atype) + (check* fixpoints invariant?? expected atype) [(&/$Some etype) (&/$Some atype)] - (check* class-loader fixpoints invariant?? etype atype)))) + (check* fixpoints invariant?? etype atype)))) [(&/$VarT ?id) _] (fn [state] @@ -693,7 +693,7 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? bound actual)) + (check* fixpoints invariant?? bound actual)) state))) [_ (&/$VarT ?id)] @@ -704,18 +704,18 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? expected bound)) + (check* fixpoints invariant?? expected bound)) state))) [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] (if (= eid aid) - (check* class-loader fixpoints invariant?? eA aA) + (check* fixpoints invariant?? eA aA) (check-error "" expected actual)) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) + (check* fixpoints invariant?? (&/$AppT F1 A1) actual)) state) (&/$Right state* output) (return* state* output) @@ -724,34 +724,34 @@ (|case F2 (&/$UnivQ (&/$Cons _) _) ((|do [actual* (apply-type F2 A2)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) state) (&/$ExT _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)] - (check* class-loader fixpoints* invariant?? A1 A2)) + ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)] + (check* fixpoints* invariant?? A1 A2)) state) _ - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) + ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) + (check* fixpoints* invariant?? e* a*)) state)))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) + (check* fixpoints invariant?? expected (&/$AppT F2 A2))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) + ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) + (check* fixpoints* invariant?? e* a*)) state))) [(&/$AppT F A) _] @@ -773,25 +773,25 @@ (&/$None) (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) + (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) [_ (&/$AppT (&/$ExT aid) A)] (check-error "" expected actual) [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] (|do [$arg existential expected* (apply-type expected $arg)] - (check* class-loader fixpoints invariant?? expected* actual)) + (check* fixpoints invariant?? expected* actual)) [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg) - =output (check* class-loader fixpoints invariant?? expected actual*) + =output (check* fixpoints invariant?? expected actual*) _ (clean $arg expected)] (return =output)))) @@ -799,24 +799,34 @@ (with-var (fn [$arg] (|do [expected* (apply-type expected $arg) - =output (check* class-loader fixpoints invariant?? expected* actual) + =output (check* fixpoints invariant?? expected* actual) _ (clean $arg actual)] (return =output)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential actual* (apply-type actual $arg)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) [(&/$HostT e!data) (&/$HostT a!data)] - (&&host/check-host-types (partial check* class-loader fixpoints true) - check-error - fixpoints - existential - class-loader - invariant?? - e!data - a!data) + (|do [? &/jvm?] + (if ? + (|do [class-loader &/loader] + (&&host/check-host-types (partial check* fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data)) + (|let [[e!name e!params] e!data + [a!name a!params] a!data] + (if (and (= e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)] + (return fixpoints)) + (check-error "" expected actual))))) [(&/$VoidT) (&/$VoidT)] (return fixpoints) @@ -825,16 +835,16 @@ (return fixpoints) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)] - (check* class-loader fixpoints* invariant?? eO aO)) + (|do [fixpoints* (check* fixpoints invariant?? aI eI)] + (check* fixpoints* invariant?? eO aO)) [(&/$ProdT eL eR) (&/$ProdT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) [(&/$SumT eL eR) (&/$SumT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) [(&/$ExT e!id) (&/$ExT a!id)] (if (= e!id a!id) @@ -842,10 +852,10 @@ (check-error "" expected actual)) [(&/$NamedT _ ?etype) _] - (check* class-loader fixpoints invariant?? ?etype actual) + (check* fixpoints invariant?? ?etype actual) [_ (&/$NamedT _ ?atype)] - (check* class-loader fixpoints invariant?? expected ?atype) + (check* fixpoints invariant?? expected ?atype) [_ _] (&/fail "")) @@ -853,8 +863,7 @@ (check-error err expected actual))))) (defn check [expected actual] - (|do [class-loader &/loader - _ (check* class-loader init-fixpoints false expected actual)] + (|do [_ (check* init-fixpoints false expected actual)] (return nil))) (defn actual-type [type] |