diff options
| -rw-r--r-- | src/lux/analyser/base.clj | 4 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 85 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 151 | ||||
| -rw-r--r-- | src/lux/base.clj | 6 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/type.clj | 6 | ||||
| -rw-r--r-- | src/lux/host.clj | 2 | ||||
| -rw-r--r-- | src/lux/type.clj | 37 | ||||
| -rw-r--r-- | src/lux/type/host.clj | 2 |
10 files changed, 178 insertions, 119 deletions
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 2e431770a..710da6eda 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -6,7 +6,7 @@ (ns lux.analyser.base (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return fail |case]] + (lux [base :as & :refer [deftags |let |do return* return fail |case]] [type :as &type]))) ;; [Tags] @@ -185,7 +185,7 @@ (return ?module))] (return (&/T module* ?name)))) -(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] +(let [tag-names #{"DataT" "VoidT" "UnitT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] (defn type-tag? [module name] (and (= "lux" module) (contains? tag-names name)))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index e0db07092..0fad10cea 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -116,6 +116,9 @@ (&/$NamedT ?name ?type) (adjust-type* up ?type) + (&/$UnitT) + (return type) + _ (fail (str "[Pattern-matching Error] Can't adjust type: " (&type/show-type type))) )) @@ -169,22 +172,29 @@ (return (&/T (&/V $TextTestAC ?value) =kont))) (&/$TupleS ?members) - (|do [value-type* (adjust-type value-type)] - (|case value-type* - (&/$TupleT ?member-types) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]" " -- " (&/show-ast pattern))) - (|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 [=kont kont] - (return (&/T &/Nil$ =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont)))) + (|case ?members + (&/$Nil) + (|do [_ (&type/check value-type &type/Unit) + =kont kont] + (return (&/T (&/V $TupleTestAC (&/|list)) =kont))) - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type))))) + _ + (|do [value-type* (adjust-type value-type)] + (|case value-type* + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]" " -- " (&/show-ast pattern))) + (|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 [=kont kont] + (return (&/T &/Nil$ =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $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)] @@ -340,24 +350,35 @@ (return ?total)) ($TupleTotal ?total ?structs) - (|do [unknown? (&type/unknown? value-type)] - (if unknown? - (|do [=structs (&/map% (check-totality+ check-totality) ?structs) - _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] - (return (or ?total - (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) - (if ?total + (|case ?structs + (&/$Nil) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$UnitT) (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) - - _ - (fail "[Pattern-maching Error] Tuple is not total.")))))) + + _ + (fail "[Pattern-maching Error] Unit is not total."))) + + _ + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) + + _ + (fail "[Pattern-maching Error] Tuple is not total."))))))) ($VariantTotal ?total ?structs) (if ?total diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index b729ffd33..5a85fbe66 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -677,9 +677,7 @@ ?params) _ (&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) - ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion all-supers =methods) - ;; :let [_ (prn 'analyse-jvm-class/_3)] _ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces =anns =fields =methods (&/|list) &/None$))) :let [_ (println 'DEF full-name)]] (return &/Nil$)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 09e01b6aa..834b75f5a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -43,73 +43,88 @@ (&type/Lambda$ input output))) ;; [Exports] -(defn analyse-tuple [analyse ?exo-type ?elems] - (|case ?exo-type - (&/$Left exo-type) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$UnivQ _) - (&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)) - =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*))) +(defn analyse-unit [analyse ?exo-type] + (|do [_cursor &/cursor + _ (&type/check ?exo-type &type/Unit)] + (return (&/|list (&&/|meta ?exo-type _cursor + (&/V &&/$tuple (&/|list))))))) - _ - (&type/clean $var tuple-type))] - (return (&/|list (&&/|meta inferred-type tuple-cursor - tuple-analysis)))))) +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?elems + (&/$Nil) + (analyse-unit analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type)) - _ - (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + _ + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&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)) + =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*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) - (&/$Right exo-type) - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems))) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$tuple =elems) - )))) - (|do [exo-type* (&type/actual-type exo-type)] - (&/with-attempt - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$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))] - (return (&/|list (&&/|meta exo-type tuple-cursor - tuple-analysis)))) - - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) - ) - (fn [err] - (fail (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type)))))))))) + _ + (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) + (|do [exo-type* (&type/actual-type exo-type)] + (&/with-attempt + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$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))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) + + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) + ) + (fn [err] + (fail (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) + )) (defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (&/with-attempt + (|do [_cursor &/cursor + output (&/with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse (&/V &/$Right exo-type) &/Nil$) + (analyse-unit analyse exo-type) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) @@ -169,7 +184,8 @@ (&/$VariantT ?cases) (|case (&/|at idx ?cases) (&/$Some vtype) - (|do [=value (&/with-attempt + (|do [_cursor &/cursor + =value (&/with-attempt (analyse-variant-body analyse vtype ?values) (fn [err] (|do [_exo-type (&type/deref+ exo-type)] @@ -340,14 +356,7 @@ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) - (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state))) - ;; :let [_ (when (or (= "import" (aget real-name 1)) - ;; (= "defsig" (aget real-name 1))) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name))))] - ] + (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state)))] (&/flat-map% (partial analyse exo-type) macro-expansion)) _ @@ -359,8 +368,8 @@ (defn analyse-case [analyse exo-type ?value ?branches] (|do [:let [num-branches (&/|length ?branches)] - _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") - _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") + _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case\" expression.") + _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case\" expression.") =value (&&/analyse-1+ analyse ?value) :let [var?? (|case =value [_ (&&/$var =var-kind)] diff --git a/src/lux/base.clj b/src/lux/base.clj index ee5e728a1..e0517940a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -45,6 +45,8 @@ ;; Type (deftags ["DataT" + "VoidT" + "UnitT" "VariantT" "TupleT" "LambdaT" @@ -183,7 +185,7 @@ (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) - 0 '_ + 0 nil 1 (first parts) ;; else `[~@parts]))))) @@ -660,7 +662,7 @@ ;; "lux;types" +init-bindings+ ;; "lux;expected" - (V $VariantT Nil$) + (V $VoidT nil) ;; "lux;seed" 0 ;; "lux;eval?" diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 19af75dce..afa2d1bf9 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -53,7 +53,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$TupleT (&/$Nil)) + (&/$UnitT) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean" (&/$Nil)) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 5b460858c..06aac90a0 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -61,6 +61,12 @@ (&/$DataT class params) (variant$ &/$DataT (tuple$ (&/|list (text$ class) (List$ (&/|map type->analysis params))))) + + (&/$VoidT) + (variant$ &/$VoidT (tuple$ (&/|list))) + + (&/$UnitT) + (variant$ &/$UnitT (tuple$ (&/|list))) (&/$TupleT members) (variant$ &/$TupleT (List$ (&/|map type->analysis members))) diff --git a/src/lux/host.clj b/src/lux/host.clj index e32a60065..3b0cc241d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -63,7 +63,7 @@ (&/$LambdaT _ _) (return (&host-generics/->type-signature function-class)) - (&/$TupleT (&/$Nil)) + (&/$UnitT) (return "V") (&/$VariantT _) diff --git a/src/lux/type.clj b/src/lux/type.clj index b03558d38..8a43eeda6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -36,8 +36,10 @@ (defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) (defn Tuple$ [members] + (assert (> (&/|length members) 0)) (&/V &/$TupleT members)) (defn Variant$ [members] + (assert (> (&/|length members) 0)) (&/V &/$VariantT members)) (defn Univ$ [env body] (&/V &/$UnivQ (&/T env body))) @@ -46,14 +48,13 @@ (defn Named$ [name type] (&/V &/$NamedT (&/T name type))) - +(def $Void (&/V &/$VoidT nil)) +(def Unit (&/V &/$UnitT nil)) (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 Unit (Named$ (&/T "lux" "Unit") (Tuple$ &/Nil$))) -(def $Void (Named$ (&/T "lux" "Void") (Variant$ &/Nil$))) (def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO @@ -92,6 +93,10 @@ (Variant$ (&/|list ;; DataT (Tuple$ (&/|list Text TypeList)) + ;; VoidT + Unit + ;; UnitT + Unit ;; VariantT TypeList ;; TupleT @@ -254,7 +259,10 @@ (|case type (&/$VarT ?id) (if (.equals ^Object ?tid ?id) - (deref ?id) + (|do [? (bound? ?id)] + (if ? + (deref ?id) + (return type))) (return type)) (&/$LambdaT ?arg ?return) @@ -319,6 +327,12 @@ _ (str "(^ " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VoidT) + "Void" + + (&/$UnitT) + "Unit" (&/$TupleT elems) (if (&/|empty? elems) @@ -374,6 +388,12 @@ (= (&/|length xparams) (&/|length yparams)) (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) + [(&/$VoidT) (&/$VoidT)] + true + + [(&/$UnitT) (&/$UnitT)] + true + [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true @@ -676,6 +696,12 @@ e!data a!data) + [(&/$VoidT) (&/$VoidT)] + (return (&/T fixpoints nil)) + + [(&/$UnitT) (&/$UnitT)] + (return (&/T fixpoints nil)) + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] (check* class-loader fixpoints* invariant?? eO aO)) @@ -688,9 +714,6 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [_ (&/$VariantT (&/$Nil))] - (return (&/T fixpoints nil)) - [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp invariant?? e a)] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index b03fd9828..b83c74a60 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -64,7 +64,7 @@ ;; [Exports] (let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+)|(\[+)([ZBSIJFDC]))" - Unit (&/V &/$TupleT (&/|list)) + Unit (&/V &/$UnitT nil) jprim->lprim (fn [prim] (case prim "Z" "boolean" |