From d4eb8bcde06922ddb932488a516549bcc8f74d77 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 7 Feb 2016 23:25:34 -0400 Subject: - Fixed a bug when getting a value out of a variant (it was acting improperly when dealing with "composed" variants). - Revamped the way variants are defined & used in the compiler. --- src/lux/analyser.clj | 28 +-- src/lux/analyser/base.clj | 281 ++++++++++++------------ src/lux/analyser/case.clj | 156 +++++++------- src/lux/analyser/env.clj | 10 +- src/lux/analyser/host.clj | 218 +++++++++---------- src/lux/analyser/lambda.clj | 6 +- src/lux/analyser/lux.clj | 100 ++++----- src/lux/analyser/meta.clj | 6 +- src/lux/analyser/module.clj | 8 +- src/lux/analyser/parser.clj | 40 ++-- src/lux/analyser/record.clj | 4 +- src/lux/base.clj | 396 ++++++++++++++++++---------------- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 49 +++-- src/lux/compiler/host.clj | 28 ++- src/lux/compiler/lux.clj | 2 +- src/lux/compiler/type.clj | 57 ++--- src/lux/host.clj | 6 +- src/lux/lexer.clj | 52 ++--- src/lux/optimizer.clj | 506 ++++++++++++++++++++++---------------------- src/lux/parser.clj | 26 +-- src/lux/reader.clj | 50 ++--- src/lux/type.clj | 326 +++++++++++++--------------- src/lux/type/host.clj | 54 +++-- 24 files changed, 1215 insertions(+), 1202 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index ae4d81a39..4d68ab0d5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -26,19 +26,19 @@ :let [is-last? (= idx (dec (&/|length group)))]] (if (= 1 (&/|length group)) (|do [_cursor &/cursor] - (analyse exo-type (&/T [_cursor (&/V &/$TupleS values)]))) + (analyse exo-type (&/T [_cursor (&/$TupleS values)]))) (|case exo-type (&/$VarT id) (|do [? (&type/bound? id)] (if (or ? (&&/type-tag? module tag-name)) - (&&lux/analyse-variant analyse (&/V &/$Right exo-type) idx is-last? values) + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) (|do [wanted-type (&&module/tag-type module tag-name) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/V &/$Left wanted-type) idx is-last? values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type) idx is-last? values)) _ (&type/check exo-type variant-type)] (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) _ - (&&lux/analyse-variant analyse (&/V &/$Right exo-type) idx is-last? values) + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) )) )) @@ -398,7 +398,7 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% &&a-parser/parse-handler (&/T [&/Nil$ &/None$]) ?handlers)] + (|do [catches+finally (&/fold% &&a-parser/parse-handler (&/T [&/$Nil &/$None]) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] @@ -594,36 +594,36 @@ (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool) _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$bool ?value))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$bool ?value))))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int) _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$int ?value))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$int ?value))))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real) _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$real ?value))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$real ?value))))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char) _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$char ?value))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$char ?value))))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text) _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$text ?value))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$text ?value))))) (&/$TupleS ?elems) - (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) + (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems) (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (analyse-variant+ analyse exo-type ?ident &/Nil$) + (analyse-variant+ analyse exo-type ?ident &/$Nil) (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) @@ -669,7 +669,7 @@ (&/with-expected-type exo-type (|case token [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx nil ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/$Right exo-type) idx nil ?values) [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) @@ -695,4 +695,4 @@ ;; [Resources] (defn analyse [eval! compile-module compile-token] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! compile-module compile-token &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module compile-token &/$VoidT) asts))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 62b2b5aad..00dbfb977 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -6,150 +6,149 @@ (ns lux.analyser.base (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return* return fail |case]] + (lux [base :as & :refer [defvariant |let |do return* return fail |case]] [type :as &type]))) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "coerce" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - - "jvm-znewarray" - "jvm-zastore" - "jvm-zaload" - "jvm-bnewarray" - "jvm-bastore" - "jvm-baload" - "jvm-snewarray" - "jvm-sastore" - "jvm-saload" - "jvm-inewarray" - "jvm-iastore" - "jvm-iaload" - "jvm-lnewarray" - "jvm-lastore" - "jvm-laload" - "jvm-fnewarray" - "jvm-fastore" - "jvm-faload" - "jvm-dnewarray" - "jvm-dastore" - "jvm-daload" - "jvm-cnewarray" - "jvm-castore" - "jvm-caload" - "jvm-anewarray" - "jvm-aastore" - "jvm-aaload" - "jvm-arraylength" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr"]) +(defvariant + ("bool" 1) + ("int" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 1) + ("case" 1) + ("lambda" 1) + ("ann" 1) + ("coerce" 1) + ("def" 1) + ("declare-macro" 1) + ("var" 1) + ("captured" 1) + + ("jvm-getstatic" 1) + ("jvm-getfield" 1) + ("jvm-putstatic" 1) + ("jvm-putfield" 1) + ("jvm-invokestatic" 1) + ("jvm-instanceof" 1) + ("jvm-invokevirtual" 1) + ("jvm-invokeinterface" 1) + ("jvm-invokespecial" 1) + ("jvm-null?" 1) + ("jvm-null" 0) + ("jvm-new" 1) + ("jvm-class" 1) + ("jvm-interface" 1) + ("jvm-try" 1) + ("jvm-throw" 1) + ("jvm-monitorenter" 1) + ("jvm-monitorexit" 1) + ("jvm-program" 1) + + ("jvm-znewarray" 1) + ("jvm-zastore" 1) + ("jvm-zaload" 1) + ("jvm-bnewarray" 1) + ("jvm-bastore" 1) + ("jvm-baload" 1) + ("jvm-snewarray" 1) + ("jvm-sastore" 1) + ("jvm-saload" 1) + ("jvm-inewarray" 1) + ("jvm-iastore" 1) + ("jvm-iaload" 1) + ("jvm-lnewarray" 1) + ("jvm-lastore" 1) + ("jvm-laload" 1) + ("jvm-fnewarray" 1) + ("jvm-fastore" 1) + ("jvm-faload" 1) + ("jvm-dnewarray" 1) + ("jvm-dastore" 1) + ("jvm-daload" 1) + ("jvm-cnewarray" 1) + ("jvm-castore" 1) + ("jvm-caload" 1) + ("jvm-anewarray" 1) + ("jvm-aastore" 1) + ("jvm-aaload" 1) + ("jvm-arraylength" 1) + + ("jvm-iadd" 1) + ("jvm-isub" 1) + ("jvm-imul" 1) + ("jvm-idiv" 1) + ("jvm-irem" 1) + ("jvm-ieq" 1) + ("jvm-ilt" 1) + ("jvm-igt" 1) + + ("jvm-ceq" 1) + ("jvm-clt" 1) + ("jvm-cgt" 1) + + ("jvm-ladd" 1) + ("jvm-lsub" 1) + ("jvm-lmul" 1) + ("jvm-ldiv" 1) + ("jvm-lrem" 1) + ("jvm-leq" 1) + ("jvm-llt" 1) + ("jvm-lgt" 1) + + ("jvm-fadd" 1) + ("jvm-fsub" 1) + ("jvm-fmul" 1) + ("jvm-fdiv" 1) + ("jvm-frem" 1) + ("jvm-feq" 1) + ("jvm-flt" 1) + ("jvm-fgt" 1) + + ("jvm-dadd" 1) + ("jvm-dsub" 1) + ("jvm-dmul" 1) + ("jvm-ddiv" 1) + ("jvm-drem" 1) + ("jvm-deq" 1) + ("jvm-dlt" 1) + ("jvm-dgt" 1) + + ("jvm-d2f" 1) + ("jvm-d2i" 1) + ("jvm-d2l" 1) + + ("jvm-f2d" 1) + ("jvm-f2i" 1) + ("jvm-f2l" 1) + + ("jvm-i2b" 1) + ("jvm-i2c" 1) + ("jvm-i2d" 1) + ("jvm-i2f" 1) + ("jvm-i2l" 1) + ("jvm-i2s" 1) + + ("jvm-l2d" 1) + ("jvm-l2f" 1) + ("jvm-l2i" 1) + + ("jvm-iand" 1) + ("jvm-ior" 1) + ("jvm-ixor" 1) + ("jvm-ishl" 1) + ("jvm-ishr" 1) + ("jvm-iushr" 1) + + ("jvm-land" 1) + ("jvm-lor" 1) + ("jvm-lxor" 1) + ("jvm-lshl" 1) + ("jvm-lshr" 1) + ("jvm-lushr" 1)) ;; [Exports] (defn expr-type* [analysis] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 3480e50c6..2e58d7baf 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -6,7 +6,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case]] + (lux [base :as & :refer [defvariant |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -15,31 +15,29 @@ [record :as &&record]))) ;; [Tags] -(deftags - ["DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal"] - ) - -(deftags - ["StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC"] - ) +(defvariant + ("DefaultTotal" 1) + ("BoolTotal" 2) + ("IntTotal" 2) + ("RealTotal" 2) + ("CharTotal" 2) + ("TextTotal" 2) + ("TupleTotal" 2) + ("VariantTotal" 2)) + +(defvariant + ("StoreTestAC" 1) + ("BoolTestAC" 1) + ("IntTestAC" 1) + ("RealTestAC" 1) + ("CharTestAC" 1) + ("TextTestAC" 1) + ("TupleTestAC" 1) + ("VariantTestAC" 1)) ;; [Utils] (def ^:private unit - (&/T [(&/T ["" -1 -1]) (&/V &/$TupleS &/Nil$)])) + (&/T [(&/T ["" -1 -1]) (&/$TupleS &/$Nil)])) (defn ^:private resolve-type [type] (|case type @@ -67,7 +65,7 @@ (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var) - ==type (adjust-type* (&/Cons$ (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)] + ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) (&/|map update-up-frame up)) =type)] (&type/clean $var ==type)))) (&/$ExQ _aenv _abody) @@ -78,14 +76,14 @@ (&/$ProdT ?left ?right) (|do [=type (&/fold% (fn [_abody ena] (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (|do [_ (&type/set-var _avar (&/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up) :let [distributor (fn [v] (&/fold (fn [_abody ena] (|let [[_aenv _aidx _avar] ena] - (&/V &/$UnivQ (&/T [_aenv _abody])))) + (&/$UnivQ _aenv _abody))) v up)) adjusted-type (&type/Tuple$ (&/|map distributor (&type/flatten-prod =type)))]] @@ -94,14 +92,14 @@ (&/$SumT ?left ?right) (|do [=type (&/fold% (fn [_abody ena] (|let [[_aenv _aidx (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (|do [_ (&type/set-var _avar (&/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up) :let [distributor (fn [v] (&/fold (fn [_abody ena] (|let [[_aenv _aidx _avar] ena] - (&/V &/$UnivQ (&/T [_aenv _abody])))) + (&/$UnivQ _aenv _abody))) v up)) adjusted-type (&type/Variant$ (&/|map distributor (&type/flatten-sum =type)))]] @@ -128,7 +126,7 @@ (defn adjust-type [type] "(-> Type (Lux Type))" - (adjust-type* &/Nil$ type)) + (adjust-type* &/$Nil type)) (defn ^:private analyse-pattern [var?? value-type pattern kont] (|let [[meta pattern*] pattern] @@ -138,13 +136,13 @@ (&/$Some var-analysis) (|do [=kont (&env/with-alias name var-analysis kont)] - (return (&/T [(&/V $StoreTestAC -1) =kont]))) + (return (&/T [($StoreTestAC -1) =kont]))) _ (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T [(&/V $StoreTestAC idx) =kont])))) + (return (&/T [($StoreTestAC idx) =kont])))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -152,34 +150,34 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T [(&/V $BoolTestAC ?value) =kont]))) + (return (&/T [($BoolTestAC ?value) =kont]))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T [(&/V $IntTestAC ?value) =kont]))) + (return (&/T [($IntTestAC ?value) =kont]))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T [(&/V $RealTestAC ?value) =kont]))) + (return (&/T [($RealTestAC ?value) =kont]))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T [(&/V $CharTestAC ?value) =kont]))) + (return (&/T [($CharTestAC ?value) =kont]))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T [(&/V $TextTestAC ?value) =kont]))) + (return (&/T [($TextTestAC ?value) =kont]))) (&/$TupleS ?members) (|case ?members (&/$Nil) - (|do [_ (&type/check value-type &type/Unit) + (|do [_ (&type/check value-type &/$UnitT) =kont kont] - (return (&/T [(&/V $TupleTestAC (&/|list)) =kont]))) + (return (&/T [($TupleTestAC (&/|list)) =kont]))) (&/$Cons ?member (&/$Nil)) (analyse-pattern var?? value-type ?member kont) @@ -197,19 +195,19 @@ (&/$Some ?member-types*) (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern &/None$ v m kont*)] - (return (&/T [(&/Cons$ =test =tests) =kont]))))) + (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] + (return (&/T [(&/$Cons =test =tests) =kont]))))) (|do [=kont kont] - (return (&/T [&/Nil$ =kont]))) + (return (&/T [&/$Nil =kont]))) (&/|reverse (&/zip2 ?member-types* ?members)))] - (return (&/T [(&/V $TupleTestAC =tests) =kont])))) + (return (&/T [($TupleTestAC =tests) =kont])))) _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) (&/$RecordS pairs) (|do [[rec-members rec-type] (&&record/order-record pairs)] - (analyse-pattern &/None$ value-type (&/T [meta (&/V &/$TupleS rec-members)]) kont)) + (analyse-pattern &/$None value-type (&/T [meta (&/$TupleS rec-members)]) kont)) (&/$TagS ?ident) (|do [[=module =name] (&&/resolved-ident ?ident) @@ -217,8 +215,8 @@ idx (&module/tag-index =module =name) group (&module/tag-group =module =name) case-type (&type/sum-at idx value-type*) - [=test =kont] (analyse-pattern &/None$ case-type unit kont)] - (return (&/T [(&/V $VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + [=test =kont] (analyse-pattern &/$None case-type unit kont)] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) @@ -228,11 +226,11 @@ group (&module/tag-group =module =name) case-type (&type/sum-at idx value-type*) [=test =kont] (case (int (&/|length ?values)) - 0 (analyse-pattern &/None$ case-type unit kont) - 1 (analyse-pattern &/None$ case-type (&/|head ?values) kont) + 0 (analyse-pattern &/$None case-type unit kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern &/None$ case-type (&/T [(&/T ["" -1 -1]) (&/V &/$TupleS ?values)]) kont))] - (return (&/T [(&/V $VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$TupleS ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) _ (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) @@ -241,89 +239,89 @@ (defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] (|do [pattern+body (analyse-pattern var?? value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/Cons$ pattern+body patterns)))) + (return (&/$Cons pattern+body patterns)))) (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/V $DefaultTotal true)) + (return ($DefaultTotal true)) [($BoolTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $BoolTotal (&/T [true ?values]))) + (return ($BoolTotal true ?values)) [($IntTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $IntTotal (&/T [true ?values]))) + (return ($IntTotal true ?values)) [($RealTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $RealTotal (&/T [true ?values]))) + (return ($RealTotal true ?values)) [($CharTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $CharTotal (&/T [true ?values]))) + (return ($CharTotal true ?values)) [($TextTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $TextTotal (&/T [true ?values]))) + (return ($TextTotal true ?values)) [($TupleTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $TupleTotal (&/T [true ?values]))) + (return ($TupleTotal true ?values)) [($VariantTotal total? ?values) ($StoreTestAC ?idx)] - (return (&/V $VariantTotal (&/T [true ?values]))) + (return ($VariantTotal true ?values)) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T [total? (&/|list ?value)]))) + (return ($BoolTotal total? (&/|list ?value))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T [total? (&/Cons$ ?value ?values)]))) + (return ($BoolTotal total? (&/$Cons ?value ?values))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T [total? (&/|list ?value)]))) + (return ($IntTotal total? (&/|list ?value))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T [total? (&/Cons$ ?value ?values)]))) + (return ($IntTotal total? (&/$Cons ?value ?values))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T [total? (&/|list ?value)]))) + (return ($RealTotal total? (&/|list ?value))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T [total? (&/Cons$ ?value ?values)]))) + (return ($RealTotal total? (&/$Cons ?value ?values))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T [total? (&/|list ?value)]))) + (return ($CharTotal total? (&/|list ?value))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T [total? (&/Cons$ ?value ?values)]))) + (return ($CharTotal total? (&/$Cons ?value ?values))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T [total? (&/|list ?value)]))) + (return ($TextTotal total? (&/|list ?value))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T [total? (&/Cons$ ?value ?values)]))) + (return ($TextTotal total? (&/$Cons ?value ?values))) [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] - (merge-total (&/V $DefaultTotal total?) (&/T [t ?body]))) + (merge-total ($DefaultTotal total?) (&/T [t ?body]))) ?tests)] - (return (&/V $TupleTotal (&/T [total? structs])))) + (return ($TupleTotal total? structs))) [($TupleTotal total? ?values) ($TupleTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T [t ?body]))) ?values ?tests)] - (return (&/V $TupleTotal (&/T [total? structs])))) + (return ($TupleTotal total? structs))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (|do [sub-struct (merge-total ($DefaultTotal total?) (&/T [?test ?body])) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T [total? structs])))) + (return ($VariantTotal total? structs))) [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) @@ -331,7 +329,7 @@ sub (&/$None) - (&/V $DefaultTotal total?)) + ($DefaultTotal total?)) (&/T [?test ?body])) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) @@ -339,7 +337,7 @@ (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T [total? structs])))) + (return ($VariantTotal total? structs))) ))) (defn check-totality+ [check-totality] @@ -394,7 +392,7 @@ (|do [=structs (&/map% (check-totality+ check-totality) ?structs) _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) (&/$Cons last prevs) - (&/fold (fn [right left] (&type/Prod$ left right)) + (&/fold (fn [right left] (&/$ProdT left right)) last prevs)))] (return (or ?total (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) @@ -436,9 +434,9 @@ (|do [patterns (&/fold% (fn [patterns branch] (|let [[pattern body] branch] (analyse-branch analyse exo-type var?? value-type pattern body patterns))) - &/Nil$ + &/$Nil branches) - struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) + struct (&/fold% merge-total ($DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index f6a1adfc6..bea4c8308 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -19,8 +19,8 @@ (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) =return (body (&/update$ &/$envs (fn [stack] - (let [var-analysis (&&/|meta type &/empty-cursor (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] - (&/Cons$ (&/update$ &/$locals #(->> % + (let [var-analysis (&&/|meta type &/empty-cursor (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] + (&/$Cons (&/update$ &/$locals #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) (&/|head stack)) @@ -29,7 +29,7 @@ (|case =return (&/$Right ?state ?value) (return* (&/update$ &/$envs (fn [stack*] - (&/Cons$ (&/update$ &/$locals #(->> % + (&/$Cons (&/update$ &/$locals #(->> % (&/update$ &/$counter dec) (&/set$ &/$mappings old-mappings)) (&/|head stack*)) @@ -45,7 +45,7 @@ (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) =return (body (&/update$ &/$envs (fn [stack] - (&/Cons$ (&/update$ &/$locals #(->> % + (&/$Cons (&/update$ &/$locals #(->> % (&/update$ &/$mappings (fn [m] (&/|put name var-analysis m)))) (&/|head stack)) (&/|tail stack))) @@ -53,7 +53,7 @@ (|case =return (&/$Right ?state ?value) (return* (&/update$ &/$envs (fn [stack*] - (&/Cons$ (&/update$ &/$locals #(->> % + (&/$Cons (&/update$ &/$locals #(->> % (&/set$ &/$mappings old-mappings)) (&/|head stack*)) (&/|tail stack*))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 6df324c1d..42257e352 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -48,11 +48,11 @@ state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] (|case (&/run-state body state*) (&/$Left msg) - (&/V &/$Left msg) + (&/$Left msg) (&/$Right state** output) - (&/V &/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) - output])))) + (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output])))) )) (defn ^:private ensure-object [type] @@ -81,7 +81,7 @@ "(-> Type Type)" (|case type (&/$DataT class params) - (&type/Data$ (&host-type/as-obj class) params) + (&/$DataT (&host-type/as-obj class) params) _ type)) @@ -104,7 +104,7 @@ "(-> Type Type)" (|case type (&/$DataT name params) - (&type/Data$ (as-otype name) params) + (&/$DataT (as-otype name) params) _ type)) @@ -115,14 +115,14 @@ (if ? (|do [real-type (&type/deref id)] (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&type/Bound$ idx)])))))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) (defn ^:private clean-gtype-vars [gtype-vars] (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] (|do [:let [[idx types] idx+types] [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/Cons$ real-type types)])))) - (&/T [1 (&/|list)]) + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) gtype-vars)] (return clean-types))) @@ -131,24 +131,24 @@ (&/fold (fn [base-type type-arg] (|case type-arg (&/$BoundT _) - (&type/Univ$ &type/empty-env base-type) + (&/$UnivQ &type/empty-env base-type) _ base-type)) - (&type/Data$ class-name type-args) + (&/$DataT class-name type-args) type-args)) ;; [Resources] (do-template [ ] - (let [input-type (&type/Data$ &/Nil$) - output-type (&type/Data$ &/Nil$)] + (let [input-type (&/$DataT &/$Nil) + output-type (&/$DataT &/$Nil)] (defn [analyse exo-type x y] (|do [=x (&&/analyse-1 analyse input-type x) =y (&&/analyse-1 analyse input-type y) _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor - (&/V (&/T [=x =y])))))))) + ( (&/T [=x =y])))))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -196,7 +196,7 @@ (|case obj-type (&/$DataT class targs) (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T [(.getName g) t]) m)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) (&/|table) gvars targs)] @@ -209,12 +209,12 @@ (defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader [gvars gtype] (&host/lookup-static-field class-loader class field) - =type (&host-type/instance-param &type/existential (&/|list) gtype) + =type (&host-type/instance-param &type/existential &/$Nil gtype) :let [output-type =type] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-getstatic (&/T [class field output-type]))))))) + (&&/$jvm-getstatic (&/T [class field output-type]))))))) (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader @@ -226,19 +226,19 @@ _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-getfield (&/T [class field =object output-type]))))))) + (&&/$jvm-getfield (&/T [class field =object output-type]))))))) (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader [gvars gtype] (&host/lookup-static-field class-loader class field) :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential (&/|list) gtype) + =type (&host-type/instance-param &type/existential &/$Nil gtype) =value (&&/analyse-1 analyse =type value) - :let [output-type &type/Unit] + :let [output-type &/$UnitT] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-putstatic (&/T [class field =value gclass =type]))))))) + (&&/$jvm-putstatic (&/T [class field =value gclass =type]))))))) (defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader @@ -249,11 +249,11 @@ :let [gclass (&host-type/gtype->gclass gtype)] =type (analyse-field-access-helper obj-type gvars gtype) =value (&&/analyse-1 analyse =type value) - :let [output-type &type/Unit] + :let [output-type &/$UnitT] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-putfield (&/T [class field =value gclass =object =type]))))))) + (&&/$jvm-putfield (&/T [class field =value gclass =object =type]))))))) (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) @@ -262,7 +262,7 @@ _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-instanceof (&/T [class =object]))))))) + (&&/$jvm-instanceof (&/T [class =object]))))))) (defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] (|case gtype-vars @@ -276,14 +276,14 @@ (&/$Cons ^TypeVariable gtv gtype-vars*) (&type/with-var (fn [$var] - (|do [:let [gtype-env* (&/Cons$ (&/T [(.getName gtv) $var]) gtype-env)] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] [=gret =args] (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args) ==gret (&type/clean $var =gret) ==args (&/map% (partial &&/clean-analysis $var) =args)] (return (&/T [==gret ==args]))))) )) -(let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))] +(let [dummy-type-param (&/$DataT "java.lang.Object" &/$Nil)] (do-template [ ] (defn [analyse exo-type class method classes object args] (|do [class-loader &/loader @@ -295,13 +295,13 @@ (catch Exception e (fail (str "[Analyser Error] Unknown class: " class)))) [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$])) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) (&host/lookup-virtual-method class-loader class method classes)) _ (ensure-catching exceptions) =object (&&/analyse-1+ analyse object) [sub-class sub-params] (ensure-object (&&/expr-type* =object)) (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T [(.getName g) t]) m)) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) (&/|table) parent-gvars super-params*)] @@ -309,7 +309,7 @@ _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T [class method classes =object =args output-type]))))))) + ( (&/T [class method classes =object =args output-type]))))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual false analyse-jvm-invokespecial &&/$jvm-invokespecial false @@ -325,7 +325,7 @@ _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-invokestatic (&/T [class method classes =args output-type]))))))) + (&&/$jvm-invokestatic (&/T [class method classes =args output-type]))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) @@ -334,14 +334,14 @@ _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-null? =object)))))) + (&&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)] + (|do [:let [output-type (&/$DataT &host-type/null-data-tag &/$Nil)] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-null &/unit-tag)))))) + &&/$jvm-null))))) (defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] (|case gtype-vars @@ -355,7 +355,7 @@ (&/$Cons ^TypeVariable gtv gtype-vars*) (&type/with-var (fn [$var] - (|do [:let [gtype-env* (&/Cons$ (&/T [(.getName gtv) $var]) gtype-env)] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) ==gret (&type/clean $var =gret) ==args (&/map% (partial &&/clean-analysis $var) =args)] @@ -370,19 +370,19 @@ _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-new (&/T [class classes =args]))))))) + (&&/$jvm-new (&/T [class classes =args]))))))) (let [length-type &type/Int idx-type &type/Int] (do-template [ ] - (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + (let [elem-type (&/$DataT &/$Nil) + array-type (&/$DataT &host-type/array-data-tag (&/|list elem-type))] (defn [analyse exo-type length] (|do [=length (&&/analyse-1 analyse length-type length) _ (&type/check exo-type array-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V =length)))))) + ( =length)))))) (defn [analyse exo-type array idx] (|do [=array (&&/analyse-1 analyse array-type array) @@ -390,7 +390,7 @@ _ (&type/check exo-type elem-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T [=array =idx]))))))) + ( (&/T [=array =idx]))))))) (defn [analyse exo-type array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) @@ -399,7 +399,7 @@ _ (&type/check exo-type array-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T [=array =idx =elem]))))))) + ( (&/T [=array =idx =elem]))))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -417,12 +417,12 @@ (defn analyse-jvm-anewarray [analyse exo-type gclass length] (|do [gtype-env &/get-type-env =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list =gclass))] + :let [array-type (&/$DataT &host-type/array-data-tag (&/|list =gclass))] =length (&&/analyse-1 analyse length-type length) _ (&type/check exo-type array-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-anewarray (&/T [gclass =length gtype-env]))))))) + (&&/$jvm-anewarray (&/T [gclass =length gtype-env]))))))) (defn analyse-jvm-aaload [analyse exo-type array idx] (|do [=array (&&/analyse-1+ analyse array) @@ -433,7 +433,7 @@ _ (&type/check exo-type inner-arr-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aaload (&/T [=array =idx]))))))) + (&&/$jvm-aaload (&/T [=array =idx]))))))) (defn analyse-jvm-aastore [analyse exo-type array idx elem] (|do [=array (&&/analyse-1+ analyse array) @@ -446,7 +446,7 @@ _ (&type/check exo-type array-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aastore (&/T [=array =idx =elem])))))))) + (&&/$jvm-aastore (&/T [=array =idx =elem])))))))) (defn analyse-jvm-arraylength [analyse exo-type array] (|do [=array (&&/analyse-1+ analyse array) @@ -455,7 +455,7 @@ _ (&type/check exo-type &type/Int) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-arraylength =array) + (&&/$jvm-arraylength =array) ))))) (defn generic-class->simple-class [gclass] @@ -519,25 +519,25 @@ (&/$GenericClass name params) (case name - "boolean" (return (&type/Data$ "java.lang.Boolean" (&/|list))) - "byte" (return (&type/Data$ "java.lang.Byte" (&/|list))) - "short" (return (&type/Data$ "java.lang.Short" (&/|list))) - "int" (return (&type/Data$ "java.lang.Integer" (&/|list))) - "long" (return (&type/Data$ "java.lang.Long" (&/|list))) - "float" (return (&type/Data$ "java.lang.Float" (&/|list))) - "double" (return (&type/Data$ "java.lang.Double" (&/|list))) - "char" (return (&type/Data$ "java.lang.Character" (&/|list))) - "void" (return &type/Unit) + "boolean" (return (&/$DataT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$DataT "java.lang.Byte" &/$Nil)) + "short" (return (&/$DataT "java.lang.Short" &/$Nil)) + "int" (return (&/$DataT "java.lang.Integer" &/$Nil)) + "long" (return (&/$DataT "java.lang.Long" &/$Nil)) + "float" (return (&/$DataT "java.lang.Float" &/$Nil)) + "double" (return (&/$DataT "java.lang.Double" &/$Nil)) + "char" (return (&/$DataT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) ;; else (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&type/Data$ name =params)))) + (return (&/$DataT name =params)))) (&/$GenericArray param) (|do [=param (generic-class->type env param)] - (return (&type/Data$ &host-type/array-data-tag (&/|list =param)))) + (return (&/$DataT &host-type/array-data-tag (&/|list =param)))) (&/$GenericWildcard) - (return (&type/Ex$ (&/|list) (&type/Bound$ 1))) + (return (&/$ExT &/$Nil (&/$BoundT 1))) )) (defn gen-super-env [class-env supers class-decl] @@ -546,8 +546,8 @@ (|case (&/|some (fn [super] (|let [[super-name super-params] super] (if (= class-name super-name) - (&/Some$ (&/zip2 class-vars super-params)) - &/None$))) + (&/$Some (&/zip2 class-vars super-params)) + &/$None))) supers) (&/$None) (fail (str "[Analyser Error] Unrecognized super-class: " class-name)) @@ -563,7 +563,7 @@ (defn ^:private analyse-method [analyse class-decl class-env all-supers method] "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" (|let [[?cname ?cparams] class-decl - class-type (&/V &/$DataT (&/T [?cname (&/|map &/|second class-env)]))] + class-type (&/$DataT ?cname (&/|map &/|second class-env))] (|case method (&/$ConstructorMethodSyntax =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) (|do [method-env (&/map% (fn [gvar] @@ -571,7 +571,7 @@ (return (&/T [gvar ex])))) ?gvars) :let [full-env (&/|++ class-env method-env)] - :let [output-type &type/Unit] + :let [output-type &/$UnitT] =ctor-args (&/map% (fn [ctor-arg] (|do [:let [[ca-type ca-term] ctor-arg] =ca-type (generic-class->type full-env ca-type) @@ -587,7 +587,7 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] - (return (&/V &/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [method-env (&/map% (fn [gvar] @@ -605,7 +605,7 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] - (return (&/V &/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?anns ?gvars ?exceptions ?inputs ?output =body])))) + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?anns ?gvars ?exceptions ?inputs ?output =body])))) (&/$OverridenMethodSyntax ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [super-env (gen-super-env class-env all-supers ?class-decl) @@ -624,7 +624,7 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs))))] - (return (&/V &/$OverridenMethodAnalysis (&/T [?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output =body])))) + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output =body])))) (&/$StaticMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output ?body) (|do [method-env (&/map% (fn [gvar] @@ -641,10 +641,10 @@ body*))) (&&/analyse-1 analyse output-type ?body) (&/|reverse ?inputs)))] - (return (&/V &/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output =body])))) + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output =body])))) (&/$AbstractMethodSyntax ?name ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/V &/$AbstractMethodAnalysis (&/T [?name ?anns ?gvars ?exceptions ?inputs ?output]))) + (return (&/$AbstractMethodAnalysis (&/T [?name ?anns ?gvars ?exceptions ?inputs ?output]))) ))) (defn ^:private mandatory-methods [supers] @@ -699,72 +699,72 @@ (|do [module &/get-module-name :let [[?name ?params] class-decl full-name (str module "." ?name) - all-supers (&/Cons$ super-class interfaces)] + all-supers (&/$Cons super-class interfaces)] class-env (&/map% (fn [gvar] (|do [ex &type/existential] (return (&/T [gvar ex])))) ?params) - _ (&host/use-dummy-class class-decl super-class interfaces &/None$ =fields methods) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) _ (check-method-completion all-supers =methods) - _ (compile-token (&/V &&/$jvm-class (&/T [class-decl super-class interfaces =inheritance-modifier =anns =fields =methods (&/|list) &/None$]))) + _ (compile-token (&&/$jvm-class (&/T [class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None]))) :let [_ (println 'DEF full-name)]] - (return &/Nil$)))) + (return &/$Nil)))) (defn analyse-jvm-interface [analyse compile-token interface-decl supers =anns =methods] (|do [module &/get-module-name - _ (compile-token (&/V &&/$jvm-interface (&/T [interface-decl supers =anns =methods]))) + _ (compile-token (&&/$jvm-interface (&/T [interface-decl supers =anns =methods]))) :let [_ (println 'DEF (str module "." (&/|first interface-decl)))]] - (return &/Nil$))) + (return &/$Nil))) (defn ^:private captured-source [env-entry] (|case env-entry [name [_ (&&/$captured _ _ source)]] source)) -(let [default- (&/V &/$ConstructorMethodSyntax (&/T [(&/V &/$PublicPM &/unit-tag) - (&/|list) - (&/|list) - (&/|list) - (&/|list) - (&/|list) - (&/V &/$TupleS (&/|list))])) +(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) captured-slot-class "java.lang.Object" - captured-slot-type (&/V &/$GenericClass (&/T [captured-slot-class (&/|list)]))] + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces ctor-args methods] (&/with-closure (|do [module &/get-module-name scope &/get-scope-name :let [name (&host/location (&/|tail scope)) - class-decl (&/T [name (&/|list)]) + class-decl (&/T [name &/$Nil]) anon-class (str module "." name) - anon-class-type (&type/Data$ anon-class (&/|list))] + anon-class-type (&/$DataT anon-class &/$Nil)] =ctor-args (&/map% (fn [ctor-arg] (|let [[arg-type arg-term] ctor-arg] (|do [=arg-term (&&/analyse-1+ analyse arg-term)] (return (&/T [arg-type =arg-term]))))) ctor-args) _ (->> methods - (&/Cons$ default-) - (&host/use-dummy-class class-decl super-class interfaces (&/Some$ =ctor-args) (&/|list))) - :let [all-supers (&/Cons$ super-class interfaces) - class-env (&/|list)] + (&/$Cons default-) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) _ (check-method-completion all-supers =methods) =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] (|let [[idx _] idx+capt] (&/T [(str &c!base/closure-prefix idx) - (&/V &/$PublicPM &/unit-tag) - (&/V &/$FinalSM &/unit-tag) - (&/|list) + &/$PublicPM + &/$FinalSM + &/$Nil captured-slot-type]))) (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] - _ (compile-token (&/V &&/$jvm-class (&/T [class-decl super-class interfaces (&/V &/$DefaultIM &/unit-tag) (&/|list) =fields =methods =captured (&/Some$ =ctor-args)]))) + _ (compile-token (&&/$jvm-class (&/T [class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)]))) _cursor &/cursor] (return (&/|list (&&/|meta anon-class-type _cursor - (&/V &&/$jvm-new (&/T [anon-class (&/|repeat (&/|length sources) captured-slot-class) sources])) + (&&/$jvm-new (&/T [anon-class (&/|repeat (&/|length sources) captured-slot-class) sources])) ))) )))) @@ -772,7 +772,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =catches (&/map% (fn [_catch_] (|do [:let [[?ex-class ?ex-arg ?catch-body] _catch_] - =catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) + =catch-body (&&env/with-local ?ex-arg (&/$DataT ?ex-class &/$Nil) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T [?ex-class idx =catch-body])))) @@ -784,39 +784,39 @@ =body (with-catches catched-exceptions (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally - (&/$None) (return &/None$) + (&/$None) (return &/$None) (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally)))) + (return (&/$Some =finally)))) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-try (&/T [=body =catches =finally]))))))) + (&&/$jvm-try (&/T [=body =catches =finally]))))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex) + (|do [=ex (&&/analyse-1 analyse (&/$DataT "java.lang.Throwable" &/$Nil) ?ex) _cursor &/cursor - _ (&type/check exo-type &type/$Void)] - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex)))))) + _ (&type/check exo-type &/$VoidT)] + (return (&/|list (&&/|meta exo-type _cursor (&&/$jvm-throw =ex)))))) (do-template [ ] (defn [analyse exo-type ?monitor] (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object (&&/expr-type* =monitor)) - :let [output-type &type/Unit] + :let [output-type &/$UnitT] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&/V =monitor)))))) + (return (&/|list (&&/|meta output-type _cursor ( =monitor)))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] - (let [output-type (&type/Data$ &/Nil$)] + (let [output-type (&/$DataT &/$Nil)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) + (|do [=value (&&/analyse-1 analyse (&/$DataT &/$Nil) ?value) _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) + (return (&/|list (&&/|meta output-type _cursor ( =value))))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -839,12 +839,12 @@ ) (do-template [ ] - (let [output-type (&type/Data$ &/Nil$)] + (let [output-type (&/$DataT &/$Nil)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) + (|do [=value (&&/analyse-1 analyse (&/$DataT &/$Nil) ?value) _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) + (return (&/|list (&&/|meta output-type _cursor ( =value))))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -861,11 +861,11 @@ analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) -(let [input-type (&type/App$ &type/List &type/Text) - output-type (&type/App$ &type/IO &type/Unit)] +(let [input-type (&/$AppT &type/List &type/Text) + output-type (&/$AppT &type/IO &/$UnitT)] (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" (&&env/with-local ?args input-type (&&/analyse-1 analyse output-type ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] - (return &/Nil$)))) + _ (compile-token (&&/$jvm-program =body))] + (return &/$Nil)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 8d94d4ab6..b47b803d0 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -24,9 +24,9 @@ (defn close-over [scope name register frame] (|let [[[register-type register-cursor] _] register register* (&&/|meta register-type register-cursor - (&/V &&/$captured (&/T [scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register])))] + (&&/$captured (&/T [scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register])))] (&/T [register* (&/update$ &/$closure #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 29cc253a8..a5e3b3290 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -31,23 +31,23 @@ (defn ^:private next-bound-type [type] "(-> Type Type)" - (&type/Bound$ (->> (count-univq type) (* 2) (+ 1)))) + (&/$BoundT (->> (count-univq type) (* 2) (+ 1)))) (defn ^:private embed-inferred-input [input output] "(-> Type Type Type)" (|case output (&/$UnivQ env output*) - (&type/Univ$ env (embed-inferred-input input output*)) + (&/$UnivQ env (embed-inferred-input input output*)) _ - (&type/Lambda$ input output))) + (&/$LambdaT input output))) ;; [Exports] (defn analyse-unit [analyse ?exo-type] (|do [_cursor &/cursor - _ (&type/check ?exo-type &type/Unit)] + _ (&type/check ?exo-type &/$UnitT)] (return (&/|list (&&/|meta ?exo-type _cursor - (&/V &&/$tuple (&/|list))))))) + (&&/$tuple (&/|list))))))) (defn analyse-tuple [analyse ?exo-type ?elems] (|case ?elems @@ -71,14 +71,14 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$VarT iid) (|do [:let [=var* (next-bound-type tuple-type)] _ (&type/set-var iid =var*) tuple-type* (&type/clean $var tuple-type)] - (return (&type/Univ$ &/Nil$ tuple-type*))) + (return (&/$UnivQ &/$Nil tuple-type*))) _ (&type/clean $var tuple-type))] @@ -86,7 +86,7 @@ tuple-analysis)))))) _ - (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + (analyse-tuple analyse (&/$Right exo-type*) ?elems))) (&/$Right exo-type) (|do [unknown? (&type/unknown? exo-type)] @@ -96,11 +96,11 @@ ?elems) _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) (&/$Cons last prevs) - (&/fold (fn [right left] (&type/Prod$ left right)) + (&/fold (fn [right left] (&/$ProdT left right)) last prevs))) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$tuple =elems) + (&&/$tuple =elems) )))) (|do [exo-type* (&type/actual-type exo-type)] (&/with-attempt @@ -117,13 +117,13 @@ ?elems) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$tuple =elems) + (&&/$tuple =elems) ))))) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems))] (return (&/|list (&&/|meta exo-type tuple-cursor tuple-analysis)))) @@ -145,7 +145,7 @@ (analyse exo-type ?value) _ - (analyse-tuple analyse (&/V &/$Right exo-type) ?values)) + (analyse-tuple analyse (&/$Right exo-type) ?values)) (fn [err] (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) @@ -167,14 +167,14 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx is-last? ?values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$VarT iid) (|do [:let [=var* (next-bound-type variant-type)] _ (&type/set-var iid =var*) variant-type* (&type/clean $var variant-type)] - (return (&type/Univ$ &/Nil$ variant-type*))) + (return (&/$UnivQ &/$Nil variant-type*))) _ (&type/clean $var variant-type))] @@ -182,7 +182,7 @@ variant-analysis)))))) _ - (analyse-variant analyse (&/V &/$Right exo-type*) idx is-last? ?values))) + (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) (&/$Right exo-type) (|do [exo-type* (|case exo-type @@ -217,19 +217,19 @@ _cursor &/cursor] (if (= 1 num-variant-types) (return (&/|list =value)) - (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$variant (&/T [idx is-last?* =value]))))) + (return (&/|list (&&/|meta exo-type _cursor (&&/$variant idx is-last?* =value)))) )) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/V &/$Right exo-type**) idx is-last? ?values)) + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) (&/$ExQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - =exprs (analyse-variant analyse (&/V &/$Right exo-type**) idx is-last? ?values)] + =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] (&/map% (partial &&/clean-analysis $var) =exprs)))) _ @@ -250,14 +250,14 @@ (&/$VarT id) (|do [? (&type/bound? id)] (if ? - (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) - (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + (analyse-tuple analyse (&/$Right exo-type) rec-members) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) _ (&type/check exo-type tuple-type)] (return (&/|list (&&/|meta exo-type tuple-cursor tuple-analysis)))))) _ - (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + (analyse-tuple analyse (&/$Right exo-type) rec-members) ))) (defn ^:private analyse-global [analyse exo-type module name] @@ -268,7 +268,7 @@ (&type/check exo-type endo-type)) _cursor &/cursor] (return (&/|list (&&/|meta endo-type _cursor - (&/V &&/$var (&/V &/$Global (&/T [r-module r-name]))) + (&&/$var (&/$Global (&/T [r-module r-name]))) ))))) (defn ^:private analyse-local [analyse exo-type name] @@ -295,16 +295,16 @@ (fail* (str "[Analyser Error] Unknown global definition: " name))) (&/$Cons top-outer _) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) + (|let [scopes (&/|tail (&/folds #(&/$Cons (&/get$ &/$name %2) %1) (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T [register* (&/Cons$ frame* new-inner)]))) + (&/T [register* (&/$Cons frame* new-inner)]))) (&/T [(or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - &/Nil$]) + &/$Nil]) (&/|reverse inner) scopes)] ((|do [_ (&type/check exo-type (&&/expr-type* =local))] (return (&/|list =local))) @@ -322,7 +322,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/T [fun-type &/Nil$]))) + (return (&/T [fun-type &/$Nil]))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -339,7 +339,7 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT 1))] + (|do [_ (&type/set-var ?id (&/$BoundT 1))] (&type/clean $var =output-t)))] (return (&/T [type** ==args]))) )))) @@ -355,7 +355,7 @@ (&&/analyse-1 analyse ?input-t ?arg) (fn [err] (fail (str err "\n" "[Analyser Error] Function expected: " (&type/show-type ?input-t)))))] - (return (&/T [=output-t (&/Cons$ =arg =args)]))) + (return (&/T [=output-t (&/$Cons =arg =args)]))) _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))) @@ -367,7 +367,7 @@ (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn] [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&&/|meta =output-t =fn-cursor - (&/V &&/$apply (&/T [=fn =args])) + (&&/$apply (&/T [=fn =args])) ))))) (defn analyse-apply [analyse exo-type =fn ?args] @@ -379,14 +379,14 @@ (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state))) - ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "jvm-import" r-name) - ;; ;; (= "@type" r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name))))] + :let [[r-prefix r-name] real-name + _ (when (or (= "defclass" r-name) + ;; (= "@type" r-name) + ) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) @@ -404,14 +404,14 @@ =value (&&/analyse-1+ analyse ?value) :let [var?? (|case =value [_ (&&/$var =var-kind)] - (&/Some$ =value) + (&/$Some =value) _ - &/None$)] + &/$None)] =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) (&/|as-pairs ?branches)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$case (&/T [=value =match])) + (&&/$case (&/T [=value =match])) ))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -426,7 +426,7 @@ (fn [$input] (&type/with-var (fn [$output] - (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body) =input (&type/resolve-type $input) =output (&type/resolve-type $output) inferred-type (|case =input @@ -435,7 +435,7 @@ _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] - (return (&type/Univ$ &/Nil$ (embed-inferred-input =input* =output**)))) + (return (&/$UnivQ &/$Nil (embed-inferred-input =input* =output**)))) _ (|do [=output* (&type/clean $input =output) @@ -468,7 +468,7 @@ (&&/analyse-1 analyse ?return-t ?body)) _cursor &/cursor] (return (&&/|meta exo-type* _cursor - (&/V &&/$lambda (&/T [=scope =captured =body]))))) + (&&/$lambda (&/T [=scope =captured =body]))))) @@ -515,8 +515,8 @@ ==meta (eval! =meta) _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) - _ (compile-token (&/V &&/$def (&/T [?name =value ==meta])))] - (return &/Nil$)) + _ (compile-token (&&/$def (&/T [?name =value ==meta])))] + (return &/$Nil)) ))) (defn analyse-import [analyse compile-module compile-token path] @@ -532,12 +532,12 @@ _ (if (not already-compiled?) (compile-module path) (return nil))] - (return &/Nil$))))) + (return &/$Nil))))) (defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] - (return &/Nil$))) + (return &/$Nil))) (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) @@ -546,7 +546,7 @@ =value (&&/analyse-1 analyse ==type ?value) _cursor &/cursor] (return (&/|list (&&/|meta ==type _cursor - (&/V &&/$ann (&/T [=value =type ==type])) + (&&/$ann (&/T [=value =type ==type])) ))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -556,5 +556,5 @@ =value (&&/analyse-1+ analyse ?value) _cursor &/cursor] (return (&/|list (&&/|meta ==type _cursor - (&/V &&/$coerce (&/T [=value =type ==type])) + (&&/$coerce (&/T [=value =type ==type])) ))))) diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj index 185391678..3f2016f27 100644 --- a/src/lux/analyser/meta.clj +++ b/src/lux/analyser/meta.clj @@ -7,7 +7,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]))) + (lux [base :as & :refer [|let |do return return* fail fail* |case]]))) ;; [Utils] (defn ^:private ident= [x y] @@ -24,11 +24,11 @@ (|case dict (&/$Cons [k v] dict*) (if (ident= k ident) - (&/Some$ v) + (&/$Some v) (meta-get ident dict*)) (&/$Nil) - &/None$ + &/$None _ (assert false (prn-str (&/adt->text ident) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 69635d4ad..1f980ba2c 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -9,14 +9,14 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] + (lux [base :as & :refer [deftuple |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]) [lux.host.generics :as &host-generics] (lux.analyser [meta :as &meta]))) ;; [Utils] -(deftags +(deftuple ["module-aliases" "defs" "imports" @@ -29,7 +29,7 @@ ;; "lux;defs" (&/|table) ;; "lux;imports" - &/Nil$ + &/$Nil ;; "lux;tags" (&/|table) ;; "lux;types" @@ -44,7 +44,7 @@ (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $imports (partial &/Cons$ module) m)) + (fn [m] (&/update$ $imports (partial &/$Cons module) m)) ms)) state) nil)))) diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index 8f142f86b..359894e75 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -38,18 +38,18 @@ (defn parse-gclass [ast] (|case ast [_ (&/$TextS "*")] - (return (&/V &/$GenericWildcard &/unit-tag)) + (return (&/$GenericWildcard &/unit-tag)) [_ (&/$TextS var-name)] - (return (&/V &/$GenericTypeVar var-name)) + (return (&/$GenericTypeVar var-name)) [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS params)] (&/$Nil))))] (|do [=params (&/map% parse-gclass params)] - (return (&/V &/$GenericClass (&/T [class-name =params])))) + (return (&/$GenericClass class-name =params))) [_ (&/$FormS (&/$Cons [_ (&/$TextS "Array")] (&/$Cons param (&/$Nil))))] (|do [=param (parse-gclass param)] - (return (&/V &/$GenericArray =param))) + (return (&/$GenericArray =param))) _ (fail (str "[Analyser Error] Not generic class: " (&/show-ast ast))))) @@ -85,7 +85,7 @@ [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] (&/$Cons ?finally-body (&/$Nil))))] - (return (&/T [catch+ (&/V &/$Some ?finally-body)])) + (return (&/T [catch+ (&/$Some ?finally-body)])) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token)))))) @@ -149,16 +149,16 @@ (defn parse-privacy-modifier [ast] (|case ast [_ (&/$TextS "default")] - (return (&/V &/$DefaultPM &/unit-tag)) + (return &/$DefaultPM) [_ (&/$TextS "public")] - (return (&/V &/$PublicPM &/unit-tag)) + (return &/$PublicPM) [_ (&/$TextS "protected")] - (return (&/V &/$ProtectedPM &/unit-tag)) + (return &/$ProtectedPM) [_ (&/$TextS "private")] - (return (&/V &/$PrivatePM &/unit-tag)) + (return &/$PrivatePM) _ (fail (str "[Analyser Error] Invalid privacy modifier: " (&/show-ast ast))))) @@ -166,13 +166,13 @@ (defn parse-state-modifier [ast] (|case ast [_ (&/$TextS "default")] - (return (&/V &/$DefaultSM &/unit-tag)) + (return &/$DefaultSM) [_ (&/$TextS "volatile")] - (return (&/V &/$VolatileSM &/unit-tag)) + (return &/$VolatileSM) [_ (&/$TextS "final")] - (return (&/V &/$FinalSM &/unit-tag)) + (return &/$FinalSM) _ (fail (str "[Analyser Error] Invalid state modifier: " (&/show-ast ast))))) @@ -180,13 +180,13 @@ (defn parse-inheritance-modifier [ast] (|case ast [_ (&/$TextS "default")] - (return (&/V &/$DefaultIM &/unit-tag)) + (return &/$DefaultIM) [_ (&/$TextS "abstract")] - (return (&/V &/$AbstractIM &/unit-tag)) + (return &/$AbstractIM) [_ (&/$TextS "final")] - (return (&/V &/$FinalIM &/unit-tag)) + (return &/$FinalIM) _ (fail (str "[Analyser Error] Invalid inheritance modifier: " (&/show-ast ast))))) @@ -207,7 +207,7 @@ =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =ctor-args (&/map% parse-ctor-arg ?ctor-args)] - (return (&/V &/$ConstructorMethodSyntax (&/T [=privacy-modifier =anns =gvars =exceptions =inputs =ctor-args body])))) + (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =anns =gvars =exceptions =inputs =ctor-args body])))) _ (fail ""))) @@ -230,7 +230,7 @@ =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$VirtualMethodSyntax (&/T [?name =privacy-modifier =final? =anns =gvars =exceptions =inputs =output body])))) + (return (&/$VirtualMethodSyntax (&/T [?name =privacy-modifier =final? =anns =gvars =exceptions =inputs =output body])))) _ (fail ""))) @@ -253,7 +253,7 @@ =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$OverridenMethodSyntax (&/T [=class-decl =name =anns =gvars =exceptions =inputs =output body])))) + (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =anns =gvars =exceptions =inputs =output body])))) _ (fail ""))) @@ -275,7 +275,7 @@ =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$StaticMethodSyntax (&/T [?name =privacy-modifier =anns =gvars =exceptions =inputs =output body])))) + (return (&/$StaticMethodSyntax (&/T [?name =privacy-modifier =anns =gvars =exceptions =inputs =output body])))) _ (fail ""))) @@ -295,7 +295,7 @@ =exceptions (&/map% parse-gclass exceptions) =inputs (&/map% parse-arg-decl inputs) =output (parse-gclass output)] - (return (&/V &/$AbstractMethodSyntax (&/T [?name =anns =gvars =exceptions =inputs =output])))) + (return (&/$AbstractMethodSyntax (&/T [?name =anns =gvars =exceptions =inputs =output])))) _ (fail ""))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 67cc78c0c..8c8c657dc 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -6,7 +6,7 @@ (ns lux.analyser.record (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return fail |case]] + (lux [base :as & :refer [|let |do return fail |case]] [type :as &type]) (lux.analyser [base :as &&] [module :as &&module]))) @@ -16,7 +16,7 @@ "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" (|do [[tag-group tag-type] (|case pairs (&/$Nil) - (return (&/T [&/Nil$ &type/Unit])) + (return (&/T [&/$Nil &/$UnitT])) (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1) diff --git a/src/lux/base.clj b/src/lux/base.clj index e3d0a049e..96c1a82a6 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -9,80 +9,119 @@ clojure.core.match.array)) ;; [Tags] -(defmacro deftags [names] +(def unit-tag (.intern (str (char 0) "unit" (char 0)))) + +(defn T [elems] + (case (count elems) + 0 + unit-tag + + 1 + (first elems) + + ;; else + (to-array elems))) + +(defmacro defvariant [& names] + (assert (> (count names) 1)) + `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) + :let [last-idx (dec (count names)) + is-last? (if (= idx last-idx) + "" + nil) + def-name (with-meta (symbol (str "$" name)) + {::idx idx + ::is-last? is-last?})]] + (cond (= 0 num-params) + `(def ~def-name + (to-array [(int ~idx) ~is-last? unit-tag])) + + (= 1 num-params) + `(defn ~def-name [arg#] + (to-array [(int ~idx) ~is-last? arg#])) + + :else + (let [g!args (map (fn [_] (gensym "arg")) + (range num-params))] + `(defn ~def-name [~@g!args] + (to-array [(int ~idx) ~is-last? (T [~@g!args])]))) + )))) + +(defmacro deftuple [names] (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) ~idx)))) + `(def ~(symbol (str "$" name)) + (int ~idx))))) ;; List -(deftags - ["Nil" - "Cons"]) +(defvariant + ("Nil" 0) + ("Cons" 2)) ;; Maybe -(deftags - ["None" - "Some"]) +(defvariant + ("None" 0) + ("Some" 1)) ;; Either -(deftags - ["Left" - "Right"]) +(defvariant + ("Left" 1) + ("Right" 1)) ;; AST -(deftags - ["BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS"]) +(defvariant + ("BoolS" 1) + ("IntS" 1) + ("RealS" 1) + ("CharS" 1) + ("TextS" 1) + ("SymbolS" 1) + ("TagS" 1) + ("FormS" 1) + ("TupleS" 1) + ("RecordS" 1)) ;; Type -(deftags - ["DataT" - "VoidT" - "UnitT" - "SumT" - "ProdT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "UnivQ" - "ExQ" - "AppT" - "NamedT"]) +(defvariant + ("DataT" 2) + ("VoidT" 0) + ("UnitT" 0) + ("SumT" 2) + ("ProdT" 2) + ("LambdaT" 2) + ("BoundT" 1) + ("VarT" 1) + ("ExT" 1) + ("UnivQ" 2) + ("ExQ" 2) + ("AppT" 2) + ("NamedT" 2)) ;; Vars -(deftags - ["Local" - "Global"]) +(defvariant + ("Local" 1) + ("Global" 1)) ;; Binding -(deftags +(deftuple ["counter" "mappings"]) ;; Env -(deftags +(deftuple ["name" "inner-closures" "locals" "closure"]) ;; ModuleState -(deftags - ["Active" - "Compiled" - "Cached"]) +(defvariant + ("Active" 0) + ("Compiled" 0) + ("Cached" 0)) ;; Host -(deftags +(deftuple ["writer" "loader" "classes" @@ -91,7 +130,7 @@ "type-env"]) ;; Compiler -(deftags +(deftuple ["source" "cursor" "modules" @@ -103,56 +142,56 @@ "host"]) ;; Compiler -(deftags - ["GenericTypeVar" - "GenericClass" - "GenericArray" - "GenericWildcard"]) +(defvariant + ("GenericTypeVar" 1) + ("GenericClass" 2) + ("GenericArray" 1) + ("GenericWildcard" 1)) ;; Privacy Modifiers -(deftags - ["DefaultPM" - "PublicPM" - "PrivatePM" - "ProtectedPM"]) +(defvariant + ("DefaultPM" 0) + ("PublicPM" 0) + ("PrivatePM" 0) + ("ProtectedPM" 0)) ;; State Modifiers -(deftags - ["DefaultSM" - "VolatileSM" - "FinalSM"]) +(defvariant + ("DefaultSM" 0) + ("VolatileSM" 0) + ("FinalSM" 0)) ;; Inheritance Modifiers -(deftags - ["DefaultIM" - "AbstractIM" - "FinalIM"]) +(defvariant + ("DefaultIM" 0) + ("AbstractIM" 0) + ("FinalIM" 0)) ;; Methods -(deftags - ["ConstructorMethodSyntax" - "VirtualMethodSyntax" - "OverridenMethodSyntax" - "StaticMethodSyntax" - "AbstractMethodSyntax"]) - -(deftags - ["ConstructorMethodAnalysis" - "VirtualMethodAnalysis" - "OverridenMethodAnalysis" - "StaticMethodAnalysis" - "AbstractMethodAnalysis"]) +(defvariant + ("ConstructorMethodSyntax" 1) + ("VirtualMethodSyntax" 1) + ("OverridenMethodSyntax" 1) + ("StaticMethodSyntax" 1) + ("AbstractMethodSyntax" 1)) + +(defvariant + ("ConstructorMethodAnalysis" 1) + ("VirtualMethodAnalysis" 1) + ("OverridenMethodAnalysis" 1) + ("StaticMethodAnalysis" 1) + ("AbstractMethodAnalysis" 1)) ;; Meta-data -(deftags - ["BoolM" - "IntM" - "RealM" - "CharM" - "TextM" - "IdentM" - "ListM" - "DictM"]) +(defvariant + ("BoolM" 1) + ("IntM" 1) + ("RealM" 1) + ("CharM" 1) + ("TextM" 1) + ("IdentM" 1) + ("ListM" 1) + ("DictM" 1)) ;; [Exports] (def name-field "_name") @@ -167,29 +206,8 @@ (def tags-field "_tags") (def module-class-name "_") (def +name-separator+ ";") -(def unit-tag (.intern (str (char 0) "unit" (char 0)))) - -(defn T [elems] - (case (count elems) - 0 - unit-tag - - 1 - (first elems) - - ;; else - (to-array elems))) - -(defn V [^Long tag value] - (to-array [(int tag) nil value])) ;; Constructors -(def None$ (V $None unit-tag)) -(defn Some$ [x] (V $Some x)) - -(def Nil$ (V $Nil unit-tag)) -(defn Cons$ [h t] (V $Cons (T [h t]))) - (def empty-cursor (T ["" -1 -1])) (defn get$ [slot ^objects record] @@ -205,10 +223,10 @@ record#))) (defn fail* [message] - (V $Left message)) + ($Left message)) (defn return* [state value] - (V $Right (T [state value]))) + ($Right (T [state value]))) (defn transform-pattern [pattern] (cond (vector? pattern) (case (count pattern) @@ -220,7 +238,9 @@ ;; else (mapv transform-pattern pattern)) - (seq? pattern) [(eval (first pattern)) + (seq? pattern) [(-> (ns-resolve *ns* (first pattern)) + meta + ::idx) '_ (transform-pattern (vec (rest pattern)))] :else pattern @@ -247,14 +267,14 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V $Cons (T [~head ~tail]))) - `Nil$ + `($Cons ~head ~tail)) + `$Nil (reverse elems))) (defmacro |table [& elems] (reduce (fn [table [k v]] `(|put ~k ~v ~table)) - `Nil$ + `$Nil (reverse (partition 2 elems)))) (defn |get [slot table] @@ -270,12 +290,12 @@ (defn |put [slot value table] (|case table ($Nil) - (V $Cons (T [(T [slot value]) Nil$])) + ($Cons (T [slot value]) $Nil) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V $Cons (T [(T [slot value]) table*])) - (V $Cons (T [(T [k v]) (|put slot value table*)]))) + ($Cons (T [slot value]) table*) + ($Cons (T [k v]) (|put slot value table*))) )) (defn |remove [slot table] @@ -286,7 +306,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V $Cons (T [(T [k v]) (|remove slot table*)]))))) + ($Cons (T [k v]) (|remove slot table*))))) (defn |update [k f table] (|case table @@ -295,8 +315,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V $Cons (T [(T [k* (f v)]) table*])) - (V $Cons (T [(T [k* v]) (|update k f table*)]))))) + ($Cons (T [k* (f v)]) table*) + ($Cons (T [k* v]) (|update k f table*))))) (defn |head [xs] (|case xs @@ -317,11 +337,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V $Left message))) + ($Left message))) (defn return [value] (fn [state] - (V $Right (T [state value])))) + ($Right (T [state value])))) (defn bind [m-value step] (fn [state] @@ -361,7 +381,7 @@ ys ($Cons x xs*) - (V $Cons (T [x (|++ xs* ys)])))) + ($Cons x (|++ xs* ys)))) (defn |map [f xs] (|case xs @@ -369,7 +389,7 @@ xs ($Cons x xs*) - (V $Cons (T [(f x) (|map f xs*)])))) + ($Cons (f x) (|map f xs*)))) (defn |empty? [xs] "(All [a] (-> (List a) Bool))" @@ -388,7 +408,7 @@ ($Cons x xs*) (if (p x) - (V $Cons (T [x (|filter p xs*)])) + ($Cons x (|filter p xs*)) (|filter p xs*)))) (defn flat-map [f xs] @@ -408,8 +428,8 @@ ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T [(Cons$ x pre) post])) - (T [Nil$ xs])))) + (T [($Cons x pre) post])) + (T [$Nil xs])))) (defn |contains? [k table] (|case table @@ -451,15 +471,15 @@ (|list init) ($Cons x xs*) - (Cons$ init (folds f (f init x) xs*)))) + ($Cons init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (V $Cons (T [from (|range* (inc from) to)])) - Nil$))] + ($Cons from (|range* (inc from) to)) + $Nil))] (defn |range [n] (|range* 0 n))) @@ -474,26 +494,26 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V $Cons (T [(T [x y]) (zip2 xs* ys*)])) + ($Cons (T [x y]) (zip2 xs* ys*)) [_ _] - Nil$)) + $Nil)) (defn |keys [plist] (|case plist ($Nil) - Nil$ + $Nil ($Cons [k v] plist*) - (Cons$ k (|keys plist*)))) + ($Cons k (|keys plist*)))) (defn |vals [plist] (|case plist ($Nil) - Nil$ + $Nil ($Cons [k v] plist*) - (Cons$ v (|vals plist*)))) + ($Cons v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -504,7 +524,7 @@ xs ($Cons x xs*) - (V $Cons (T [x (V $Cons (T [sep (|interpose sep xs*)]))])))) + ($Cons x ($Cons sep (|interpose sep xs*))))) (do-template [ ] (defn [f xs] @@ -517,24 +537,24 @@ ys ( f xs*)] (return ( y ys))))) - map% Cons$ + map% $Cons flat-map% |++) (defn list-join [xss] - (fold |++ Nil$ xss)) + (fold |++ $Nil xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V $Cons (T [(T [x y]) (|as-pairs xs*)])) + ($Cons (T [x y]) (|as-pairs xs*)) _ - Nil$)) + $Nil)) (defn |reverse [xs] (fold (fn [tail head] - (Cons$ head tail)) - Nil$ + ($Cons head tail)) + $Nil xs)) (defn assert! [test message] @@ -569,8 +589,8 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (Cons$ head tail))) - (return Nil$)))) + (return ($Cons head tail))) + (return $Nil)))) (defn exhaust% [step] (fn [state] @@ -668,13 +688,13 @@ (defn host [_] (let [store (atom {})] (T [;; "lux;writer" - (V $None unit-tag) + $None ;; "lux;loader" (memory-class-loader store) ;; "lux;classes" store ;; "lux;catching" - Nil$ + $Nil ;; "lux;module-states" (|table) ;; lux;type-env @@ -682,17 +702,17 @@ (defn init-state [_] (T [;; "lux;source" - (V $None unit-tag) + $None ;; "lux;cursor" (T ["" -1 -1]) ;; "lux;modules" (|table) ;; "lux;envs" - Nil$ + $Nil ;; "lux;types" +init-bindings+ ;; "lux;expected" - (V $VoidT unit-tag) + $VoidT ;; "lux;seed" 0 ;; "lux;eval?" @@ -758,13 +778,13 @@ (defn ->list [seq] (if (empty? seq) - Nil$ - (Cons$ (first seq) (->list (rest seq))))) + $Nil + ($Cons (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (Cons$ x (|repeat (dec n) x)) - Nil$)) + ($Cons x (|repeat (dec n) x)) + $Nil)) (def get-module-name (fn [state] @@ -789,7 +809,7 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(Cons$ (env name) %) state))] + (let [output (body (update$ $envs #($Cons (env name) %) state))] (|case output ($Right state* datum) (return* (update$ $envs |tail state*) datum) @@ -805,7 +825,7 @@ (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(Cons$ (update$ $inner-closures inc (|head %)) + (run-state body* (update$ $envs #($Cons (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) @@ -816,7 +836,7 @@ (defn with-writer [writer body] (fn [state] (let [old-writer (->> state (get$ $host) (get$ $writer)) - output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + output (body (update$ $host #(set$ $writer ($Some writer) %) state))] (|case output ($Right ?state ?value) (return* (update$ $host #(set$ $writer old-writer %) ?state) @@ -922,10 +942,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (Cons$ z zs))) + (return ($Cons z zs))) [($Nil) ($Nil)] - (return Nil$) + (return $Nil) [_ _] (fail "Lists don't match in size."))) @@ -933,10 +953,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (f x y) (map2 f xs* ys*)) + ($Cons (f x y) (map2 f xs* ys*)) [_ _] - Nil$)) + $Nil)) (defn fold2 [f init xs ys] (|case [xs ys] @@ -956,8 +976,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (V $Cons (T [(T [idx x]) - (enumerate* (inc idx) xs*)])) + ($Cons (T [idx x]) + (enumerate* (inc idx) xs*)) ($Nil) xs @@ -983,16 +1003,16 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - (V $None unit-tag) + $None (= idx 0) - (V $Some x) + ($Some x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - (V $None unit-tag) + $None )) (defn normalize [ident] @@ -1011,14 +1031,14 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - (V $None unit-tag) + $None ($Cons x xs*) (if (= idx 0) - (V $Some (V $Cons (T [val xs*]))) + ($Some ($Cons val xs*)) (|case (|list-put (dec idx) val xs*) - ($None) (V $None unit-tag) - ($Some xs**) (V $Some (V $Cons (T [x xs**])))) + ($None) $None + ($Some xs**) ($Some ($Cons x xs**))) ))) (do-template [ ] @@ -1028,18 +1048,18 @@ (let [state* (update$ $host (fn [host] (update$ $module-states (fn [module-states] - (|put module (V unit-tag) module-states)) + (|put module module-states)) host)) state)] - (V $Right (T [state* unit-tag]))))) + ($Right (T [state* unit-tag]))))) (defn [module] "(-> Text (Lux Bool))" (fn [state] (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] - (V $Right (T [state (|case module-state - () true - _ false)])) - (V $Right (T [state false]))) + ($Right (T [state (|case module-state + () true + _ false)])) + ($Right (T [state false]))) ))) flag-active-module active-module? $Active @@ -1080,7 +1100,7 @@ "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" (|case xs ($Nil) - None$ + $None ($Cons x xs*) (|case (f x) @@ -1100,26 +1120,26 @@ state)] (|case (body state*) ($Right [state** output]) - (V $Right (T [(update$ $host - #(set$ $type-env - (->> state (get$ $host) (get$ $type-env)) - %) - state**) - output])) + ($Right (T [(update$ $host + #(set$ $type-env + (->> state (get$ $host) (get$ $type-env)) + %) + state**) + output])) ($Left msg) - (V $Left msg))))) + ($Left msg))))) (defn |take [n xs] (|case (T [n xs]) - [0 _] Nil$ - [_ ($Nil)] Nil$ - [_ ($Cons x xs*)] (Cons$ x (|take (dec n) xs*)) + [0 _] $Nil + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*)) )) (defn |drop [n xs] (|case (T [n xs]) [0 _] xs - [_ ($Nil)] Nil$ + [_ ($Nil)] $Nil [_ ($Cons x xs*)] (|drop (dec n) xs*) )) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 38592d16f..93f8bf3e9 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -98,7 +98,7 @@ _ (load _import (hash content) compile-module)] (&/cached-module? _import))) (if (= [""] imports) - &/Nil$ + &/$Nil (&/->list imports)))] (if (->> loads &/->seq (every? true?)) (do (doseq [^File file (seq (.listFiles (File. module-path))) @@ -111,7 +111,7 @@ (let [defs (string/split (get-field &/defs-field module-meta) def-separator-re) tag-groups (let [all-tags (get-field &/tags-field module-meta)] (if (= "" all-tags) - &/Nil$ + &/$Nil (-> all-tags (string/split tag-group-separator-re) (->> (map (fn [_group] @@ -137,12 +137,12 @@ (let [[_ __module __name] (re-find #"^(.*);(.*)$" _alias) def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) def-type (get-field &/type-field def-class) - def-meta (&/|list (&/T [&a-meta/alias-tag (&/V &/$IdentM (&/T [__module __name]))])) + def-meta (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) def-value (get-field &/value-field def-class)] (&a-module/define module _name def-type def-meta def-value))) )) (if (= [""] defs) - &/Nil$ + &/$Nil (&/->list defs))) _ (&/map% (fn [group] (|let [[_type _tags] group] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index c7a7145f8..cd672b5ec 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -118,27 +118,33 @@ (&a-case/$VariantTestAC ?tag ?count ?test) (if (= 1 ?count) (compile-match ?test $target $else) - (let [$variant-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?tag)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "sum_get" "([Ljava/lang/Object;I)Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/ACONST_NULL) - (.visitJumpInsn Opcodes/IF_ACMPEQ $variant-else) - (-> (doto (compile-match ?test $value-then $value-else) - (.visitLabel $value-then) + (let [is-last (= ?tag (dec ?count)) + $variant-else (new Label) + _ (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int ?tag))) + _ (if is-last + (.visitLdcInsn writer "") + (.visitInsn writer Opcodes/ACONST_NULL)) + _ (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/IF_ACMPEQ $variant-else) + (-> (doto (compile-match ?test $value-then $value-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $value-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else)) + (->> (let [$value-then (new Label) + $value-else (new Label)]))) + (.visitLabel $variant-else) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $value-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)) - (->> (let [$value-then (new Label) - $value-else (new Label)]))) - (.visitLabel $variant-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)))) + (.visitJumpInsn Opcodes/GOTO $else))] + writer)) )) (defn ^:private separate-bodies [patterns] @@ -167,7 +173,8 @@ (.visitInsn Opcodes/POP) (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "()V") + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") (.visitInsn Opcodes/ATHROW)) (&/map% (fn [?label+?body] (|let [[?label ?body] ?label+?body] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 6cfc87864..76e88e79f 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -497,7 +497,7 @@ (defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def] (|case method-def (&/$ConstructorMethodAnalysis ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|let [?output (&/V &/$GenericClass (&/T ["void" (&/|list)])) + (|let [?output (&/$GenericClass "void" (&/|list)) =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] (&/with-writer (.visitMethod class-writer @@ -680,7 +680,7 @@ (|do [module &/get-module-name [file-name line column] &/cursor :let [[?name ?params] class-decl - class-signature (&host-generics/gclass-decl->signature class-decl (&/Cons$ ?super-class ?interfaces)) + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) full-name (str module "/" ?name) super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -718,7 +718,7 @@ (&&/save-class! interface-name (.toByteArray =interface)))) (def compile-Function-class - (let [object-class (&/V &/$GenericClass (&/T ["java.lang.Object" (&/|list)])) + (let [object-class (&/$GenericClass "java.lang.Object" (&/|list)) interface-decl (&/T [(second (string/split &&/function-class #"/")) (&/|list)]) ?supers (&/|list) ?anns (&/|list) @@ -752,6 +752,7 @@ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) (.visitCode) (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) (.visitVarInsn Opcodes/ALOAD 0) ;; tuple (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index @@ -786,6 +787,7 @@ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) (.visitCode) (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) (.visitVarInsn Opcodes/ALOAD 0) ;; tuple (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index @@ -812,6 +814,7 @@ (.visitVarInsn Opcodes/ASTORE 0) ;; (.visitJumpInsn Opcodes/GOTO $begin) (.visitLabel $must-copy) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ILOAD 1) (.visitVarInsn Opcodes/ALOAD 0) @@ -828,13 +831,14 @@ (.visitMaxs 0 0) (.visitEnd))) =sum-get-method (let [$begin (new Label) + $just-return (new Label) $then (new Label) $further (new Label) $not-right (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) (.visitCode) - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 0) (to-array [])) (.visitVarInsn Opcodes/ILOAD 1) ;; tag (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx @@ -848,14 +852,22 @@ (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN) (.visitLabel $then) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) (.visitInsn Opcodes/POP2) (.visitVarInsn Opcodes/ALOAD 0) (.visitLdcInsn (int 2)) (.visitInsn Opcodes/AALOAD) (.visitInsn Opcodes/ARETURN) (.visitLabel $further) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? @@ -869,7 +881,7 @@ (.visitVarInsn Opcodes/ISTORE 1) ;; (.visitJumpInsn Opcodes/GOTO $begin) (.visitLabel $not-right) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) (.visitInsn Opcodes/POP2) (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 80bf065da..3003a0335 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -126,7 +126,7 @@ [[?def-type ?def-cursor] ?def-value] (if (&type/type= &type/Type ?def-type) (&/T [(&/T [?def-type ?def-cursor]) - (&/V &a/$tuple (&/|list))]) + (&a/$tuple (&/|list))]) (&&type/type->analysis ?def-type)))]] (compile ?def-type))) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 8a63aaa17..2b9542919 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -14,19 +14,20 @@ ;; [Utils] (defn ^:private variant$ [tag body] "(-> Int Analysis Analysis)" - (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$variant (&/T [tag false body])))) + (let [tag-meta (meta tag)] + (&a/|meta &/$VoidT &/empty-cursor + (&a/$variant (::&/idx tag-meta) (::&/is-last? tag-meta) body)))) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$tuple members))) + (&a/|meta &/$VoidT &/empty-cursor + (&a/$tuple members))) (do-template [ ] (defn [value] - (&a/|meta &type/$Void &/empty-cursor - (&/V value))) + (&a/|meta &/$VoidT &/empty-cursor + ( value))) ^:private bool$ &a/$bool "(-> Bool Analysis)" ^:private int$ &a/$int "(-> Int Analysis)" @@ -42,11 +43,11 @@ (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ &/Nil$))) + (variant$ #'&/$Nil (tuple$ &/$Nil))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ &/$Cons (tuple$ (&/|list head tail)))) + (variant$ #'&/$Cons (tuple$ (&/|list head tail)))) (defn ^:private List$ [elems] (&/fold (fn [tail head] @@ -59,38 +60,38 @@ "(-> Type Analysis)" (|case type (&/$DataT class params) - (variant$ &/$DataT (tuple$ (&/|list (text$ class) - (List$ (&/|map type->analysis params))))) + (variant$ #'&/$DataT (tuple$ (&/|list (text$ class) + (List$ (&/|map type->analysis params))))) (&/$VoidT) - (variant$ &/$VoidT (tuple$ (&/|list))) + (variant$ #'&/$VoidT (tuple$ (&/|list))) (&/$UnitT) - (variant$ &/$UnitT (tuple$ (&/|list))) + (variant$ #'&/$UnitT (tuple$ (&/|list))) (&/$ProdT left right) - (variant$ &/$ProdT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) + (variant$ #'&/$ProdT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) (&/$SumT left right) - (variant$ &/$SumT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) + (variant$ #'&/$SumT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) (&/$LambdaT input output) - (variant$ &/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output)))) + (variant$ #'&/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output)))) (&/$UnivQ env body) - (variant$ &/$UnivQ + (variant$ #'&/$UnivQ (tuple$ (&/|list (List$ (&/|map type->analysis env)) (type->analysis body)))) (&/$BoundT idx) - (variant$ &/$BoundT (int$ idx)) + (variant$ #'&/$BoundT (int$ idx)) (&/$AppT fun arg) - (variant$ &/$AppT (tuple$ (&/|list (type->analysis fun) (type->analysis arg)))) + (variant$ #'&/$AppT (tuple$ (&/|list (type->analysis fun) (type->analysis arg)))) (&/$NamedT [module name] type*) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) - (type->analysis type*)))) + (variant$ #'&/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) + (type->analysis type*)))) _ (assert false (prn 'type->analysis (&/adt->text type))) @@ -100,28 +101,28 @@ "(-> DefMetaValue Analysis)" (|case dmv (&/$BoolM value) - (variant$ &/$BoolM (bool$ value)) + (variant$ #'&/$BoolM (bool$ value)) (&/$IntM value) - (variant$ &/$IntM (int$ value)) + (variant$ #'&/$IntM (int$ value)) (&/$RealM value) - (variant$ &/$RealM (real$ value)) + (variant$ #'&/$RealM (real$ value)) (&/$CharM value) - (variant$ &/$CharM (char$ value)) + (variant$ #'&/$CharM (char$ value)) (&/$TextM value) - (variant$ &/$TextM (text$ value)) + (variant$ #'&/$TextM (text$ value)) (&/$IdentM value) - (variant$ &/$IdentM (ident$ value)) + (variant$ #'&/$IdentM (ident$ value)) (&/$ListM xs) - (variant$ &/$ListM (List$ (&/|map defmetavalue->analysis xs))) + (variant$ #'&/$ListM (List$ (&/|map defmetavalue->analysis xs))) (&/$DictM kvs) - (variant$ &/$DictM + (variant$ #'&/$DictM (List$ (&/|map (fn [kv] (|let [[k v] kv] (tuple$ (&/|list (text$ k) diff --git a/src/lux/host.clj b/src/lux/host.clj index abcd830c8..8b8996f52 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -155,7 +155,7 @@ (str (&/normalize-name name) "_" (hash name))) (defn location [scope] - (let [scope (&/Cons$ (def-name (&/|head scope)) + (let [scope (&/$Cons (def-name (&/|head scope)) (&/|map &/normalize-name (&/|tail scope)))] (->> scope (&/|interpose "$") @@ -274,7 +274,7 @@ (defn ^:private compile-dummy-method [^ClassWriter =class super-class method-def] (|case method-def (&/$ConstructorMethodSyntax =privacy-modifier =anns =gvars =exceptions =inputs =ctor-args body) - (|let [=output (&/V &/$GenericClass (&/T ["void" (&/|list)])) + (|let [=output (&/$GenericClass "void" (&/|list)) method-decl [init-method-name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC @@ -368,7 +368,7 @@ (|do [module &/get-module-name :let [[?name ?params] class-decl full-name (str module "/" ?name) - class-signature (&host-generics/gclass-decl->signature class-decl (&/Cons$ super-class interfaces)) + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) full-name diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 74efc9fc4..bac8675de 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -6,27 +6,27 @@ (ns lux.lexer (:require (clojure [template :refer [do-template]] [string :as string]) - (lux [base :as & :refer [deftags |do return* return fail fail*]] + (lux [base :as & :refer [defvariant |do return* return fail fail*]] [reader :as &reader]) [lux.analyser.module :as &module])) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(defvariant + ("White_Space" 1) + ("Comment" 1) + ("Bool" 1) + ("Int" 1) + ("Real" 1) + ("Char" 1) + ("Text" 1) + ("Symbol" 1) + ("Tag" 1) + ("Open_Paren" 0) + ("Close_Paren" 0) + ("Open_Bracket" 0) + ("Close_Bracket" 0) + ("Open_Brace" 0) + ("Close_Brace" 0) ) ;; [Utils] @@ -83,7 +83,7 @@ :let [[_ _ _column] meta] token (lex-text-body (inc _column)) _ (&reader/read-text "\"")] - (return (&/T [meta (&/V $Text token)])))) + (return (&/T [meta ($Text token)])))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)" ;; #"^([^0-9\[\]\(\)\{\};#\s\"][^\[\]\(\)\{\};#\s\"]*)" @@ -92,12 +92,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] - (return (&/T [meta (&/V $White_Space white-space)])))) + (return (&/T [meta ($White_Space white-space)])))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta _ comment] (&reader/read-regex #"^(.*)$")] - (return (&/T [meta (&/V $Comment comment)])))) + (return (&/T [meta ($Comment comment)])))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -108,7 +108,7 @@ [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] (return (&/T [meta (str pre "#(" inner ")#" post)]))))) _ (&reader/read-text ")#")] - (return (&/T [meta (&/V $Comment comment)])))) + (return (&/T [meta ($Comment comment)])))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -117,7 +117,7 @@ (do-template [ ] (def (|do [[meta _ token] (&reader/read-regex )] - (return (&/T [meta (&/V token)])))) + (return (&/T [meta ( token)])))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^-?(0|[1-9][0-9]*)" @@ -131,7 +131,7 @@ (|do [[_ _ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/T [meta (&/V $Char token)])))) + (return (&/T [meta ($Char token)])))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+)] @@ -155,17 +155,17 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/T [meta (&/V $Symbol ident)])))) + (return (&/T [meta ($Symbol ident)])))) (def ^:private lex-tag (|do [[meta _ _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/T [meta (&/V $Tag ident)])))) + (return (&/T [meta ($Tag ident)])))) (do-template [ ] (def (|do [[meta _ _] (&reader/read-text )] - (return (&/T [meta (&/V &/unit-tag)])))) + (return (&/T [meta ])))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 66245750c..8f4625c6b 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -4,528 +4,528 @@ ;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.optimizer - (:require (lux [base :as & :refer [|let |do return fail return* fail* |case deftags]] + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]] [analyser :as &analyser]) [lux.analyser.base :as &-base])) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "coerce" - "def" - "declare-macro" - "var" - "captured" +(defvariant + ("bool" 1) + ("int" 1) + ("real" 1) + ("char" 1) + ("text" 1) + ("variant" 1) + ("tuple" 1) + ("apply" 1) + ("case" 1) + ("lambda" 1) + ("ann" 1) + ("coerce" 1) + ("def" 1) + ("declare-macro" 1) + ("var" 1) + ("captured" 1) - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" + ("jvm-getstatic" 1) + ("jvm-getfield" 1) + ("jvm-putstatic" 1) + ("jvm-putfield" 1) + ("jvm-invokestatic" 1) + ("jvm-instanceof" 1) + ("jvm-invokevirtual" 1) + ("jvm-invokeinterface" 1) + ("jvm-invokespecial" 1) + ("jvm-null?" 1) + ("jvm-null" 1) + ("jvm-new" 1) + ("jvm-class" 1) + ("jvm-interface" 1) + ("jvm-try" 1) + ("jvm-throw" 1) + ("jvm-monitorenter" 1) + ("jvm-monitorexit" 1) + ("jvm-program" 1) - "jvm-znewarray" - "jvm-zastore" - "jvm-zaload" - "jvm-bnewarray" - "jvm-bastore" - "jvm-baload" - "jvm-snewarray" - "jvm-sastore" - "jvm-saload" - "jvm-inewarray" - "jvm-iastore" - "jvm-iaload" - "jvm-lnewarray" - "jvm-lastore" - "jvm-laload" - "jvm-fnewarray" - "jvm-fastore" - "jvm-faload" - "jvm-dnewarray" - "jvm-dastore" - "jvm-daload" - "jvm-cnewarray" - "jvm-castore" - "jvm-caload" - "jvm-anewarray" - "jvm-aastore" - "jvm-aaload" - "jvm-arraylength" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" + ("jvm-znewarray" 1) + ("jvm-zastore" 1) + ("jvm-zaload" 1) + ("jvm-bnewarray" 1) + ("jvm-bastore" 1) + ("jvm-baload" 1) + ("jvm-snewarray" 1) + ("jvm-sastore" 1) + ("jvm-saload" 1) + ("jvm-inewarray" 1) + ("jvm-iastore" 1) + ("jvm-iaload" 1) + ("jvm-lnewarray" 1) + ("jvm-lastore" 1) + ("jvm-laload" 1) + ("jvm-fnewarray" 1) + ("jvm-fastore" 1) + ("jvm-faload" 1) + ("jvm-dnewarray" 1) + ("jvm-dastore" 1) + ("jvm-daload" 1) + ("jvm-cnewarray" 1) + ("jvm-castore" 1) + ("jvm-caload" 1) + ("jvm-anewarray" 1) + ("jvm-aastore" 1) + ("jvm-aaload" 1) + ("jvm-arraylength" 1) + + ("jvm-iadd" 1) + ("jvm-isub" 1) + ("jvm-imul" 1) + ("jvm-idiv" 1) + ("jvm-irem" 1) + ("jvm-ieq" 1) + ("jvm-ilt" 1) + ("jvm-igt" 1) - "jvm-ceq" - "jvm-clt" - "jvm-cgt" + ("jvm-ceq" 1) + ("jvm-clt" 1) + ("jvm-cgt" 1) - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" + ("jvm-ladd" 1) + ("jvm-lsub" 1) + ("jvm-lmul" 1) + ("jvm-ldiv" 1) + ("jvm-lrem" 1) + ("jvm-leq" 1) + ("jvm-llt" 1) + ("jvm-lgt" 1) - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" + ("jvm-fadd" 1) + ("jvm-fsub" 1) + ("jvm-fmul" 1) + ("jvm-fdiv" 1) + ("jvm-frem" 1) + ("jvm-feq" 1) + ("jvm-flt" 1) + ("jvm-fgt" 1) - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" + ("jvm-dadd" 1) + ("jvm-dsub" 1) + ("jvm-dmul" 1) + ("jvm-ddiv" 1) + ("jvm-drem" 1) + ("jvm-deq" 1) + ("jvm-dlt" 1) + ("jvm-dgt" 1) - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" + ("jvm-d2f" 1) + ("jvm-d2i" 1) + ("jvm-d2l" 1) - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" + ("jvm-f2d" 1) + ("jvm-f2i" 1) + ("jvm-f2l" 1) - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" + ("jvm-i2b" 1) + ("jvm-i2c" 1) + ("jvm-i2d" 1) + ("jvm-i2f" 1) + ("jvm-i2l" 1) + ("jvm-i2s" 1) - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" + ("jvm-l2d" 1) + ("jvm-l2f" 1) + ("jvm-l2i" 1) - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" + ("jvm-iand" 1) + ("jvm-ior" 1) + ("jvm-ixor" 1) + ("jvm-ishl" 1) + ("jvm-ishr" 1) + ("jvm-iushr" 1) - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr"]) + ("jvm-land" 1) + ("jvm-lor" 1) + ("jvm-lxor" 1) + ("jvm-lshl" 1) + ("jvm-lshr" 1) + ("jvm-lushr" 1)) (defn ^:private optimize-token [analysis] "(-> Analysis Optimized)" (|case analysis (&-base/$bool value) - (return (&/V $bool value)) + (return ($bool value)) (&-base/$int value) - (return (&/V $int value)) + (return ($int value)) (&-base/$real value) - (return (&/V $real value)) + (return ($real value)) (&-base/$char value) - (return (&/V $char value)) + (return ($char value)) (&-base/$text value) - (return (&/V $text value)) + (return ($text value)) (&-base/$variant value) - (return (&/V $variant value)) + (return ($variant value)) (&-base/$tuple value) - (return (&/V $tuple value)) + (return ($tuple value)) (&-base/$apply value) - (return (&/V $apply value)) + (return ($apply value)) (&-base/$case value) - (return (&/V $case value)) + (return ($case value)) (&-base/$lambda value) - (return (&/V $lambda value)) + (return ($lambda value)) (&-base/$ann value) - (return (&/V $ann value)) + (return ($ann value)) (&-base/$coerce value) - (return (&/V $coerce value)) + (return ($coerce value)) (&-base/$def value) - (return (&/V $def value)) + (return ($def value)) (&-base/$declare-macro value) - (return (&/V $declare-macro value)) + (return ($declare-macro value)) (&-base/$var value) - (return (&/V $var value)) + (return ($var value)) (&-base/$captured value) - (return (&/V $captured value)) + (return ($captured value)) (&-base/$jvm-getstatic value) - (return (&/V $jvm-getstatic value)) + (return ($jvm-getstatic value)) (&-base/$jvm-getfield value) - (return (&/V $jvm-getfield value)) + (return ($jvm-getfield value)) (&-base/$jvm-putstatic value) - (return (&/V $jvm-putstatic value)) + (return ($jvm-putstatic value)) (&-base/$jvm-putfield value) - (return (&/V $jvm-putfield value)) + (return ($jvm-putfield value)) (&-base/$jvm-invokestatic value) - (return (&/V $jvm-invokestatic value)) + (return ($jvm-invokestatic value)) (&-base/$jvm-instanceof value) - (return (&/V $jvm-instanceof value)) + (return ($jvm-instanceof value)) (&-base/$jvm-invokevirtual value) - (return (&/V $jvm-invokevirtual value)) + (return ($jvm-invokevirtual value)) (&-base/$jvm-invokeinterface value) - (return (&/V $jvm-invokeinterface value)) + (return ($jvm-invokeinterface value)) (&-base/$jvm-invokespecial value) - (return (&/V $jvm-invokespecial value)) + (return ($jvm-invokespecial value)) (&-base/$jvm-null? value) - (return (&/V $jvm-null? value)) + (return ($jvm-null? value)) (&-base/$jvm-null value) - (return (&/V $jvm-null value)) + (return ($jvm-null value)) (&-base/$jvm-new value) - (return (&/V $jvm-new value)) + (return ($jvm-new value)) (&-base/$jvm-class value) - (return (&/V $jvm-class value)) + (return ($jvm-class value)) (&-base/$jvm-interface value) - (return (&/V $jvm-interface value)) + (return ($jvm-interface value)) (&-base/$jvm-try value) - (return (&/V $jvm-try value)) + (return ($jvm-try value)) (&-base/$jvm-throw value) - (return (&/V $jvm-throw value)) + (return ($jvm-throw value)) (&-base/$jvm-monitorenter value) - (return (&/V $jvm-monitorenter value)) + (return ($jvm-monitorenter value)) (&-base/$jvm-monitorexit value) - (return (&/V $jvm-monitorexit value)) + (return ($jvm-monitorexit value)) (&-base/$jvm-program value) - (return (&/V $jvm-program value)) + (return ($jvm-program value)) (&-base/$jvm-znewarray value) - (return (&/V $jvm-znewarray value)) + (return ($jvm-znewarray value)) (&-base/$jvm-zastore value) - (return (&/V $jvm-zastore value)) + (return ($jvm-zastore value)) (&-base/$jvm-zaload value) - (return (&/V $jvm-zaload value)) + (return ($jvm-zaload value)) (&-base/$jvm-bnewarray value) - (return (&/V $jvm-bnewarray value)) + (return ($jvm-bnewarray value)) (&-base/$jvm-bastore value) - (return (&/V $jvm-bastore value)) + (return ($jvm-bastore value)) (&-base/$jvm-baload value) - (return (&/V $jvm-baload value)) + (return ($jvm-baload value)) (&-base/$jvm-snewarray value) - (return (&/V $jvm-snewarray value)) + (return ($jvm-snewarray value)) (&-base/$jvm-sastore value) - (return (&/V $jvm-sastore value)) + (return ($jvm-sastore value)) (&-base/$jvm-saload value) - (return (&/V $jvm-saload value)) + (return ($jvm-saload value)) (&-base/$jvm-inewarray value) - (return (&/V $jvm-inewarray value)) + (return ($jvm-inewarray value)) (&-base/$jvm-iastore value) - (return (&/V $jvm-iastore value)) + (return ($jvm-iastore value)) (&-base/$jvm-iaload value) - (return (&/V $jvm-iaload value)) + (return ($jvm-iaload value)) (&-base/$jvm-lnewarray value) - (return (&/V $jvm-lnewarray value)) + (return ($jvm-lnewarray value)) (&-base/$jvm-lastore value) - (return (&/V $jvm-lastore value)) + (return ($jvm-lastore value)) (&-base/$jvm-laload value) - (return (&/V $jvm-laload value)) + (return ($jvm-laload value)) (&-base/$jvm-fnewarray value) - (return (&/V $jvm-fnewarray value)) + (return ($jvm-fnewarray value)) (&-base/$jvm-fastore value) - (return (&/V $jvm-fastore value)) + (return ($jvm-fastore value)) (&-base/$jvm-faload value) - (return (&/V $jvm-faload value)) + (return ($jvm-faload value)) (&-base/$jvm-dnewarray value) - (return (&/V $jvm-dnewarray value)) + (return ($jvm-dnewarray value)) (&-base/$jvm-dastore value) - (return (&/V $jvm-dastore value)) + (return ($jvm-dastore value)) (&-base/$jvm-daload value) - (return (&/V $jvm-daload value)) + (return ($jvm-daload value)) (&-base/$jvm-cnewarray value) - (return (&/V $jvm-cnewarray value)) + (return ($jvm-cnewarray value)) (&-base/$jvm-castore value) - (return (&/V $jvm-castore value)) + (return ($jvm-castore value)) (&-base/$jvm-caload value) - (return (&/V $jvm-caload value)) + (return ($jvm-caload value)) (&-base/$jvm-anewarray value) - (return (&/V $jvm-anewarray value)) + (return ($jvm-anewarray value)) (&-base/$jvm-aastore value) - (return (&/V $jvm-aastore value)) + (return ($jvm-aastore value)) (&-base/$jvm-aaload value) - (return (&/V $jvm-aaload value)) + (return ($jvm-aaload value)) (&-base/$jvm-arraylength value) - (return (&/V $jvm-arraylength value)) + (return ($jvm-arraylength value)) (&-base/$jvm-iadd value) - (return (&/V $jvm-iadd value)) + (return ($jvm-iadd value)) (&-base/$jvm-isub value) - (return (&/V $jvm-isub value)) + (return ($jvm-isub value)) (&-base/$jvm-imul value) - (return (&/V $jvm-imul value)) + (return ($jvm-imul value)) (&-base/$jvm-idiv value) - (return (&/V $jvm-idiv value)) + (return ($jvm-idiv value)) (&-base/$jvm-irem value) - (return (&/V $jvm-irem value)) + (return ($jvm-irem value)) (&-base/$jvm-ieq value) - (return (&/V $jvm-ieq value)) + (return ($jvm-ieq value)) (&-base/$jvm-ilt value) - (return (&/V $jvm-ilt value)) + (return ($jvm-ilt value)) (&-base/$jvm-igt value) - (return (&/V $jvm-igt value)) + (return ($jvm-igt value)) (&-base/$jvm-ceq value) - (return (&/V $jvm-ceq value)) + (return ($jvm-ceq value)) (&-base/$jvm-clt value) - (return (&/V $jvm-clt value)) + (return ($jvm-clt value)) (&-base/$jvm-cgt value) - (return (&/V $jvm-cgt value)) + (return ($jvm-cgt value)) (&-base/$jvm-ladd value) - (return (&/V $jvm-ladd value)) + (return ($jvm-ladd value)) (&-base/$jvm-lsub value) - (return (&/V $jvm-lsub value)) + (return ($jvm-lsub value)) (&-base/$jvm-lmul value) - (return (&/V $jvm-lmul value)) + (return ($jvm-lmul value)) (&-base/$jvm-ldiv value) - (return (&/V $jvm-ldiv value)) + (return ($jvm-ldiv value)) (&-base/$jvm-lrem value) - (return (&/V $jvm-lrem value)) + (return ($jvm-lrem value)) (&-base/$jvm-leq value) - (return (&/V $jvm-leq value)) + (return ($jvm-leq value)) (&-base/$jvm-llt value) - (return (&/V $jvm-llt value)) + (return ($jvm-llt value)) (&-base/$jvm-lgt value) - (return (&/V $jvm-lgt value)) + (return ($jvm-lgt value)) (&-base/$jvm-fadd value) - (return (&/V $jvm-fadd value)) + (return ($jvm-fadd value)) (&-base/$jvm-fsub value) - (return (&/V $jvm-fsub value)) + (return ($jvm-fsub value)) (&-base/$jvm-fmul value) - (return (&/V $jvm-fmul value)) + (return ($jvm-fmul value)) (&-base/$jvm-fdiv value) - (return (&/V $jvm-fdiv value)) + (return ($jvm-fdiv value)) (&-base/$jvm-frem value) - (return (&/V $jvm-frem value)) + (return ($jvm-frem value)) (&-base/$jvm-feq value) - (return (&/V $jvm-feq value)) + (return ($jvm-feq value)) (&-base/$jvm-flt value) - (return (&/V $jvm-flt value)) + (return ($jvm-flt value)) (&-base/$jvm-fgt value) - (return (&/V $jvm-fgt value)) + (return ($jvm-fgt value)) (&-base/$jvm-dadd value) - (return (&/V $jvm-dadd value)) + (return ($jvm-dadd value)) (&-base/$jvm-dsub value) - (return (&/V $jvm-dsub value)) + (return ($jvm-dsub value)) (&-base/$jvm-dmul value) - (return (&/V $jvm-dmul value)) + (return ($jvm-dmul value)) (&-base/$jvm-ddiv value) - (return (&/V $jvm-ddiv value)) + (return ($jvm-ddiv value)) (&-base/$jvm-drem value) - (return (&/V $jvm-drem value)) + (return ($jvm-drem value)) (&-base/$jvm-deq value) - (return (&/V $jvm-deq value)) + (return ($jvm-deq value)) (&-base/$jvm-dlt value) - (return (&/V $jvm-dlt value)) + (return ($jvm-dlt value)) (&-base/$jvm-dgt value) - (return (&/V $jvm-dgt value)) + (return ($jvm-dgt value)) (&-base/$jvm-d2f value) - (return (&/V $jvm-d2f value)) + (return ($jvm-d2f value)) (&-base/$jvm-d2i value) - (return (&/V $jvm-d2i value)) + (return ($jvm-d2i value)) (&-base/$jvm-d2l value) - (return (&/V $jvm-d2l value)) + (return ($jvm-d2l value)) (&-base/$jvm-f2d value) - (return (&/V $jvm-f2d value)) + (return ($jvm-f2d value)) (&-base/$jvm-f2i value) - (return (&/V $jvm-f2i value)) + (return ($jvm-f2i value)) (&-base/$jvm-f2l value) - (return (&/V $jvm-f2l value)) + (return ($jvm-f2l value)) (&-base/$jvm-i2b value) - (return (&/V $jvm-i2b value)) + (return ($jvm-i2b value)) (&-base/$jvm-i2c value) - (return (&/V $jvm-i2c value)) + (return ($jvm-i2c value)) (&-base/$jvm-i2d value) - (return (&/V $jvm-i2d value)) + (return ($jvm-i2d value)) (&-base/$jvm-i2f value) - (return (&/V $jvm-i2f value)) + (return ($jvm-i2f value)) (&-base/$jvm-i2l value) - (return (&/V $jvm-i2l value)) + (return ($jvm-i2l value)) (&-base/$jvm-i2s value) - (return (&/V $jvm-i2s value)) + (return ($jvm-i2s value)) (&-base/$jvm-l2d value) - (return (&/V $jvm-l2d value)) + (return ($jvm-l2d value)) (&-base/$jvm-l2f value) - (return (&/V $jvm-l2f value)) + (return ($jvm-l2f value)) (&-base/$jvm-l2i value) - (return (&/V $jvm-l2i value)) + (return ($jvm-l2i value)) (&-base/$jvm-iand value) - (return (&/V $jvm-iand value)) + (return ($jvm-iand value)) (&-base/$jvm-ior value) - (return (&/V $jvm-ior value)) + (return ($jvm-ior value)) (&-base/$jvm-ixor value) - (return (&/V $jvm-ixor value)) + (return ($jvm-ixor value)) (&-base/$jvm-ishl value) - (return (&/V $jvm-ishl value)) + (return ($jvm-ishl value)) (&-base/$jvm-ishr value) - (return (&/V $jvm-ishr value)) + (return ($jvm-ishr value)) (&-base/$jvm-iushr value) - (return (&/V $jvm-iushr value)) + (return ($jvm-iushr value)) (&-base/$jvm-land value) - (return (&/V $jvm-land value)) + (return ($jvm-land value)) (&-base/$jvm-lor value) - (return (&/V $jvm-lor value)) + (return ($jvm-lor value)) (&-base/$jvm-lxor value) - (return (&/V $jvm-lxor value)) + (return ($jvm-lxor value)) (&-base/$jvm-lshl value) - (return (&/V $jvm-lshl value)) + (return ($jvm-lshl value)) (&-base/$jvm-lshr value) - (return (&/V $jvm-lshr value)) + (return ($jvm-lshr value)) (&-base/$jvm-lushr value) - (return (&/V $jvm-lushr value)) + (return ($jvm-lushr value)) )) ;; [Exports] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 881619d4d..4fb42e0fa 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -7,7 +7,7 @@ (:require [clojure.template :refer [do-template]] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |case]] + (lux [base :as & :refer [|do return fail |case]] [lexer :as &lexer]))) ;; [Utils] @@ -17,7 +17,7 @@ token &lexer/lex] (|case token [meta ( _)] - (return (&/V (&/fold &/|++ &/Nil$ elems))) + (return ( (&/fold &/|++ &/$Nil elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -29,11 +29,11 @@ (defn ^:private parse-record [parse] (|do [elems* (&/repeat% parse) token &lexer/lex - :let [elems (&/fold &/|++ &/Nil$ elems*)]] + :let [elems (&/fold &/|++ &/$Nil elems*)]] (|case token [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) - (return (&/V &/$RecordS (&/|as-pairs elems))) + (return (&/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -45,31 +45,31 @@ :let [[meta token*] token]] (|case token* (&lexer/$White_Space _) - (return &/Nil$) + (return &/$Nil) (&lexer/$Comment _) - (return &/Nil$) + (return &/$Nil) (&lexer/$Bool ?value) - (return (&/|list (&/T [meta (&/V &/$BoolS (Boolean/parseBoolean ?value))]))) + (return (&/|list (&/T [meta (&/$BoolS (Boolean/parseBoolean ?value))]))) (&lexer/$Int ?value) - (return (&/|list (&/T [meta (&/V &/$IntS (Long/parseLong ?value))]))) + (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))]))) (&lexer/$Real ?value) - (return (&/|list (&/T [meta (&/V &/$RealS (Double/parseDouble ?value))]))) + (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))]))) (&lexer/$Char ^String ?value) - (return (&/|list (&/T [meta (&/V &/$CharS (.charAt ?value 0))]))) + (return (&/|list (&/T [meta (&/$CharS (.charAt ?value 0))]))) (&lexer/$Text ?value) - (return (&/|list (&/T [meta (&/V &/$TextS ?value)]))) + (return (&/|list (&/T [meta (&/$TextS ?value)]))) (&lexer/$Symbol ?ident) - (return (&/|list (&/T [meta (&/V &/$SymbolS ?ident)]))) + (return (&/|list (&/T [meta (&/$SymbolS ?ident)]))) (&lexer/$Tag ?ident) - (return (&/|list (&/T [meta (&/V &/$TagS ?ident)]))) + (return (&/|list (&/T [meta (&/$TagS ?ident)]))) (&lexer/$Open_Paren _) (|do [syntax (parse-form parse)] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 2ff8c4093..72d0ee11b 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -7,13 +7,13 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + [lux.base :as & :refer [defvariant |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags - ["No" - "Done" - "Yes"]) +(defvariant + ("No" 1) + ("Done" 1) + ("Yes" 2)) ;; [Utils] (defn ^:private with-line [body] @@ -33,7 +33,7 @@ output) ($Yes output line*) - (return* (&/set$ &/$source (&/Cons$ line* more) state) + (return* (&/set$ &/$source (&/$Cons line* more) state) output)) ))) @@ -72,10 +72,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T [(&/T [file-name line-num column-num]) true match])) - (&/V $Yes (&/T [(&/T [(&/T [file-name line-num column-num]) false match]) - (&/T [(&/T [file-name line-num column-num*]) line])])))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + ($Done (&/T [(&/T [file-name line-num column-num]) true match])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -84,10 +84,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T [(&/T [file-name line-num column-num]) true (&/T [tok1 tok2])])) - (&/V $Yes (&/T [(&/T [(&/T [file-name line-num column-num]) false (&/T [tok1 tok2])]) - (&/T [(&/T [file-name line-num column-num*]) line])])))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + ($Done (&/T [(&/T [file-name line-num column-num]) true (&/T [tok1 tok2])])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/T [tok1 tok2])]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -96,7 +96,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/V &/$Left "[Reader Error] EOF") + (&/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -108,10 +108,10 @@ (str prefix match))] (if (= column-num* (.length line)) (recur prefix* reader**) - (&/V &/$Right (&/T [(&/Cons$ (&/T [(&/T [file-name line-num column-num*]) line]) - reader**) - (&/T [(&/T [file-name line-num column-num]) prefix*])])))) - (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line]) + reader**) + (&/T [(&/T [file-name line-num column-num]) prefix*])])))) + (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -120,10 +120,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T [(&/T [file-name line-num column-num]) true text])) - (&/V $Yes (&/T [(&/T [(&/T [file-name line-num column-num]) false text]) - (&/T [(&/T [file-name line-num column-num*]) line])])))) - (&/V $No (str "[Reader Error] Text failed: " text)))))) + ($Done (&/T [(&/T [file-name line-num column-num]) true text])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Text failed: " text)))))) (defn from [^String name ^String source-code] (let [lines (string/split-lines source-code) @@ -132,6 +132,6 @@ line])) lines (range (count lines)))] - (reduce (fn [tail head] (&/Cons$ head tail)) - &/Nil$ + (reduce (fn [tail head] (&/$Cons head tail)) + &/$Nil (reverse indexed-lines)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index d3a5f1493..9cb854c1e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -25,143 +25,121 @@ _ false)) -(def empty-env &/Nil$) -(defn Data$ [name params] - (&/V &/$DataT (&/T [name params]))) -(defn Bound$ [idx] - (&/V &/$BoundT idx)) -(defn Var$ [id] - (&/V &/$VarT id)) -(defn Lambda$ [in out] - (&/V &/$LambdaT (&/T [in out]))) -(defn App$ [fun arg] - (&/V &/$AppT (&/T [fun arg]))) -(defn Prod$ [left right] - (&/V &/$ProdT (&/T [left right]))) -(defn Sum$ [left right] - (&/V &/$SumT (&/T [left right]))) -(defn Univ$ [env body] - (&/V &/$UnivQ (&/T [env body]))) -(defn Ex$ [env body] - (&/V &/$ExQ (&/T [env body]))) -(defn Named$ [name type] - (&/V &/$NamedT (&/T [name type]))) - -(def $Void (&/V &/$VoidT &/unit-tag)) -(def Unit (&/V &/$UnitT &/unit-tag)) -(def Bool (Named$ (&/T ["lux" "Bool"]) (Data$ "java.lang.Boolean" &/Nil$))) -(def Int (Named$ (&/T ["lux" "Int"]) (Data$ "java.lang.Long" &/Nil$))) -(def Real (Named$ (&/T ["lux" "Real"]) (Data$ "java.lang.Double" &/Nil$))) -(def Char (Named$ (&/T ["lux" "Char"]) (Data$ "java.lang.Character" &/Nil$))) -(def Text (Named$ (&/T ["lux" "Text"]) (Data$ "java.lang.String" &/Nil$))) -(def Ident (Named$ (&/T ["lux" "Ident"]) (Prod$ Text Text))) +(def empty-env &/$Nil) + +(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$DataT "java.lang.Boolean" &/$Nil))) +(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$DataT "java.lang.Long" &/$Nil))) +(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$DataT "java.lang.Double" &/$Nil))) +(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$DataT "java.lang.Character" &/$Nil))) +(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$DataT "java.lang.String" &/$Nil))) +(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) (def IO - (Named$ (&/T ["lux/codata" "IO"]) - (Univ$ empty-env - (Lambda$ $Void (Bound$ 1))))) + (&/$NamedT (&/T ["lux/codata" "IO"]) + (&/$UnivQ empty-env + (&/$LambdaT &/$VoidT (&/$BoundT 1))))) (def List - (Named$ (&/T ["lux" "List"]) - (Univ$ empty-env - (Sum$ - ;; lux;Nil - Unit - ;; lux;Cons - (Prod$ (Bound$ 1) - (App$ (Bound$ 0) - (Bound$ 1))))))) + (&/$NamedT (&/T ["lux" "List"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;Nil + &/$UnitT + ;; lux;Cons + (&/$ProdT (&/$BoundT 1) + (&/$AppT (&/$BoundT 0) + (&/$BoundT 1))))))) (def Maybe - (Named$ (&/T ["lux" "Maybe"]) - (Univ$ empty-env - (Sum$ - ;; lux;None - Unit - ;; lux;Some - (Bound$ 1)) - ))) + (&/$NamedT (&/T ["lux" "Maybe"]) + (&/$UnivQ empty-env + (&/$SumT + ;; lux;None + &/$UnitT + ;; lux;Some + (&/$BoundT 1)) + ))) (def Type - (Named$ (&/T ["lux" "Type"]) - (let [Type (App$ (Bound$ 0) (Bound$ 1)) - TypeList (App$ List Type) - TypePair (Prod$ Type Type)] - (App$ (Univ$ empty-env - (Sum$ - ;; DataT - (Prod$ Text TypeList) - (Sum$ - ;; VoidT - Unit - (Sum$ - ;; UnitT - Unit - (Sum$ - ;; SumT - TypePair - (Sum$ - ;; ProdT - TypePair - (Sum$ - ;; LambdaT - TypePair - (Sum$ - ;; BoundT - Int - (Sum$ - ;; VarT - Int - (Sum$ - ;; ExT - Int - (Sum$ - ;; UnivQ - (Prod$ TypeList Type) - (Sum$ - ;; ExQ - (Prod$ TypeList Type) - (Sum$ - ;; AppT - TypePair - ;; NamedT - (Prod$ Ident Type))))))))))))) - ) - $Void)))) + (&/$NamedT (&/T ["lux" "Type"]) + (let [Type (&/$AppT (&/$BoundT 0) (&/$BoundT 1)) + TypeList (&/$AppT List Type) + TypePair (&/$ProdT Type Type)] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; DataT + (&/$ProdT Text TypeList) + (&/$SumT + ;; VoidT + &/$UnitT + (&/$SumT + ;; UnitT + &/$UnitT + (&/$SumT + ;; SumT + TypePair + (&/$SumT + ;; ProdT + TypePair + (&/$SumT + ;; LambdaT + TypePair + (&/$SumT + ;; BoundT + Int + (&/$SumT + ;; VarT + Int + (&/$SumT + ;; ExT + Int + (&/$SumT + ;; UnivQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; ExQ + (&/$ProdT TypeList Type) + (&/$SumT + ;; AppT + TypePair + ;; NamedT + (&/$ProdT Ident Type))))))))))))) + ) + &/$VoidT)))) (def DefMetaValue - (Named$ (&/T ["lux" "DefMetaValue"]) - (let [DefMetaValue (App$ (Bound$ 0) (Bound$ 1))] - (App$ (Univ$ empty-env - (Sum$ - ;; BoolM - Bool - (Sum$ - ;; IntM - Int - (Sum$ - ;; RealM - Real - (Sum$ - ;; CharM - Char - (Sum$ - ;; TextM - Text - (Sum$ - ;; IdentM - Ident - (Sum$ - ;; ListM - (App$ List DefMetaValue) - ;; DictM - (App$ List (Prod$ Text DefMetaValue))))))))) - ) - $Void)))) + (&/$NamedT (&/T ["lux" "DefMetaValue"]) + (let [DefMetaValue (&/$AppT (&/$BoundT 0) (&/$BoundT 1))] + (&/$AppT (&/$UnivQ empty-env + (&/$SumT + ;; BoolM + Bool + (&/$SumT + ;; IntM + Int + (&/$SumT + ;; RealM + Real + (&/$SumT + ;; CharM + Char + (&/$SumT + ;; TextM + Text + (&/$SumT + ;; IdentM + Ident + (&/$SumT + ;; ListM + (&/$AppT List DefMetaValue) + ;; DictM + (&/$AppT List (&/$ProdT Text DefMetaValue))))))))) + ) + &/$VoidT)))) (def DefMeta - (Named$ (&/T ["lux" "DefMeta"]) - (App$ List (Prod$ Ident DefMetaValue)))) + (&/$NamedT (&/T ["lux" "DefMeta"]) + (&/$AppT List (&/$ProdT Ident DefMetaValue)))) (def Macro) @@ -208,7 +186,7 @@ (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) ts)) state) nil)) @@ -221,14 +199,14 @@ (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] (return* (&/update$ &/$type-vars #(->> % (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id &/None$ ms)))) + (&/update$ &/$mappings (fn [ms] (&/|put id &/$None ms)))) state) id)))) (def existential ;; (Lux Type) (|do [seed &/gen-id] - (return (&/V &/$ExT seed)))) + (return (&/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -250,12 +228,12 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T [?id &/None$])) + (return (&/T [?id &/$None])) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T [?id (&/V &/$Some ?type**)])))) + (return (&/T [?id (&/$Some ?type**)])))) )))) (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] @@ -266,7 +244,7 @@ (defn with-var [k] (|do [id create-var - output (k (Var$ id)) + output (k (&/$VarT id)) _ (delete-var id)] (return output))) @@ -282,32 +260,32 @@ (&/$DataT ?name ?params) (|do [=params (&/map% (partial clean* ?tid) ?params)] - (return (Data$ ?name =params))) + (return (&/$DataT ?name =params))) (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (Lambda$ =arg =return))) + (return (&/$LambdaT =arg =return))) (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (App$ =lambda =param))) + (return (&/$AppT =lambda =param))) (&/$ProdT ?left ?right) (|do [=left (clean* ?tid ?left) =right (clean* ?tid ?right)] - (return (Prod$ =left =right))) + (return (&/$ProdT =left =right))) (&/$SumT ?left ?right) (|do [=left (clean* ?tid ?left) =right (clean* ?tid ?right)] - (return (Sum$ =left =right))) + (return (&/$SumT =left =right))) (&/$UnivQ ?env ?body) (|do [=env (&/map% (partial clean* ?tid) ?env) body* (clean* ?tid ?body)] - (return (Univ$ =env body*))) + (return (&/$UnivQ =env body*))) _ (return type) @@ -325,10 +303,10 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T [??out (&/Cons$ ?in ?args)])) + (&/T [??out (&/$Cons ?in ?args)])) _ - (&/T [type &/Nil$]))) + (&/T [type &/$Nil]))) (defn ^:private unravel-app [fun-type] (|case fun-type @@ -337,14 +315,14 @@ (&/T [?fun-type (&/|++ ?args (&/|list ?right))])) _ - (&/T [fun-type &/Nil$]))) + (&/T [fun-type &/$Nil]))) (do-template [ ] (do (defn [type] "(-> Type (List Type))" (|case type ( left right) - (&/Cons$ left ( right)) + (&/$Cons left ( right)) _ (&/|list type))) @@ -380,8 +358,8 @@ (&/$Nil) )) - Variant$ Sum$ $Void - Tuple$ Prod$ Unit + Variant$ &/$SumT &/$VoidT + Tuple$ &/$ProdT &/$UnitT ) (defn show-type [^objects type] @@ -495,17 +473,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - &/None$ + &/$None (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V &/$Some v*) + (&/$Some v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/Cons$ (&/T [k v]) fixpoints)) + (&/$Cons (&/T [k v]) fixpoints)) (defn show-type+ [type] (|case type @@ -533,31 +511,31 @@ (defn beta-reduce [env type] (|case type (&/$DataT ?name ?params) - (Data$ ?name (&/|map (partial beta-reduce env) ?params)) + (&/$DataT ?name (&/|map (partial beta-reduce env) ?params)) (&/$SumT ?left ?right) (let [=left (beta-reduce env ?left) =right (beta-reduce env ?right)] - (Sum$ =left =right)) + (&/$SumT =left =right)) (&/$ProdT ?left ?right) (let [=left (beta-reduce env ?left) =right (beta-reduce env ?right)] - (Prod$ =left =right)) + (&/$ProdT =left =right)) (&/$AppT ?type-fn ?type-arg) - (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + (&/$AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) (&/$UnivQ ?local-env ?local-def) (|case ?local-env (&/$Nil) - (Univ$ env ?local-def) + (&/$UnivQ env ?local-def) _ type) (&/$LambdaT ?input ?output) - (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) + (&/$LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) (&/$BoundT ?idx) (|case (&/|at ?idx env) @@ -575,14 +553,14 @@ (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ param) - (&/Cons$ type-fn)) + (&/$Cons param) + (&/$Cons type-fn)) local-def)) (&/$ExQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ param) - (&/Cons$ type-fn)) + (&/$Cons param) + (&/$Cons type-fn)) local-def)) (&/$AppT F A) @@ -593,12 +571,12 @@ (apply-type ?type param) (&/$ExT id) - (return (App$ type-fn param)) + (return (&/$AppT type-fn param)) _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) -(def ^:private init-fixpoints &/Nil$) +(def ^:private init-fixpoints &/$Nil) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) @@ -611,17 +589,17 @@ (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/V &/$Some ebound)) + (return* state* (&/$Some ebound)) (&/$Left _) - (return* state &/None$))) + (return* state &/$None))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/V &/$Some abound)) + (return* state* (&/$Some abound)) (&/$Left _) - (return* state &/None$)))] + (return* state &/$None)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] @@ -666,13 +644,13 @@ [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints invariant?? (App$ F1 A1) actual)) + (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] @@ -682,13 +660,13 @@ [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) + (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] @@ -724,7 +702,7 @@ (|do [$arg existential expected* (apply-type expected $arg)] (check* class-loader fixpoints invariant?? expected* actual)) - + [_ (&/$UnivQ _)] (with-var (fn [$arg] @@ -735,16 +713,16 @@ (with-var (fn [$arg] (|let [expected* (beta-reduce (->> e!env - (&/Cons$ $arg) - (&/Cons$ expected)) + (&/$Cons $arg) + (&/$Cons expected)) e!def)] (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential] (|let [actual* (beta-reduce (->> a!env - (&/Cons$ $arg) - (&/Cons$ expected)) + (&/$Cons $arg) + (&/$Cons expected)) a!def)] (check* class-loader fixpoints invariant?? expected actual*))) @@ -852,12 +830,12 @@ (|let [?member-types (flatten-prod type) size-types (&/|length ?member-types)] (if (not (>= size-types size-members)) - &/None$ + &/$None (|let [?member-types* (if (= size-types size-members) ?member-types (&/|++ (&/|take (dec size-members) ?member-types) (&/|list (|case (->> (&/|drop (dec size-members) ?member-types) (&/|reverse)) (&/$Cons last prevs) - (&/fold (fn [right left] (Prod$ left right)) + (&/fold (fn [right left] (&/$ProdT left right)) last prevs)))))] - (&/Some$ ?member-types*))))) + (&/$Some ?member-types*))))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index ae225db1f..531169538 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -29,26 +29,26 @@ stack (&/|list)] (let [super-interface (some valid-sub? (.getInterfaces sub-class))] (if (= super-class super-interface) - (&/Cons$ super-interface stack) - (recur super-interface (&/Cons$ super-interface stack))))) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))))) (.isInterface super-class) (loop [sub-class sub-class stack (&/|list)] (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] (if (= super-class super-interface) - (&/Cons$ super-interface stack) - (recur super-interface (&/Cons$ super-interface stack))) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))) (let [super* (.getSuperclass sub-class)] - (recur super* (&/Cons$ super* stack))))) + (recur super* (&/$Cons super* stack))))) :else (loop [sub-class sub-class stack (&/|list)] (let [super* (.getSuperclass sub-class)] (if (= super* super-class) - (&/Cons$ super* stack) - (recur super* (&/Cons$ super* stack)))))))) + (&/$Cons super* stack) + (recur super* (&/$Cons super* stack)))))))) (defn ^:private trace-lineage [^Class sub-class ^Class super-class] "(-> Class Class (List Class))" @@ -56,7 +56,7 @@ (&/|list) (&/|reverse (trace-lineage* super-class sub-class)))) -(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T [(.getName jt) lt]) m))] +(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))] (defn ^:private match-params [sub-type-params params] (assert (and (= (&/|length sub-type-params) (&/|length params)) (&/|every? (partial instance? TypeVariable) sub-type-params))) @@ -64,7 +64,6 @@ ;; [Exports] (let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+)|(\[+)([ZBSIJFDC]))" - Unit (&/V &/$UnitT &/unit-tag) jprim->lprim (fn [prim] (case prim "Z" "boolean" @@ -80,9 +79,9 @@ (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re (.getName class))] (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] (if (.equals "void" base) - Unit - (reduce (fn [inner _] (&/V &/$DataT (&/T [array-data-tag (&/|list inner)]))) - (&/V &/$DataT (&/T [base &/Nil$])) + &/$UnitT + (reduce (fn [inner _] (&/$DataT array-data-tag (&/|list inner))) + (&/$DataT base &/$Nil) (range (count (or arr-obrackets arr-pbrackets ""))))) )))) @@ -93,7 +92,7 @@ (instance? GenericArrayType refl-type) (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] - (return (&/V &/$DataT (&/T [array-data-tag (&/|list inner-type)])))) + (return (&/$DataT array-data-tag (&/|list inner-type)))) (instance? ParameterizedType refl-type) (|do [:let [refl-type* ^ParameterizedType refl-type] @@ -101,8 +100,8 @@ .getActualTypeArguments seq &/->list (&/map% (partial instance-param existential matchings)))] - (return (&/V &/$DataT (&/T [(->> refl-type* ^Class (.getRawType) .getName) - params*])))) + (return (&/$DataT (->> refl-type* ^Class (.getRawType) .getName) + params*))) (instance? TypeVariable refl-type) (let [gvar (.getName ^TypeVariable refl-type)] @@ -123,15 +122,14 @@ (|case gtype (&/$GenericArray component-type) (|do [inner-type (instance-gtype existential matchings component-type)] - (return (&/V &/$DataT (&/T [array-data-tag (&/|list inner-type)])))) + (return (&/$DataT array-data-tag (&/|list inner-type)))) (&/$GenericClass type-name type-params) (if-let [m-type (&/|get type-name matchings)] (return m-type) (|do [params* (&/map% (partial instance-gtype existential matchings) type-params)] - (return (&/V &/$DataT (&/T [type-name - params*]))))) + (return (&/$DataT type-name params*)))) (&/$GenericTypeVar var-name) (if-let [m-type (&/|get var-name matchings)] @@ -191,7 +189,7 @@ (if (.isAssignableFrom super-class+ sub-class+) (let [lineage (trace-lineage sub-class+ super-class+)] (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] - (return (&/V &/$DataT (&/T [(.getName sub-class*) sub-params*]))))) + (return (&/$DataT (.getName sub-class*) sub-params*)))) (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] - (check (&/V &/$DataT expected) actual*)) + (check (&/$DataT e!name e!params) actual*)) :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) @@ -253,10 +251,10 @@ (defn gtype->gclass [gtype] "(-> GenericType GenericClass)" (cond (instance? Class gtype) - (&/V &/$GenericClass (&/T [(.getName ^Class gtype) &/Nil$])) + (&/$GenericClass (.getName ^Class gtype) &/$Nil) (instance? GenericArrayType gtype) - (&/V &/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) + (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) (instance? ParameterizedType gtype) (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) @@ -264,12 +262,12 @@ .getActualTypeArguments seq &/->list (&/|map gtype->gclass))] - (&/V &/$GenericClass (&/T [type-name type-params]))) + (&/$GenericClass type-name type-params)) (instance? TypeVariable gtype) - (&/V &/$GenericTypeVar (.getName ^TypeVariable gtype)) + (&/$GenericTypeVar (.getName ^TypeVariable gtype)) (instance? WildcardType gtype) (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] (gtype->gclass bound) - (&/V &/$GenericWildcard &/unit-tag)))) + &/$GenericWildcard))) -- cgit v1.2.3