From f52eb6df2e57f67e7cf30d85c6340ce00f923d6f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 20:07:08 -0400 Subject: - Corrected the indentation issues in the lux files. - Temporarily reverted back to forward apply-analysis. - Fixed an error in lux.base/show-ast. - Reader now only returns a tuple instead of a full-blown #Meta variant. - Reader now doesn't cut the strings that it reads. Instead, the "cursor" just moves around, indicating where to read. - Inlined some calculations that previously relied on try-all%. --- src/lux.clj | 5 +- src/lux/analyser.clj | 1 + src/lux/analyser/lux.clj | 86 ++++++++++++++++--------------- src/lux/base.clj | 20 ++++---- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 9 ++-- src/lux/lexer.clj | 56 ++++++++++----------- src/lux/reader.clj | 75 +++++++++++++++------------ src/lux/type.clj | 128 +++++++++++++++++++++++++++++++++-------------- 9 files changed, 227 insertions(+), 157 deletions(-) (limited to 'src') diff --git a/src/lux.clj b/src/lux.clj index 5b32955a3..eb025f55e 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -2,10 +2,13 @@ (:gen-class) (:require [lux.base :as &] [lux.compiler :as &compiler] + [lux.type :as &type] :reload-all)) (defn -main [& _] - (time (&compiler/compile-all (&/|list "program"))) + (do (time (&compiler/compile-all (&/|list "program"))) + ;; (prn @&type/counter) + ) (System/exit 0)) (comment diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index c37c1acde..3c5c5c956 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -454,6 +454,7 @@ (fail ""))) (defn ^:private analyse-basic-ast [analyse eval! exo-type token] + ;; (prn 'analyse-basic-ast (&/show-ast token)) (fn [state] (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 1b0c70f77..7600f34ff 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -151,7 +151,7 @@ [_] (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) - (fail* "")) + (fail* "_{_ analyse-symbol _}_")) [["lux;Cons" [top-outer _]]] (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) @@ -172,39 +172,42 @@ ))) )) -(defn ^:private analyse-apply* [analyse exo-type fun-type args] - (matchv ::M/objects [args] - [["lux;Nil" _]] - (|do [_ (&type/check exo-type fun-type)] - (return (&/T (&/|list) fun-type))) - - [["lux;Cons" [?arg ?args*]]] - (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - [?args** ?type**] (analyse-apply* analyse exo-type type* args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] - (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type*** (&type/clean $var ?type**)] - (return (&/T ?args** type***))) - )))) - - [["lux;LambdaT" [?input-t ?output-t]]] - (|do [[=args ?output-t*] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T (&/|cons =arg =args) ?output-t*))) +(defn ^:private analyse-apply* [analyse exo-type =fn ?args] + (matchv ::M/objects [=fn] + [[?fun-expr ?fun-type]] + (matchv ::M/objects [?args] + [["lux;Nil" _]] + (|do [_ (&type/check exo-type ?fun-type)] + (return =fn)) + + [["lux;Cons" [?arg ?args*]]] + (|do [?fun-type* (&type/actual-type ?fun-type)] + (matchv ::M/objects [?fun-type*] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] + (matchv ::M/objects [output $var] + [[?expr* ?type*] ["lux;VarT" ?id]] + (|do [? (&type/bound? ?id) + _ (if ? + (return nil) + (|do [ex &type/existential] + (&type/set-var ?id ex))) + type** (&type/clean $var ?type*)] + (return (&/T ?expr* type**))) + )))) + + [["lux;LambdaT" [?input-t ?output-t]]] + (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] + (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) + ?output-t) + ?args*)) - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) - )) + [_] + (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) + ))) (defn analyse-apply [analyse exo-type =fn ?args] (|do [loader &/loader] @@ -219,14 +222,12 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] - (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =app-type)))))) + (|do [output (analyse-apply* analyse exo-type =fn ?args)] + (return (&/|list output))))) [_] - (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =app-type))))) + (|do [output (analyse-apply* analyse exo-type =fn ?args)] + (return (&/|list output)))) ))) (defn analyse-case [analyse exo-type ?value ?branches] @@ -263,7 +264,12 @@ (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id)] - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))) + (matchv ::M/objects [dtype] + [["lux;ExT" _]] + (return (&/T _expr exo-type)) + + [_] + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) [_] diff --git a/src/lux/base.clj b/src/lux/base.clj index 9ea255132..edf6781ea 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -551,40 +551,40 @@ (defn show-ast [ast] (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;Bool" ?value]]]] + [["lux;Meta" [_ ["lux;BoolS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Int" ?value]]]] + [["lux;Meta" [_ ["lux;IntS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Real" ?value]]]] + [["lux;Meta" [_ ["lux;RealS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Char" ?value]]]] + [["lux;Meta" [_ ["lux;CharS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Text" ?value]]]] + [["lux;Meta" [_ ["lux;TextS" ?value]]]] (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;Tag" [?module ?tag]]]]] + [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;Symbol" [?module ?ident]]]]] + [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] (if (= "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;Tuple" ?elems]]]] + [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;Record" ?elems]]]] + [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;Form" ?elems]]]] + [["lux;Meta" [_ ["lux;FormS" ?elems]]]] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 26b75bec3..6fb9e2c6d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -60,8 +60,8 @@ [["lux;Global" [?owner-class ?name]]] (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?args]]] - (&&lux/compile-apply compile-expression ?type ?fn ?args) + [["apply" [?fn ?arg]]] + (&&lux/compile-apply compile-expression ?type ?fn ?arg) [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 2c5073a4d..cf4a65f04 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -117,14 +117,11 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?args] +(defn compile-apply [compile *type* ?fn ?arg] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) - _ (&/map% (fn [?arg] - (|do [_ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] - (return nil))) - ?args)] + _ (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] (return nil))) (defn compile-def [compile ?name ?body ?def-data] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 2ee8088d3..d2ab4a5d7 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -18,11 +18,11 @@ (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_] - (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") + (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") unescaped (escape-char escaped) postfix (lex-text-body nil)] (return (str prefix unescaped postfix))) - (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] + (|do [[_ body] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)" @@ -31,26 +31,26 @@ ;; [Lexers] (def ^:private lex-white-space - (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")] + (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") - [_ [meta comment]] (&reader/read-regex #"^(.*)$")] + [meta comment] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] (return (&/T meta comment))) (|do [;; :let [_ (prn 'pre/_0)] - [_ [meta pre]] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") + [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] - [_ [_ [_ inner]]] (lex-multi-line-comment nil) + [_ inner] (lex-multi-line-comment nil) ;; :let [_ (prn 'inner inner)] - [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))") + [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] (return (&/T meta (str pre "#(" inner ")#" post)))))) @@ -64,7 +64,7 @@ (do-template [ ] (def - (|do [[_ [meta token]] (&reader/read-regex )] + (|do [[meta token] (&reader/read-regex )] (return (&/V "lux;Meta" (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" @@ -73,54 +73,54 @@ ) (def ^:private lex-char - (|do [[_ [meta _]] (&reader/read-text "#\"") - token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")] + (|do [[meta _] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [[_ escaped] (&reader/read-regex #"^(\\.)")] (escape-char escaped)) - (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] + (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) (def ^:private lex-text - (|do [[_ [meta _]] (&reader/read-text "\"") + (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident - (&/try-all% (&/|list (|do [[_ [meta token]] (&reader/read-regex +ident-re+)] + (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ [_ local-token]] (&reader/read-regex +ident-re+)] + [_ local-token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token))))) + (return (&/T meta (&/T unaliased local-token)))) (|do [? (&module/exists? token)] (if ? - (return (&/V "lux;Meta" (&/T meta (&/T token local-token)))) + (return (&/T meta (&/T token local-token))) (fail (str "[Lexer Error] Unknown module: " token)))) ))) - (return (&/V "lux;Meta" (&/T meta (&/T "" token)))) + (return (&/T meta (&/T "" token))) ))) - (|do [[_ [meta _]] (&reader/read-text ";;") - [_ [_ token]] (&reader/read-regex +ident-re+) + (|do [[meta _] (&reader/read-text ";;") + [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/V "lux;Meta" (&/T meta (&/T module-name token))))) - (|do [[_ [meta _]] (&reader/read-text ";") - [_ [_ token]] (&reader/read-regex +ident-re+)] - (return (&/V "lux;Meta" (&/T meta (&/T "lux" token))))) + (return (&/T meta (&/T module-name token)))) + (|do [[meta _] (&reader/read-text ";") + [_ token] (&reader/read-regex +ident-re+)] + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol - (|do [[_ [meta ident]] lex-ident] + (|do [[meta ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag - (|do [[_ [meta _]] (&reader/read-text "#") - [_ [_ ident]] lex-ident] + (|do [[meta _] (&reader/read-text "#") + [_ ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) (do-template [ ] (def - (|do [[_ [meta _]] (&reader/read-text )] + (|do [[meta _] (&reader/read-text )] (return (&/V "lux;Meta" (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" "Open_Paren" diff --git a/src/lux/reader.clj b/src/lux/reader.clj index c25870168..b1fcc4740 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -11,7 +11,7 @@ [["lux;Nil" _]] (fail* "[Reader Error] EOF") - [["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]] + [["lux;Cons" [[[file-name line-num column-num] line] more]]] (matchv ::M/objects [(body file-name line-num column-num line)] [["No" msg]] @@ -38,18 +38,24 @@ ))) ;; [Exports] -(defn ^:private re-find! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find1! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (.group matcher 1)))) -(defn ^:private re-find3! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (list (.group matcher 0) (.group matcher 1) @@ -58,27 +64,29 @@ (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] + ;; (prn 'read-regex [file-name line-num column-num regex line]) (if-let [^String match (do ;; (prn '[regex line] [regex line]) - (re-find! regex line))] + (re-find! regex column-num line))] (let [;; _ (prn 'match match) match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) match)) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match tok1 tok2] (re-find3! regex line)] + ;; (prn 'read-regex2 [file-name line-num column-num regex line]) + (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] @@ -90,37 +98,38 @@ [["lux;Nil" _]] (&/V "lux;Left" "[Reader Error] EOF") - [["lux;Cons" [[_ [[file-name line-num column-num] ^String line]] + [["lux;Cons" [[[file-name line-num column-num] ^String line] reader**]]] (if-let [^String match (do ;; (prn 'read-regex+ regex line) - (re-find1! regex line))] + (re-find1! regex column-num line))] (let [match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V "lux;Right" (&/T (&/|cons (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)) + (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) - (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (str prefix match))))))) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - (if (.startsWith line text) + ;; (prn 'read-text [file-name line-num column-num text line]) + (if (.startsWith line text column-num) (let [match-length (.length text) - line* (.substring line match-length)] - (if (empty? line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + (&/V "Done" (&/T (&/T file-name line-num column-num) text)) + (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) (defn from [file-name] (let [lines (&/->list (string/split-lines (slurp file-name)))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/V "lux;Meta" (&/T (&/T file-name line-num 0) - line)))) + (&/T (&/T file-name line-num 0) + line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] (not= "" line))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 97b7c1bde..105528b8a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -547,17 +547,28 @@ (def init-fixpoints (&/|list)) +(def counter (atom {})) (defn ^:private check* [fixpoints expected actual] + ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] + ;; #(inc (or % 0))) (matchv ::M/objects [expected actual] [["lux;VarT" ?eid] ["lux;VarT" ?aid]] (if (= ?eid ?aid) (return (&/T fixpoints nil)) - (|do [ebound (&/try-all% (&/|list (|do [ebound (deref ?eid)] - (return (&/V "lux;Some" ebound))) - (return (&/V "lux;None" nil)))) - abound (&/try-all% (&/|list (|do [abound (deref ?aid)] - (return (&/V "lux;Some" abound))) - (return (&/V "lux;None" nil))))] + (|do [ebound (fn [state] + (matchv ::M/objects [((deref ?eid) state)] + [["lux;Right" [state* ebound]]] + (return* state* (&/V "lux;Some" ebound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil)))) + abound (fn [state] + (matchv ::M/objects [((deref ?aid) state)] + [["lux;Right" [state* abound]]] + (return* state* (&/V "lux;Some" abound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil))))] (matchv ::M/objects [ebound abound] [["lux;None" _] ["lux;None" _]] (|do [_ (set-var ?eid actual)] @@ -573,39 +584,75 @@ (check* fixpoints etype atype)))) [["lux;VarT" ?id] _] - (&/try-all% (&/|list (|do [_ (set-var ?id actual)] - (return (&/T fixpoints nil))) - (|do [bound (deref ?id)] - (check* fixpoints bound actual)))) + (fn [state] + (matchv ::M/objects [((set-var ?id actual) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) + + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints bound actual)) + state))) [_ ["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [_ (set-var ?id expected)] - (return (&/T fixpoints nil))) - (|do [bound (deref ?id)] - (check* fixpoints expected bound)))) + (fn [state] + (matchv ::M/objects [((set-var ?id expected) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) + + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints expected bound)) + state))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (&/try-all% (&/|list (|do [F1 (deref ?eid)] - (&/try-all% (&/|list (|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)))) - (|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?eid)] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* fixpoints* A1 A2)] + (return (&/T fixpoints** nil))) + state)))) ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) ;; _ (check* fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (&/try-all% (&/|list (|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?id)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) ;; e* (apply-type F2 A1) @@ -614,13 +661,20 @@ ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (&/try-all% (&/|list (|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?id)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) ;; e* (apply-type F1 A1) -- cgit v1.2.3