diff options
| author | Eduardo Julian | 2022-09-02 22:30:48 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2022-09-02 22:30:48 -0400 |
| commit | 950836e72a1b775ccab19a722566c431f56208f6 (patch) | |
| tree | d48e07019fc67f8e234d06847ca14d612027817f | |
| parent | 3b571c140a3bee7ec715df9f9cf37645883b9397 (diff) | |
Made labels (tags & slots) into normal definitions.
Diffstat (limited to '')
58 files changed, 1628 insertions, 1556 deletions
diff --git a/lux-bootstrapper/src/lux/analyser.clj b/lux-bootstrapper/src/lux/analyser.clj index 8d440598b..0a168b38b 100644 --- a/lux-bootstrapper/src/lux/analyser.clj +++ b/lux-bootstrapper/src/lux/analyser.clj @@ -65,10 +65,10 @@ (&/$Variant (&/$Item [command-meta command] parameters)) (|case command - (&/$Nat idx) + (&/$Nat lefts) (|let [(&/$Item [_ (&/$Bit ?right)] parameters*) parameters] (&/with-analysis-meta location exo-type - (&&lux/analyse-variant analyse (&/$Right exo-type) (if ?right (inc idx) idx) ?right parameters*))) + (&&lux/analyse-variant analyse (&/$Right exo-type) lefts ?right parameters*))) (&/$Identifier ?ident) (&/with-analysis-meta location exo-type @@ -126,21 +126,6 @@ (&/with-location location (&&lux/analyse-def-alias ?alias ?original))) - "lux def type tagged" - (|let [(&/$Item [_ (&/$Identifier "" ?name)] - (&/$Item ?value - (&/$Item ?labels - (&/$Item exported? - (&/$End))) - )) parameters] - (&/with-location location - (|case ?labels - [_ (&/$Variant ?tags)] - (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value false ?tags exported?) - - [_ (&/$Tuple ?slots)] - (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value true ?slots exported?)))) - "lux def module" (|let [(&/$Item ?imports (&/$End)) parameters] (&/with-location location diff --git a/lux-bootstrapper/src/lux/analyser/case.clj b/lux-bootstrapper/src/lux/analyser/case.clj index ef339587b..42ab446ca 100644 --- a/lux-bootstrapper/src/lux/analyser/case.clj +++ b/lux-bootstrapper/src/lux/analyser/case.clj @@ -356,8 +356,8 @@ (&/$None) (analyse-tuple-pattern analyse-pattern pattern value-type ?members kont))) - (&/$Variant (&/$Item [_ (&/$Nat idx)] (&/$Item [_ (&/$Bit right?)] ?values))) - (let [idx (if right? (inc idx) idx)] + (&/$Variant (&/$Item [_ (&/$Nat lefts)] (&/$Item [_ (&/$Bit right?)] ?values))) + (let [idx (if right? (inc lefts) lefts)] (|do [value-type* (adjust-type value-type) case-type (&type/sum-at idx value-type*) [=test =kont] (case (int (&/|length ?values)) @@ -365,25 +365,34 @@ 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) ;; 1+ (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont])))) + (return (&/T [($VariantTestAC (&/T [lefts right? =test])) =kont])))) (&/$Variant (&/$Item [_ (&/$Identifier ?ident)] ?values)) (|do [[=module =name] (&&/resolved-ident ?ident) must-infer? (&type/unknown? value-type) - [_exported? variant-type** group idx] (&module/find-tag =module =name) + [_exported? [label* variant-type**]] (&module/find-tag =module =name) + [lefts right?] (return (|case label* + (&/$Some [lefts right? family]) + (&/T [lefts right?]) + + (&/$None) + (&/T [0 false]))) variant-type (if must-infer? (|do [variant-type* (&type/instantiate-inference variant-type**) _ (&type/check value-type variant-type*)] (return variant-type*)) (return value-type)) value-type* (adjust-type variant-type) - case-type (&type/sum-at idx value-type*) + case-type (let [idx (if right? + (inc lefts) + lefts)] + (&type/sum-at idx value-type*)) [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern &/$None case-type unit-tuple kont) 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) ;; 1+ (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + (return (&/T [($VariantTestAC (&/T [lefts right? =test])) =kont]))) _ (&/fail-with-loc (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) @@ -394,238 +403,245 @@ (&&/analyse-1 analyse exo-type body))] (return (&/$Item pattern+body patterns)))) -(defn ^:private merge-total [struct test+body] - (|let [[test ?body] test+body] - (|case [struct test] - [($DefaultTotal total?) ($NoTestAC)] - (return ($DefaultTotal true)) - - [($BitTotal total? ?values) ($NoTestAC)] - (return ($BitTotal true ?values)) - - [($NatTotal total? ?values) ($NoTestAC)] - (return ($NatTotal true ?values)) - - [($IntTotal total? ?values) ($NoTestAC)] - (return ($IntTotal true ?values)) - - [($RevTotal total? ?values) ($NoTestAC)] - (return ($RevTotal true ?values)) - - [($FracTotal total? ?values) ($NoTestAC)] - (return ($FracTotal true ?values)) - - [($TextTotal total? ?values) ($NoTestAC)] - (return ($TextTotal true ?values)) - - [($TupleTotal total? ?values) ($NoTestAC)] - (return ($TupleTotal true ?values)) - - [($VariantTotal total? ?values) ($NoTestAC)] - (return ($VariantTotal true ?values)) +;; (defn ^:private merge-total [struct test+body] +;; (|let [[test ?body] test+body] +;; (|case [struct test] +;; [($DefaultTotal total?) ($NoTestAC)] +;; (return ($DefaultTotal true)) - [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return ($DefaultTotal true)) +;; [($BitTotal total? ?values) ($NoTestAC)] +;; (return ($BitTotal true ?values)) - [($BitTotal total? ?values) ($StoreTestAC ?idx)] - (return ($BitTotal true ?values)) +;; [($NatTotal total? ?values) ($NoTestAC)] +;; (return ($NatTotal true ?values)) - [($NatTotal total? ?values) ($StoreTestAC ?idx)] - (return ($NatTotal true ?values)) +;; [($IntTotal total? ?values) ($NoTestAC)] +;; (return ($IntTotal true ?values)) - [($IntTotal total? ?values) ($StoreTestAC ?idx)] - (return ($IntTotal true ?values)) +;; [($RevTotal total? ?values) ($NoTestAC)] +;; (return ($RevTotal true ?values)) - [($RevTotal total? ?values) ($StoreTestAC ?idx)] - (return ($RevTotal true ?values)) +;; [($FracTotal total? ?values) ($NoTestAC)] +;; (return ($FracTotal true ?values)) - [($FracTotal total? ?values) ($StoreTestAC ?idx)] - (return ($FracTotal true ?values)) +;; [($TextTotal total? ?values) ($NoTestAC)] +;; (return ($TextTotal true ?values)) - [($TextTotal total? ?values) ($StoreTestAC ?idx)] - (return ($TextTotal true ?values)) +;; [($TupleTotal total? ?values) ($NoTestAC)] +;; (return ($TupleTotal true ?values)) - [($TupleTotal total? ?values) ($StoreTestAC ?idx)] - (return ($TupleTotal true ?values)) +;; [($VariantTotal total? ?values) ($NoTestAC)] +;; (return ($VariantTotal true ?values)) - [($VariantTotal total? ?values) ($StoreTestAC ?idx)] - (return ($VariantTotal true ?values)) +;; [($DefaultTotal total?) ($StoreTestAC ?idx)] +;; (return ($DefaultTotal true)) - [($DefaultTotal total?) ($BitTestAC ?value)] - (return ($BitTotal total? (&/|list ?value))) +;; [($BitTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($BitTotal true ?values)) - [($BitTotal total? ?values) ($BitTestAC ?value)] - (return ($BitTotal total? (&/$Item ?value ?values))) +;; [($NatTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($NatTotal true ?values)) - [($DefaultTotal total?) ($NatTestAC ?value)] - (return ($NatTotal total? (&/|list ?value))) +;; [($IntTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($IntTotal true ?values)) - [($NatTotal total? ?values) ($NatTestAC ?value)] - (return ($NatTotal total? (&/$Item ?value ?values))) +;; [($RevTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($RevTotal true ?values)) - [($DefaultTotal total?) ($IntTestAC ?value)] - (return ($IntTotal total? (&/|list ?value))) +;; [($FracTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($FracTotal true ?values)) - [($IntTotal total? ?values) ($IntTestAC ?value)] - (return ($IntTotal total? (&/$Item ?value ?values))) +;; [($TextTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($TextTotal true ?values)) - [($DefaultTotal total?) ($RevTestAC ?value)] - (return ($RevTotal total? (&/|list ?value))) +;; [($TupleTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($TupleTotal true ?values)) - [($RevTotal total? ?values) ($RevTestAC ?value)] - (return ($RevTotal total? (&/$Item ?value ?values))) +;; [($VariantTotal total? ?values) ($StoreTestAC ?idx)] +;; (return ($VariantTotal true ?values)) - [($DefaultTotal total?) ($FracTestAC ?value)] - (return ($FracTotal total? (&/|list ?value))) +;; [($DefaultTotal total?) ($BitTestAC ?value)] +;; (return ($BitTotal total? (&/|list ?value))) - [($FracTotal total? ?values) ($FracTestAC ?value)] - (return ($FracTotal total? (&/$Item ?value ?values))) +;; [($BitTotal total? ?values) ($BitTestAC ?value)] +;; (return ($BitTotal total? (&/$Item ?value ?values))) - [($DefaultTotal total?) ($TextTestAC ?value)] - (return ($TextTotal total? (&/|list ?value))) +;; [($DefaultTotal total?) ($NatTestAC ?value)] +;; (return ($NatTotal total? (&/|list ?value))) - [($TextTotal total? ?values) ($TextTestAC ?value)] - (return ($TextTotal total? (&/$Item ?value ?values))) +;; [($NatTotal total? ?values) ($NatTestAC ?value)] +;; (return ($NatTotal total? (&/$Item ?value ?values))) - [($DefaultTotal total?) ($TupleTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (merge-total ($DefaultTotal total?) (&/T [t ?body]))) - ?tests)] - (return ($TupleTotal total? structs))) +;; [($DefaultTotal total?) ($IntTestAC ?value)] +;; (return ($IntTotal total? (&/|list ?value))) - [($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 ($TupleTotal total? structs))) - (&/fail-with-loc (str "[Pattern-matching Error] Inconsistent tuple-size.\n" - "Expected: " (&/|length ?values) "\n" - " Actual: " (&/|length ?tests)))) +;; [($IntTotal total? ?values) ($IntTestAC ?value)] +;; (return ($IntTotal total? (&/$Item ?value ?values))) - [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total ($DefaultTotal total?) - (&/T [?test ?body])) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) - (&/$Some list) - (return list) +;; [($DefaultTotal total?) ($RevTestAC ?value)] +;; (return ($RevTotal total? (&/|list ?value))) - (&/$None) - (assert false))] - (return ($VariantTotal total? structs))) +;; [($RevTotal total? ?values) ($RevTestAC ?value)] +;; (return ($RevTotal total? (&/$Item ?value ?values))) - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) - (&/$Some sub) - sub - - (&/$None) - ($DefaultTotal total?)) - (&/T [?test ?body])) - structs (|case (&/|list-put ?tag sub-struct ?branches) - (&/$Some list) - (return list) +;; [($DefaultTotal total?) ($FracTestAC ?value)] +;; (return ($FracTotal total? (&/|list ?value))) - (&/$None) - (assert false))] - (return ($VariantTotal total? structs))) - ))) - -(defn check-totality+ [check-totality] - (fn [?token] - (&type/with-var - (fn [$var] - (|do [=output (check-totality $var ?token) - ?type (&type/deref+ $var) - =type (&type/clean $var ?type)] - (return (&/T [=output =type]))))))) - -(defn ^:private check-totality [value-type struct] - (|case struct - ($DefaultTotal ?total) - (return ?total) - - ($BitTotal ?total ?values) - (|do [_ (&type/check value-type &type/Bit)] - (return (or ?total - (= #{true false} (set (&/->seq ?values)))))) - - ($NatTotal ?total _) - (|do [_ (&type/check value-type &type/Nat)] - (return ?total)) - - ($IntTotal ?total _) - (|do [_ (&type/check value-type &type/Int)] - (return ?total)) - - ($RevTotal ?total _) - (|do [_ (&type/check value-type &type/Rev)] - (return ?total)) - - ($FracTotal ?total _) - (|do [_ (&type/check value-type &type/Frac)] - (return ?total)) +;; [($FracTotal total? ?values) ($FracTestAC ?value)] +;; (return ($FracTotal total? (&/$Item ?value ?values))) - ($TextTotal ?total _) - (|do [_ (&type/check value-type &type/Text)] - (return ?total)) +;; [($DefaultTotal total?) ($TextTestAC ?value)] +;; (return ($TextTotal total? (&/|list ?value))) - ($TupleTotal ?total ?structs) - (|case ?structs - (&/$End) - (|do [value-type* (resolve-type value-type)] - (if (&type/type= &type/Any value-type*) - (return true) - (&/fail-with-loc "[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 (|case (->> (&/|map &/|second =structs) (&/|reverse)) - (&/$Item last prevs) - (&/fold (fn [right left] (&/$Product left right)) - last prevs)))] - (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* - (&/$Product _) - (|let [num-elems (&/|length ?structs) - [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*) - _ (&/assert! (= num-elems _shorter) - (&/fail-with-loc (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))] - (|do [totals (&/map2% check-totality _tuple-types ?structs)] - (return (&/fold #(and %1 %2) true totals)))) - - _ - (&/fail-with-loc (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) - - ($VariantTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$Sum _) - (|do [totals (&/map2% check-totality - (&type/flatten-sum value-type*) - ?structs)] - (return (&/fold #(and %1 %2) true totals))) - - _ - (&/fail-with-loc "[Pattern-maching Error] Variant is not total.")))) - )) +;; [($TextTotal total? ?values) ($TextTestAC ?value)] +;; (return ($TextTotal total? (&/$Item ?value ?values))) + +;; [($DefaultTotal total?) ($TupleTestAC ?tests)] +;; (|do [structs (&/map% (fn [t] +;; (merge-total ($DefaultTotal total?) (&/T [t ?body]))) +;; ?tests)] +;; (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 ($TupleTotal total? structs))) +;; (&/fail-with-loc (str "[Pattern-matching Error] Inconsistent tuple-size.\n" +;; "Expected: " (&/|length ?values) "\n" +;; " Actual: " (&/|length ?tests)))) + +;; [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] +;; (|do [sub-struct (merge-total ($DefaultTotal total?) +;; (&/T [?test ?body])) +;; structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) +;; (&/$Some list) +;; (return list) + +;; (&/$None) +;; (assert false))] +;; (return ($VariantTotal total? structs))) + +;; [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] +;; (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) +;; (&/$Some sub) +;; sub + +;; (&/$None) +;; ($DefaultTotal total?)) +;; (&/T [?test ?body])) +;; structs (|case (&/|list-put ?tag sub-struct ?branches) +;; (&/$Some list) +;; (return list) + +;; (&/$None) +;; (assert false))] +;; (return ($VariantTotal total? structs))) +;; ))) + +;; (defn check-totality+ [check-totality] +;; (fn [?token] +;; (&type/with-var +;; (fn [$var] +;; (|do [=output (check-totality $var ?token) +;; ?type (&type/deref+ $var) +;; =type (&type/clean $var ?type)] +;; (return (&/T [=output =type]))))))) + +;; (defn ^:private check-totality [value-type struct] +;; (|case struct +;; ($DefaultTotal ?total) +;; (return ?total) + +;; ($BitTotal ?total ?values) +;; (|do [_ (&type/check value-type &type/Bit)] +;; (return (or ?total +;; (= #{true false} (set (&/->seq ?values)))))) + +;; ($NatTotal ?total _) +;; (|do [_ (&type/check value-type &type/Nat)] +;; (return ?total)) + +;; ($IntTotal ?total _) +;; (|do [_ (&type/check value-type &type/Int)] +;; (return ?total)) + +;; ($RevTotal ?total _) +;; (|do [_ (&type/check value-type &type/Rev)] +;; (return ?total)) + +;; ($FracTotal ?total _) +;; (|do [_ (&type/check value-type &type/Frac)] +;; (return ?total)) + +;; ($TextTotal ?total _) +;; (|do [_ (&type/check value-type &type/Text)] +;; (return ?total)) + +;; ($TupleTotal ?total ?structs) +;; (|case ?structs +;; (&/$End) +;; (|do [value-type* (resolve-type value-type)] +;; (if (&type/type= &type/Any value-type*) +;; (return true) +;; (&/fail-with-loc "[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 (|case (->> (&/|map &/|second =structs) (&/|reverse)) +;; (&/$Item last prevs) +;; (&/fold (fn [right left] (&/$Product left right)) +;; last prevs)))] +;; (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* +;; (&/$Product _) +;; (|let [num-elems (&/|length ?structs) +;; [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*) +;; _ (&/assert! (= num-elems _shorter) +;; (&/fail-with-loc (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))] +;; (|do [totals (&/map2% check-totality _tuple-types ?structs)] +;; (return (&/fold #(and %1 %2) true totals)))) + +;; _ +;; (&/fail-with-loc (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) + +;; ($VariantTotal ?total ?structs) +;; (if ?total +;; (return true) +;; (|do [value-type* (resolve-type value-type)] +;; (|case value-type* +;; (&/$Sum _) +;; (|do [totals (&/map2% check-totality +;; (&type/flatten-sum value-type*) +;; ?structs)] +;; (return (&/fold #(and %1 %2) true totals))) + +;; _ +;; (&/fail-with-loc "[Pattern-maching Error] Variant is not total.")))) +;; )) ;; [Exports] (defn analyse-branches [analyse exo-type var?? value-type branches] - (|do [patterns (&/fold% (fn [patterns branch] - (|let [[pattern body] branch] - (analyse-branch analyse exo-type var?? value-type pattern body patterns))) - &/$End - branches) - struct (&/fold% merge-total ($DefaultTotal false) patterns) - ? (check-totality value-type struct) - _ (&/assert! ? "[Pattern-maching Error] Pattern-matching is not total.")] - (return patterns))) + (&/fold% (fn [patterns branch] + (|let [[pattern body] branch] + (analyse-branch analyse exo-type var?? value-type pattern body patterns))) + &/$End + branches) + ;; (|do [patterns (&/fold% (fn [patterns branch] + ;; (|let [[pattern body] branch] + ;; (analyse-branch analyse exo-type var?? value-type pattern body patterns))) + ;; &/$End + ;; branches) + ;; ;; struct (&/fold% merge-total ($DefaultTotal false) patterns) + ;; ;; ? (check-totality value-type struct) + ;; ;; _ (&/assert! ? "[Pattern-maching Error] Pattern-matching is not total.") + ;; ] + ;; (return patterns)) + ) diff --git a/lux-bootstrapper/src/lux/analyser/lux.clj b/lux-bootstrapper/src/lux/analyser/lux.clj index 0ae77b537..d28a92051 100644 --- a/lux-bootstrapper/src/lux/analyser/lux.clj +++ b/lux-bootstrapper/src/lux/analyser/lux.clj @@ -174,7 +174,7 @@ _ (&/fail-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) -(defn analyse-variant [analyse ?exo-type idx is-last? ?values] +(defn analyse-variant [analyse ?exo-type lefts right? ?values] (|case ?exo-type (&/$Left exo-type) (|do [exo-type* (&type/actual-type exo-type)] @@ -183,7 +183,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) + [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) lefts right? ?values)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$Var iid) @@ -198,7 +198,7 @@ variant-analysis)))))) _ - (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) + (analyse-variant analyse (&/$Right exo-type*) lefts right? ?values))) (&/$Right exo-type) (|do [exo-type* (|case exo-type @@ -213,56 +213,61 @@ (&/with-attempt (|case exo-type* (&/$Sum _) - (|do [vtype (&type/sum-at idx exo-type*) + (|do [:let [idx (if right? + (inc lefts) + lefts)] + vtype (&type/sum-at idx exo-type*) =value (analyse-variant-body analyse vtype ?values) _location &/location] (if (= 1 (&/|length (&type/flatten-sum exo-type*))) (return (&/|list =value)) - (return (&/|list (&&/|meta exo-type _location (&&/$variant idx is-last? =value)))) + (return (&/|list (&&/|meta exo-type _location (&&/$variant idx right? =value)))) )) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) + (analyse-variant analyse (&/$Right exo-type**) lefts right? ?values)) (&/$ExQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] + =exprs (analyse-variant analyse (&/$Right exo-type**) lefts right? ?values)] (&/map% (partial &&/clean-analysis $var) =exprs)))) _ - (&/fail-with-loc (str "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + (&/fail-with-loc (str "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type*) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) (fn [err] (|case exo-type (&/$Var ?id) (|do [=exo-type (&type/deref ?id)] - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type =exo-type) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) _ - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) ))) (defn analyse-variant+ [analyse exo-type module tag-name values] - (|do [[exported? wanted-type group idx] (&&module/find-tag module tag-name) - :let [is-last? (= idx (dec (&/|length group)))]] - (if (= 1 (&/|length group)) + (|do [[exported? [label* variant_type]] (&&module/find-tag module tag-name)] + (|case label* + (&/$None) (|do [_location &/location] (analyse exo-type (&/T [_location (&/$Tuple values)]))) + + (&/$Some [lefts right? family]) (|case exo-type (&/$Var id) (|do [? (&type/bound? id)] (if (or ? (&&/type-tag? module tag-name)) - (analyse-variant analyse (&/$Right exo-type) idx is-last? values) - (|do [wanted-type* (&type/instantiate-inference wanted-type) - [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) + (analyse-variant analyse (&/$Right exo-type) lefts right? values) + (|do [variant_type* (&type/instantiate-inference variant_type) + [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left variant_type*) lefts right? values)) _ (&type/check exo-type variant-type)] (return (&/|list (&&/|meta exo-type variant-location variant-analysis)))))) _ - (analyse-variant analyse (&/$Right exo-type) idx is-last? values))))) + (analyse-variant analyse (&/$Right exo-type) lefts right? values))))) (defn analyse-record [analyse exo-type ?elems] (|do [rec-members&rec-type (&&record/order-record false ?elems)] @@ -577,7 +582,7 @@ (&&/analyse-1 analyse type code))] (eval! (optimize analysis)))) -(defn analyse-def* [analyse optimize eval! compile-def ?name ?value exported? type? & [?expected-type]] +(defn analyse-def* [analyse optimize eval! compile-def ?name ?value exported? & [?expected-type]] (|do [_ &/ensure-declaration module-name &/get-module-name _ (ensure-undefined! module-name ?name) @@ -588,7 +593,7 @@ (&&/analyse-1 analyse ?expected-type ?value)) (&&/analyse-1+ analyse ?value)))) ==exported? (eval analyse optimize eval! &type/Bit exported?) - def-value (compile-def ?name (optimize =value) ==exported? type?) + def-value (compile-def ?name (optimize =value) ==exported?) _ &type/reset-mappings :let [def-type (&&/expr-type* =value) _ (println 'DEF (str module-name &/+name-separator+ ?name @@ -596,19 +601,7 @@ (return (&/T [module-name def-type def-value ==exported?])))) (defn analyse-def [analyse optimize eval! compile-def ?name ?value exported?] - (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value exported? &/$None)] - (return &/$End))) - -(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value record? labels* exported?] - (|do [labels (&/map% (fn [tag*] - (|case tag* - [_ (&/$Text tag)] - (return tag) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect format for labels."))) - labels*) - _ (analyse-def* analyse optimize eval! compile-def ?name ?value exported? (&/$Some (&/T [record? labels])) &type/Type)] + (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value exported?)] (return &/$End))) (defn analyse-def-alias [?alias ?original] diff --git a/lux-bootstrapper/src/lux/analyser/module.clj b/lux-bootstrapper/src/lux/analyser/module.clj index eebac2d80..426d0bfb6 100644 --- a/lux-bootstrapper/src/lux/analyser/module.clj +++ b/lux-bootstrapper/src/lux/analyser/module.clj @@ -110,18 +110,7 @@ (if (&type/type= &type/Type ?type) (return* state (&/T [exported? ?value])) ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) - state)) - - (&/$TypeG [exported? ?value labels]) - (return* state (&/T [exported? ?value])) - - (&/$TagG _) - ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) - state) - - (&/$SlotG _) - ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) - state)) + state))) ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) state)) ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) @@ -181,24 +170,13 @@ state) (&/$DefinitionG $def*) - (return* state (&/T [(&/T [module name]) $def*])) - - (&/$TypeG [exported? ?value labels]) - (return* state (&/T [(&/T [module name]) - (&/T [exported? &type/Type ?value])])) - - (&/$TagG _) - ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) - state) - - (&/$SlotG _) - ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (str module &/+name-separator+ name) - " at module: " current-module)) + (return* state (&/T [(&/T [module name]) $def*]))) + ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (&/ident->text (&/T [module name])) + " at module: " (pr-str current-module))) state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Module does not exist: " module - " at module: " current-module)) + ((&/fail-with-loc (str "[Analyser Error @ find-def!] Module does not exist: " (pr-str module) + " for symbol: " (&/ident->text (&/T [module name])) + " at module: " (pr-str current-module))) state))))) (defn find-def [quoted_module module name] @@ -225,27 +203,7 @@ (&/T [exported? ?type ?value])])) ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) " at module: " current-module)) - state)) - - (&/$TypeG [exported? ?value labels]) - (if (or (.equals ^Object current-module module) - (and exported? - (or (.equals ^Object &/prelude module) - (.equals ^Object quoted_module module) - (imports? state module current-module)))) - (return* state (&/T [(&/T [module name]) - (&/T [exported? &type/Type ?value])])) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - - (&/$TagG _) - ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) - state) - - (&/$SlotG _) - ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) - state)) + state))) ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name) " at module: " current-module)) state)) @@ -260,10 +218,7 @@ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def (&/$AliasG [?r-module ?r-name]) (return* state $def) - (&/$DefinitionG _) (return* state $def) - (&/$TypeG _) (return* state $def) - (&/$TagG _) (return* state $def) - (&/$SlotG _) (return* state $def)) + (&/$DefinitionG _) (return* state $def)) ((&/fail-with-loc (str "[Analyser Error @ find-def] Global does not exist: " (str module &/+name-separator+ name) " at module: " current-module)) state)) @@ -271,7 +226,21 @@ " at module: " current-module)) state))))) -(do-template [<tag> <find!> <find>] +(defn label + "(-> Text Nat (List Text) Type + Label)" + [module index group type] + (let [max_size (&/|length group)] + (if (= 1 max_size) + (&/T [&/$None type]) + (let [right? (= index (dec max_size)) + lefts (if right? + (dec index) + index)] + (&/T [(&/$Some (&/T [lefts right? (&/|map (fn [it] (&/T [module it])) group)])) + type]))))) + +(do-template [<find!> <find> <definition_type>] (do (defn <find!> [module name] (|do [current-module &/get-module-name] (fn [state] @@ -282,9 +251,6 @@ ((<find!> ?r-module ?r-name) state) - (<tag> ?payload) - (return* state ?payload) - _ ((&/fail-with-loc (str "[Analyser Error] Not a label: " (&/ident->text (&/T [module name])) " @ " (quote <find!>))) @@ -311,12 +277,17 @@ " at module: " current-module " @ " (quote <find>))) state)) - - (<tag> [exported? type group index]) + + (&/$DefinitionG [exported? ?type ?value]) (if (or (.equals ^Object current-module module) exported?) - (return* state (&/T [exported? type group index])) - ((&/fail-with-loc (str "[Analyser Error] Cannot use private label: " (str module &/+name-separator+ name) + (if (&type/type= <definition_type> ?type) + (return* state (&/T [exported? ?value])) + ((&/fail-with-loc (str "[Analyser Error] Invalid type for label: " (str module &/+name-separator+ name) + " at module: " current-module + " @ " (quote <find>))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Cannot use private definition: " (str module &/+name-separator+ name) " at module: " current-module " @ " (quote <find>))) state)) @@ -334,8 +305,8 @@ " @ " (quote <find>))) state)))))) - &/$TagG find-tag! find-tag - &/$SlotG find-slot! find-slot + find-tag! find-tag &type/Tag + find-slot! find-slot &type/Slot ) (defn if_not_defined [module name then] @@ -426,81 +397,6 @@ ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) state))))) -(do-template [<name> <tag>] - (defn <name> [module name exported? type group index] - (if_not_defined - module name - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Item ?env (&/$End)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (<tag> (&/T [exported? type group index])) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global outside of a global environment: " (str module &/+name-separator+ name))) - state))))) - - define_tag &/$TagG - define_slot &/$SlotG - ) - -(defn declare-labels - "(-> Text (List Text) Bit Type (Lux Null))" - [module record? label-names was-exported? type] - (|do [type-name (&type/type-name type) - :let [[_module _name] type-name] - _ (&/assert! (= module _module) - (str "[Module Error] Cannot define labels for a type belonging to a foreign module: " (&/ident->text type-name)))] - (if (nil? record?) - (return &/unit-tag) - (if record? - (&/map% (fn [idx+label-name] - (|let [[index label-name] idx+label-name] - (define_slot module label-name was-exported? type label-names index))) - (&/enumerate label-names)) - (&/map% (fn [idx+label-name] - (|let [[index label-name] idx+label-name] - (define_tag module label-name was-exported? type label-names index))) - (&/enumerate label-names)))))) - -(defn define-type [module name exported? def-value record? labels] - (if_not_defined - module name - (|case labels - (&/$End) - (define module name exported? &type/Type def-value) - - (&/$Item labelH labelT) - (|do [_ (declare-labels module record? labels exported? def-value)] - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Item ?env (&/$End)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/$TypeG (&/T [exported? def-value (if record? - (&/$Right (&/T [labelH labelT])) - (&/$Left (&/T [labelH labelT])))])) - %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) - state))))))) - (def defs (|do [module &/get-module-name] (fn [state] diff --git a/lux-bootstrapper/src/lux/analyser/record.clj b/lux-bootstrapper/src/lux/analyser/record.clj index 913de4a64..d65211623 100644 --- a/lux-bootstrapper/src/lux/analyser/record.clj +++ b/lux-bootstrapper/src/lux/analyser/record.clj @@ -6,74 +6,124 @@ (lux.analyser [base :as &&] [module :as &&module]))) -(defn head_slot [slot0] +(defn ^:private record_slot [slot0] (|do [[module name] (&&/resolved-ident slot0) - _exported?&type&slots&_index (fn [lux] - (|case ((&&module/find-slot module name) lux) - (&/$Left error) - (&/$Right (&/T [lux &/$None])) - - (&/$Right [lux* output]) - (&/$Right (&/T [lux* (&/$Some output)]))))] - (return (|case _exported?&type&slots&_index - (&/$Some [_exported? type slots _index]) - (&/$Some (&/T [module slots type])) + exported?&label (fn [lux] + (|case ((&&module/find-slot module name) lux) + (&/$Left error) + (&/$Right (&/T [lux &/$None])) + + (&/$Right [lux* output]) + (&/$Right (&/T [lux* (&/$Some output)]))))] + (return (|case exported?&label + (&/$Some [exported? [label* type]]) + (&/$Some (&/T [label* type])) (&/$None) &/$None)))) +(defn ^:private slot_type + "(-> [Label Code] Type)" + [it] + (|let [[[label* type] value] it] + type)) + +(defn ^:private same_record? + "(-> (List [Label Code]) Bit)" + [it] + (|case it + (&/$Item head tail) + (|let [expected (slot_type head)] + (&/|every? (fn [it] (->> it slot_type (&type/type= expected))) + tail)) + + (&/$End) + false)) + +(defn ^:private complete_record? + "(-> (List [Label Code]) Bit)" + [it] + (loop [expected_lefts 0 + remaining it] + (|case remaining + (&/$Item [[label* type] value] (&/$End)) + (|case label* + (&/$Some [lefts true family]) + (= (dec expected_lefts) lefts) + + (&/$None) + (= 0 expected_lefts)) + + (&/$Item [[(&/$Some [lefts false family]) type] value] tail) + (and (= expected_lefts lefts) + (recur (inc expected_lefts) tail)) + + _ + false))) + ;; [Exports] (defn order-record "(-> (List Syntax) (Lux (Maybe (List Syntax))))" [pattern_matching? pairs] - (if (even? (&/|length pairs)) - (let [pairs (&/|as-pairs pairs)] - (|do [module&slot-group&slot-type (|case pairs - (&/$End) - (|do [module &/get-module-name] - (return (&/$Some (&/T [module &/$End &type/Any])))) - - (&/$Item [[_ (&/$Identifier slot0)] _] _) - (|case slot0 - ["" short0] - (if pattern_matching? - (return &/$None) - (|do [local? (&&module/find_local short0)] - (|case local? - (&/$None) - (head_slot slot0) - - (&/$Some [local _inner _outer]) - (return &/$None)))) - - [module0 short0] - (head_slot slot0)) - - _ - (return &/$None))] - (|case module&slot-group&slot-type - (&/$Some [module slot-group slot-type]) - (|do [=pairs (&/map% (fn [kv] - (|case kv - [[_ (&/$Identifier k)] v] - (|do [=k (&&/resolved-ident k)] - (return (&/T [(&/ident->text =k) v]))) - - _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be slots."))) - pairs) - _ (let [num-expected (&/|length slot-group) - num-got (&/|length =pairs)] - (&/assert! (= num-expected num-got) - (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) - =members (&/map% (fn [slot] - (let [slot (&/ident->text (&/T [module slot]))] - (if-let [member (&/|get slot =pairs)] - (return member) - (&/fail-with-loc (str "[Analyser Error] Missing slot: " slot))))) - slot-group)] - (return (&/$Some (&/T [=members slot-type])))) - - (&/$None) + (let [arity (&/|length pairs)] + (cond (= 0 arity) + (return &/$None) + + (even? arity) + (let [pairs (&/|as-pairs pairs)] + (|do [resolved_slots* (&/map% (fn [pair] + (|case pair + [[_ (&/$Identifier slot0)] value] + (|case slot0 + ["" short0] + (if pattern_matching? + (return &/$None) + (|do [local? (&&module/find_local short0)] + (|case local? + (&/$None) + (|do [slot (record_slot slot0)] + (return (|case slot + (&/$Some slot*) + (&/$Some (&/T [slot* value])) + + (&/$None) + &/$None))) + + (&/$Some [local _inner _outer]) + (return &/$None)))) + + [module0 short0] + (|do [slot (record_slot slot0)] + (return (|case slot + (&/$Some slot*) + (&/$Some (&/T [slot* value])) + + (&/$None) + &/$None)))) + + _ + (return &/$None))) + pairs)] + (|case (&/all_maybe resolved_slots*) + (&/$Some resolved_slots) + (|do [:let [sorted_slots (->> resolved_slots + &/->seq + (sort (fn [left right] + (|let [[[(&/$Some [leftsL right?L familyL]) typeL] valueL] left + [[(&/$Some [leftsR right?R familyR]) typeR] valueR] right] + (if (= leftsL leftsR) + (not right?L) + (< leftsL leftsR))))) + &/->list)] + _ (&/assert! (same_record? sorted_slots) + "[Analyser Error] Slots correspond to different record types.") + _ (&/assert! (complete_record? sorted_slots) + "[Analyser Error] Missing record slots.")] + (return (&/$Some (&/T [(&/|map &/|second sorted_slots) + (slot_type (&/|head sorted_slots))])))) + + (&/$None) + (return &/$None)))) + + true (return &/$None)))) - (return &/$None))) diff --git a/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj index 39806f73f..8e99d8cde 100644 --- a/lux-bootstrapper/src/lux/base.clj +++ b/lux-bootstrapper/src/lux/base.clj @@ -150,9 +150,6 @@ (defvariant ("DefinitionG" 1) - ("TypeG" 1) - ("TagG" 1) - ("SlotG" 1) ("AliasG" 1)) (deftuple @@ -1520,3 +1517,25 @@ ($Left ^String msg) (fail* msg))))) + +(defn all_maybe + "(All (_ value) + (-> (List (Maybe value)) + (Maybe (List value))))" + [it] + (|case it + ($Item head tail) + (|case head + ($Some head*) + (|case (all_maybe tail) + ($Some tail*) + ($Some ($Item head* tail*)) + + ($None) + $None) + + ($None) + $None) + + ($End) + ($Some $End))) diff --git a/lux-bootstrapper/src/lux/compiler/cache.clj b/lux-bootstrapper/src/lux/compiler/cache.clj index 931b6a165..301ddb7ef 100644 --- a/lux-bootstrapper/src/lux/compiler/cache.clj +++ b/lux-bootstrapper/src/lux/compiler/cache.clj @@ -81,23 +81,6 @@ [def-type _] (&&&type/deserialize-type _type)] (|do [def-value (load-def-value module _name)] (&a-module/define module _name (= "1" _exported?) def-type def-value))) - ":" (let [[_ _name _exported? _record? _head _tail] parts - labels (&/$Item _head (if _tail - (&/->list (seq (.split _tail "\\."))) - &/$End))] - (|do [def-value (load-def-value module _name)] - (&a-module/define-type - module _name - (= "1" _exported?) - def-value (= "1" _record?) labels))) - ;; "T" (let [[_ _name _exported? _type _index _group] parts - ;; [_type _] (&&&type/deserialize-type _type) - ;; _group (&/->list (seq (.split _group "\\.")))] - ;; (&a-module/define_tag module _name (= "1" _exported?) _type _group (Long/parseLong _index))) - ;; "S" (let [[_ _name _exported? _type _index _group] parts - ;; [_type _] (&&&type/deserialize-type _type) - ;; _group (&/->list (seq (.split _group "\\.")))] - ;; (&a-module/define_slot module _name (= "1" _exported?) _type _group (Long/parseLong _index))) ))) (defn ^:private uninstall-cache [module] diff --git a/lux-bootstrapper/src/lux/compiler/core.clj b/lux-bootstrapper/src/lux/compiler/core.clj index 5ba14e3ed..f3fefdc74 100644 --- a/lux-bootstrapper/src/lux/compiler/core.clj +++ b/lux-bootstrapper/src/lux/compiler/core.clj @@ -61,48 +61,7 @@ datum-separator (if exported? "1" "0") datum-separator (&&&type/serialize-type ?def-type) ;; Next - entry-separator def-entries) - - (&/$TypeG [exported? value labels]) - (let [[record? head tail] (|case labels - (&/$Left [head tail]) - [false head tail] - - (&/$Right [head tail]) - [true head tail])] - (str ":" - datum-separator ?name - datum-separator (if exported? "1" "0") - datum-separator (if record? "1" "0") - datum-separator head - datum-separator (->> tail - (&/|interpose &/+name-separator+) - (&/fold str "")) - ;; Next - entry-separator def-entries)) - - (&/$TagG [?export ?type ?group ?index]) - def-entries - ;; (str "T" - ;; datum-separator ?name - ;; datum-separator (if ?export "1" "0") - ;; datum-separator (&&&type/serialize-type ?type) - ;; datum-separator ?index - ;; datum-separator (->> ?group - ;; (&/|interpose &/+name-separator+) - ;; (&/fold str ""))) - - (&/$SlotG [?export ?type ?group ?index]) - def-entries - ;; (str "S" - ;; datum-separator ?name - ;; datum-separator (if ?export "1" "0") - ;; datum-separator (&&&type/serialize-type ?type) - ;; datum-separator ?index - ;; datum-separator (->> ?group - ;; (&/|interpose &/+name-separator+) - ;; (&/fold str ""))) - ))) + entry-separator def-entries)))) "" defs) import-entries (->> imports diff --git a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj index 4617f7e2e..eabda4265 100644 --- a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj +++ b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj @@ -252,7 +252,7 @@ (str base "\n\n" "Caused by: " (throwable->text cause)) base))) -(defn ^:private install-def! [class-loader current-class module-name ?name ?body exported? type?] +(defn ^:private install-def! [class-loader current-class module-name ?name ?body exported?] (|do [_ (return nil) :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) def-type (&a/expr-type* ?body)] @@ -262,17 +262,12 @@ (str "Error during value initialization:\n" (throwable->text t))))) _ (&/without-repl-closure - (|case type? - (&/$Some [record? labels]) - (&a-module/define-type module-name ?name exported? def-value record? labels) - - (&/$None) - (&a-module/define module-name ?name exported? def-type def-value)))] + (&a-module/define module-name ?name exported? def-type def-value))] (return def-value))) (let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body exported? type?] + (defn compile-def [compile ?name ?body exported?] (|do [module-name &/get-module-name class-loader &/loader] (|case (de-ann ?body) @@ -303,7 +298,7 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body exported? type?)] + def-value (install-def! class-loader current-class module-name ?name ?body exported?)] (return def-value))) _ @@ -329,7 +324,7 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body exported? type?)] + def-value (install-def! class-loader current-class module-name ?name ?body exported?)] (return def-value)))))) (defn compile-program [compile ?program] diff --git a/lux-bootstrapper/src/lux/optimizer.clj b/lux-bootstrapper/src/lux/optimizer.clj index b8095fa22..1c40ac68b 100644 --- a/lux-bootstrapper/src/lux/optimizer.clj +++ b/lux-bootstrapper/src/lux/optimizer.clj @@ -198,10 +198,10 @@ (&/|list ($TextPM _value) $PopPM) - (&a-case/$VariantTestAC _idx _num-options _sub-test) - (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) - (&/$Right _idx) - (&/$Left _idx)))) + (&a-case/$VariantTestAC lefts right? _sub-test) + (&/|++ (&/|list ($VariantPM (if right? + (&/$Right (inc lefts)) + (&/$Left lefts)))) (&/|++ (transform-pm* _sub-test) (&/|list $PopPM))) @@ -1049,7 +1049,7 @@ ;; (not (contains-self-reference? _body))) ;; (inline-loop meta _register-offset _scope _captured =args _body) ;; (&/T [meta ($apply =func =args)])) - + ;; _ ;; (&/T [meta ($apply =func =args)])) ) diff --git a/lux-bootstrapper/src/lux/type.clj b/lux-bootstrapper/src/lux/type.clj index 657eb3077..35a9a4b8e 100644 --- a/lux-bootstrapper/src/lux/type.clj +++ b/lux-bootstrapper/src/lux/type.clj @@ -28,17 +28,13 @@ (def I64 (&/$Named (&/T [&/prelude "I64"]) (&/$UnivQ empty-env (&/$Primitive "#I64" (&/|list (&/$Parameter 1)))))) -(def Nat* (&/$Primitive &&host/nat-data-tag &/$End)) -(def Rev* (&/$Primitive &&host/rev-data-tag &/$End)) -(def Int* (&/$Primitive &&host/int-data-tag &/$End)) - (def Bit (&/$Named (&/T [&/prelude "Bit"]) (&/$Primitive "#Bit" &/$End))) -(def Nat (&/$Named (&/T [&/prelude "Nat"]) (&/$Apply Nat* I64))) -(def Rev (&/$Named (&/T [&/prelude "Rev"]) (&/$Apply Rev* I64))) -(def Int (&/$Named (&/T [&/prelude "Int"]) (&/$Apply Int* I64))) +(def Nat (&/$Named (&/T [&/prelude "Nat"]) (&/$Primitive "#I64" (&/|list (&/$Primitive &&host/nat-data-tag &/$End))))) +(def Int (&/$Named (&/T [&/prelude "Int"]) (&/$Primitive "#I64" (&/|list (&/$Primitive &&host/int-data-tag &/$End))))) +(def Rev (&/$Named (&/T [&/prelude "Rev"]) (&/$Primitive "#I64" (&/|list (&/$Primitive &&host/rev-data-tag &/$End))))) (def Frac (&/$Named (&/T [&/prelude "Frac"]) (&/$Primitive "#Frac" &/$End))) (def Text (&/$Named (&/T [&/prelude "Text"]) (&/$Primitive "#Text" &/$End))) -(def Ident (&/$Named (&/T [&/prelude "Ident"]) (&/$Product Text Text))) +(def Symbol (&/$Named (&/T [&/prelude "Symbol"]) (&/$Product Text Text))) (def Array &&host/Array) @@ -81,10 +77,10 @@ (def Type (&/$Named (&/T [&/prelude "Type"]) - (let [Type (&/$Apply (&/$Parameter 1) (&/$Parameter 0)) + (let [Type (&/$Apply (&/$Primitive "" &/$End) (&/$Parameter 0)) TypeList (&/$Apply Type List) TypePair (&/$Product Type Type)] - (&/$Apply Nothing + (&/$Apply (&/$Primitive "" &/$End) (&/$UnivQ empty-env (&/$Sum ;; Primitive @@ -117,13 +113,21 @@ ;; App TypePair ;; Named - (&/$Product Ident Type))))))))))) + (&/$Product Symbol Type))))))))))) ))))) (def Macro (&/$Named (&/T [&/prelude "Macro"]) (&/$Primitive "#Macro" &/$End))) +(def Tag + (&/$Named (&/T [&/prelude "Tag"]) + (&/$Primitive "#Tag" &/$End))) + +(def Slot + (&/$Named (&/T [&/prelude "Slot"]) + (&/$Primitive "#Slot" &/$End))) + (defn bound? [id] (fn [state] (if-let [type (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] @@ -818,7 +822,7 @@ )) (defn type-name - "(-> Type (Lux Ident))" + "(-> Type (Lux Symbol))" [type] (|case type (&/$Named name _) diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index f35ba4250..d5c43cc7f 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -36,32 +36,11 @@ {4 #0 1}}}) #1) -... (type .public (List a) -... (Variant -... {#End} -... {#Item a (List a)})) -("lux def type tagged" List - {9 #1 - [..prelude "List"] - {7 #0 - {0 #0} - {1 #0 - ... End - Any - ... Item - {2 #0 - {4 #0 1} - {9 #0 - {4 #0 1} - {4 #0 0}}}}}} - {"#End" "#Item"} - #1) - ("lux def" Bit ("lux type check type" {9 #1 [..prelude "Bit"] - {0 #0 "#Bit" {#End}}}) + {0 #0 "#Bit" {0 #0}}}) #1) ("lux def" I64 @@ -70,42 +49,42 @@ [..prelude "I64"] {7 #0 {0 #0} - {0 #0 "#I64" {#Item {4 #0 1} {#End}}}}}) + {0 #0 "#I64" {0 #1 {4 #0 1} {0 #0}}}}}) #1) ("lux def" Nat ("lux type check type" {9 #1 [..prelude "Nat"] - {0 #0 "#I64" {#Item {0 #0 "#Nat" {#End}} {#End}}}}) + {0 #0 "#I64" {0 #1 {0 #0 "#Nat" {0 #0}} {0 #0}}}}) #1) ("lux def" Int ("lux type check type" {9 #1 [..prelude "Int"] - {0 #0 "#I64" {#Item {0 #0 "#Int" {#End}} {#End}}}}) + {0 #0 "#I64" {0 #1 {0 #0 "#Int" {0 #0}} {0 #0}}}}) #1) ("lux def" Rev ("lux type check type" {9 #1 [..prelude "Rev"] - {0 #0 "#I64" {#Item {0 #0 "#Rev" {#End}} {#End}}}}) + {0 #0 "#I64" {0 #1 {0 #0 "#Rev" {0 #0}} {0 #0}}}}) #1) ("lux def" Frac ("lux type check type" {9 #1 [..prelude "Frac"] - {0 #0 "#Frac" {#End}}}) + {0 #0 "#Frac" {0 #0}}}) #1) ("lux def" Text ("lux type check type" {9 #1 [..prelude "Text"] - {0 #0 "#Text" {#End}}}) + {0 #0 "#Text" {0 #0}}}) #1) ("lux def" Symbol @@ -115,21 +94,82 @@ {2 #0 Text Text}}) #1) +... (type .public (List a) +... (Variant +... {#End} +... {#Item a (List a)})) +("lux def" List + ("lux type check type" + {9 #1 + [..prelude "List"] + {7 #0 + {0 #0} + {1 #0 + ... End + Any + ... Item + {2 #0 + {4 #0 1} + {9 #0 + {4 #0 1} + {4 #0 0}}}}}}) + #1) + +... (type .public Tag +... (Primitive "#Tag")) +("lux def" Tag + ("lux type check type" + {9 #1 [..prelude "Tag"] + {0 #0 "#Tag" {0 #0}}}) + #1) + +... (type .public Slot +... (Primitive "#Slot")) +("lux def" Slot + ("lux type check type" + {9 #1 [..prelude "Slot"] + {0 #0 "#Slot" {0 #0}}}) + #1) + +("lux def" Label' + ("lux type check type" + {1 #0 [Any {2 #0 [Nat {2 #0 [Bit {9 #0 Symbol List}]}]}]}) + #0) + +("lux def" list_tags + ("lux type check" + {9 #0 Symbol List} + {0 #1 [[..prelude "#End"] + {0 #1 [[..prelude "#Item"] + {0 #0}]}]}) + #0) +("lux def" #End ("lux type as" Tag [("lux type check" Label' {0 #1 [0 #0 ..list_tags]}) List]) #1) +("lux def" #Item ("lux type as" Tag [("lux type check" Label' {0 #1 [0 #1 ..list_tags]}) List]) #1) + ... (type .public (Maybe a) ... {#None} ... {#Some a}) -("lux def type tagged" Maybe - {9 #1 - [..prelude "Maybe"] - {7 #0 - {#End} - {1 #0 - ... None - Any - ... Some - {4 #0 1}}}} - {"#None" "#Some"} +("lux def" Maybe + ("lux type check type" + {9 #1 + [..prelude "Maybe"] + {7 #0 + {#End} + {1 #0 + ... None + Any + ... Some + {4 #0 1}}}}) #1) +("lux def" maybe_tags + ("lux type check" + {9 #0 Symbol List} + {0 #1 [[..prelude "#None"] + {0 #1 [[..prelude "#Some"] + {0 #0}]}]}) + #0) +("lux def" #None ("lux type as" Tag [("lux type check" Label' {0 #1 [0 #0 ..maybe_tags]}) Maybe]) #1) +("lux def" #Some ("lux type as" Tag [("lux type check" Label' {0 #1 [0 #1 ..maybe_tags]}) Maybe]) #1) ... (type .public Type ... (Rec Type @@ -145,77 +185,149 @@ ... {#ExQ (List Type) Type} ... {#Apply Type Type} ... {#Named Symbol Type}))) -("lux def type tagged" Type - {9 #1 [..prelude "Type"] - ({Type - ({Type_List - ({Type_Pair - {9 #0 - {0 #0 ["" {#End}]} - {7 #0 - {#End} - {1 #0 - ... Primitive - {2 #0 Text Type_List} - {1 #0 - ... Sum - Type_Pair - {1 #0 - ... Product - Type_Pair - {1 #0 - ... Function - Type_Pair - {1 #0 - ... Parameter - Nat - {1 #0 - ... Var - Nat - {1 #0 - ... Ex - Nat - {1 #0 - ... UnivQ - {2 #0 Type_List Type} - {1 #0 - ... ExQ - {2 #0 Type_List Type} - {1 #0 - ... Apply - Type_Pair - ... Named - {2 #0 Symbol Type}}}}}}}}}}}}}} - ("lux type check type" {2 #0 Type Type}))} - ("lux type check type" {9 #0 Type List}))} - ("lux type check type" {9 #0 {0 #0 ["" {#End}]} {4 #0 0}}))} - {"#Primitive" "#Sum" "#Product" "#Function" "#Parameter" "#Var" "#Ex" "#UnivQ" "#ExQ" "#Apply" "#Named"} +("lux def" Type + ("lux type check type" + {9 #1 [..prelude "Type"] + ({Type + ({Type_List + ({Type_Pair + {9 #0 + {0 #0 ["" {#End}]} + {7 #0 + {#End} + {1 #0 + ... Primitive + {2 #0 Text Type_List} + {1 #0 + ... Sum + Type_Pair + {1 #0 + ... Product + Type_Pair + {1 #0 + ... Function + Type_Pair + {1 #0 + ... Parameter + Nat + {1 #0 + ... Var + Nat + {1 #0 + ... Ex + Nat + {1 #0 + ... UnivQ + {2 #0 Type_List Type} + {1 #0 + ... ExQ + {2 #0 Type_List Type} + {1 #0 + ... Apply + Type_Pair + ... Named + {2 #0 Symbol Type}}}}}}}}}}}}}} + ("lux type check type" {2 #0 Type Type}))} + ("lux type check type" {9 #0 Type List}))} + ("lux type check type" {9 #0 {0 #0 ["" {#End}]} {4 #0 0}}))}) + #1) + +("lux def" type_tags + ("lux type check" + {9 #0 Symbol List} + {0 #1 [[..prelude "#Primitive"] + {0 #1 [[..prelude "#Sum"] + {0 #1 [[..prelude "#Product"] + {0 #1 [[..prelude "#Function"] + {0 #1 [[..prelude "#Parameter"] + {0 #1 [[..prelude "#Var"] + {0 #1 [[..prelude "#Ex"] + {0 #1 [[..prelude "#UnivQ"] + {0 #1 [[..prelude "#ExQ"] + {0 #1 [[..prelude "#Apply"] + {0 #1 [[..prelude "#Named"] + {0 #0}]}]}]}]}]}]}]}]}]}]}]}) + #0) +("lux def" #Primitive ("lux type as" Tag [("lux type check" Label' {#Some [0 #0 ..type_tags]}) Type]) #1) +("lux def" #Sum ("lux type as" Tag [("lux type check" Label' {#Some [1 #0 ..type_tags]}) Type]) #1) +("lux def" #Product ("lux type as" Tag [("lux type check" Label' {#Some [2 #0 ..type_tags]}) Type]) #1) +("lux def" #Function ("lux type as" Tag [("lux type check" Label' {#Some [3 #0 ..type_tags]}) Type]) #1) +("lux def" #Parameter ("lux type as" Tag [("lux type check" Label' {#Some [4 #0 ..type_tags]}) Type]) #1) +("lux def" #Var ("lux type as" Tag [("lux type check" Label' {#Some [5 #0 ..type_tags]}) Type]) #1) +("lux def" #Ex ("lux type as" Tag [("lux type check" Label' {#Some [6 #0 ..type_tags]}) Type]) #1) +("lux def" #UnivQ ("lux type as" Tag [("lux type check" Label' {#Some [7 #0 ..type_tags]}) Type]) #1) +("lux def" #ExQ ("lux type as" Tag [("lux type check" Label' {#Some [8 #0 ..type_tags]}) Type]) #1) +("lux def" #Apply ("lux type as" Tag [("lux type check" Label' {#Some [9 #0 ..type_tags]}) Type]) #1) +("lux def" #Named ("lux type as" Tag [("lux type check" Label' {#Some [9 #1 ..type_tags]}) Type]) #1) + +... (type .public Label +... [(Maybe [Nat Bit (List Symbol)]) Type]) +("lux def" Label + ("lux type check" + Type + {#Named [..prelude "Label"] + {#Product {#Apply {#Product Nat {#Product Bit {#Apply Symbol List}}} Maybe} + Type}}) #1) +("lux def" tag + ("lux type check" + {#Function Label Tag} + ([_ it] ("lux type as" Tag it))) + #0) + +("lux def" slot + ("lux type check" + {#Function Label Slot} + ([_ it] ("lux type as" Slot it))) + #0) + ... (type .public Location ... (Record ... [#module Text ... #line Nat ... #column Nat])) -("lux def type tagged" Location - {#Named [..prelude "Location"] - {#Product Text {#Product Nat Nat}}} - ["#module" "#line" "#column"] +("lux def" Location + ("lux type check" + Type + {#Named [..prelude "Location"] + {#Product Text {#Product Nat Nat}}}) #1) +("lux def" location_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#module"] + {#Item [..prelude "#line"] + {#Item [..prelude "#column"] + {#End}}}}) + #0) +("lux def" #module (slot [{#Some [0 #0 ..location_slots]} Location]) #1) +("lux def" #line (slot [{#Some [1 #0 ..location_slots]} Location]) #1) +("lux def" #column (slot [{#Some [1 #1 ..location_slots]} Location]) #1) ... (type .public (Ann m v) ... (Record ... [#meta m ... #datum v])) -("lux def type tagged" Ann - {#Named [..prelude "Ann"] - {#UnivQ {#End} - {#UnivQ {#End} - {#Product - {#Parameter 3} - {#Parameter 1}}}}} - ["#meta" "#datum"] +("lux def" Ann + ("lux type check" + Type + {#Named [..prelude "Ann"] + {#UnivQ {#End} + {#UnivQ {#End} + {#Product + {#Parameter 3} + {#Parameter 1}}}}}) #1) +("lux def" ann_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#meta"] + {#Item [..prelude "#datum"] + {#End}}}) + #0) +("lux def" #meta (slot [{#Some [0 #0 ..ann_slots]} Ann]) #1) +("lux def" #datum (slot [{#Some [0 #1 ..ann_slots]} Ann]) #1) ... (type .public (Code' w) ... (Variant @@ -229,57 +341,88 @@ ... {#Form (List (w (Code' w)))} ... {#Variant (List (w (Code' w)))} ... {#Tuple (List (w (Code' w)))})) -("lux def type tagged" Code' - {#Named [..prelude "Code'"] - ({Code - ({Code_List - {#UnivQ {#End} - {#Sum - ... Bit - Bit +("lux def" Code' + ("lux type check" + Type + {#Named [..prelude "Code'"] + ({Code + ({Code_List + {#UnivQ {#End} {#Sum - ... Nat - Nat + ... Bit + Bit {#Sum - ... Int - Int + ... Nat + Nat {#Sum - ... Rev - Rev + ... Int + Int {#Sum - ... Frac - Frac + ... Rev + Rev {#Sum - ... Text - Text + ... Frac + Frac {#Sum - ... Symbol - Symbol + ... Text + Text {#Sum - ... Form - Code_List + ... Symbol + Symbol {#Sum - ... Variant + ... Form Code_List - ... Tuple - Code_List - }}}}}}}}} - }} - ("lux type check type" {#Apply Code List}))} - ("lux type check type" {#Apply {#Apply {#Parameter 1} - {#Parameter 0}} - {#Parameter 1}}))} - {"#Bit" "#Nat" "#Int" "#Rev" "#Frac" "#Text" "#Symbol" "#Form" "#Variant" "#Tuple"} + {#Sum + ... Variant + Code_List + ... Tuple + Code_List + }}}}}}}}} + }} + ("lux type check" + Type + {#Apply Code List}))} + ("lux type check" + Type + {#Apply {#Apply {#Parameter 1} + {#Parameter 0}} + {#Parameter 1}}))}) #1) +("lux def" code'_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Bit"] + {#Item [..prelude "#Nat"] + {#Item [..prelude "#Int"] + {#Item [..prelude "#Rev"] + {#Item [..prelude "#Frac"] + {#Item [..prelude "#Text"] + {#Item [..prelude "#Symbol"] + {#Item [..prelude "#Form"] + {#Item [..prelude "#Variant"] + {#Item [..prelude "#Tuple"] + {#End}}}}}}}}}}}) + #0) +("lux def" #Bit (tag [{#Some [0 #0 ..code'_tags]} Code']) #1) +("lux def" #Nat (tag [{#Some [1 #0 ..code'_tags]} Code']) #1) +("lux def" #Int (tag [{#Some [2 #0 ..code'_tags]} Code']) #1) +("lux def" #Rev (tag [{#Some [3 #0 ..code'_tags]} Code']) #1) +("lux def" #Frac (tag [{#Some [4 #0 ..code'_tags]} Code']) #1) +("lux def" #Text (tag [{#Some [5 #0 ..code'_tags]} Code']) #1) +("lux def" #Symbol (tag [{#Some [6 #0 ..code'_tags]} Code']) #1) +("lux def" #Form (tag [{#Some [7 #0 ..code'_tags]} Code']) #1) +("lux def" #Variant (tag [{#Some [8 #0 ..code'_tags]} Code']) #1) +("lux def" #Tuple (tag [{#Some [8 #1 ..code'_tags]} Code']) #1) ... (type .public Code ... (Ann Location (Code' (Ann Location)))) ("lux def" Code - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Code"] ({w {#Apply {#Apply w Code'} w}} - ("lux type check type" {#Apply Location Ann}))}) + ("lux type check" Type {#Apply Location Ann}))}) #1) ("lux def" private @@ -307,64 +450,76 @@ #0) ("lux def" bit$ - ("lux type check" {#Function Bit Code} + ("lux type check" + {#Function Bit Code} ([_ value] (_ann {#Bit value}))) #0) ("lux def" nat$ - ("lux type check" {#Function Nat Code} + ("lux type check" + {#Function Nat Code} ([_ value] (_ann {#Nat value}))) #0) ("lux def" int$ - ("lux type check" {#Function Int Code} + ("lux type check" + {#Function Int Code} ([_ value] (_ann {#Int value}))) #0) ("lux def" rev$ - ("lux type check" {#Function Rev Code} + ("lux type check" + {#Function Rev Code} ([_ value] (_ann {#Rev value}))) #0) ("lux def" frac$ - ("lux type check" {#Function Frac Code} + ("lux type check" + {#Function Frac Code} ([_ value] (_ann {#Frac value}))) #0) ("lux def" text$ - ("lux type check" {#Function Text Code} + ("lux type check" + {#Function Text Code} ([_ text] (_ann {#Text text}))) #0) ("lux def" symbol$ - ("lux type check" {#Function Symbol Code} + ("lux type check" + {#Function Symbol Code} ([_ name] (_ann {#Symbol name}))) #0) ("lux def" local$ - ("lux type check" {#Function Text Code} + ("lux type check" + {#Function Text Code} ([_ name] (_ann {#Symbol ["" name]}))) #0) ("lux def" form$ - ("lux type check" {#Function {#Apply Code List} Code} + ("lux type check" + {#Function {#Apply Code List} Code} ([_ tokens] (_ann {#Form tokens}))) #0) ("lux def" variant$ - ("lux type check" {#Function {#Apply Code List} Code} + ("lux type check" + {#Function {#Apply Code List} Code} ([_ tokens] (_ann {#Variant tokens}))) #0) ("lux def" tuple$ - ("lux type check" {#Function {#Apply Code List} Code} + ("lux type check" + {#Function {#Apply Code List} Code} ([_ tokens] (_ann {#Tuple tokens}))) #0) ... (type .public Definition ... [Bit Type Any]) ("lux def" Definition - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Definition"] {#Product Bit {#Product Type Any}}}) .public) @@ -372,94 +527,128 @@ ... (type .public Alias ... Symbol) ("lux def" Alias - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Alias"] Symbol}) .public) -... (type .public Label -... [Bit Type (List Text) Nat]) -("lux def" Label - ("lux type check type" - {#Named [..prelude "Label"] - {#Product Bit {#Product Type {#Product {#Apply Text List} Nat}}}}) - .public) - ... (type .public Global ... (Variant ... {#Definition Definition} -... {#Type [Bit Type (Either [Text (List Text)] [Text (List Text)])]} -... {#Tag Label} -... {#Slot Label} ... {#Alias Alias})) -("lux def type tagged" Global - {#Named [..prelude "Global"] - {#Sum Definition - {#Sum ({labels - {#Product Bit {#Product Type {#Sum labels labels}}}} - {#Product Text {#Apply Text List}}) - {#Sum Label - {#Sum Label - Alias}}}}} - {"#Definition" "#Type" "#Tag" "#Slot" "#Alias"} +("lux def" Global + ("lux type check" + Type + {#Named [..prelude "Global"] + {#Sum Definition + Alias}}) .public) +("lux def" global_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Definition"] + {#Item [..prelude "#Alias"] + {#End}}}) + #0) +("lux def" #Definition (tag [{#Some [0 #0 ..global_tags]} Global]) .public) +("lux def" #Alias (tag [{#Some [0 #1 ..global_tags]} Global]) .public) + ... (type .public (Bindings k v) ... (Record ... [#counter Nat ... #mappings (List [k v])])) -("lux def type tagged" Bindings - {#Named [..prelude "Bindings"] - {#UnivQ {#End} - {#UnivQ {#End} - {#Product - ... counter - Nat - ... mappings - {#Apply {#Product {#Parameter 3} - {#Parameter 1}} - List}}}}} - ["#counter" "#mappings"] +("lux def" Bindings + ("lux type check" + Type + {#Named [..prelude "Bindings"] + {#UnivQ {#End} + {#UnivQ {#End} + {#Product + ... counter + Nat + ... mappings + {#Apply {#Product {#Parameter 3} + {#Parameter 1}} + List}}}}}) .public) +("lux def" bindings_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#counter"] + {#Item [..prelude "#mappings"] + {#End}}}) + #0) +("lux def" #counter (slot [{#Some [0 #0 ..bindings_slots]} Bindings]) .public) +("lux def" #mappings (slot [{#Some [0 #1 ..bindings_slots]} Bindings]) .public) + ... (type .public Ref ... {#Local Nat} ... {#Captured Nat}) -("lux def type tagged" Ref - {#Named [..prelude "Ref"] - {#Sum - ... Local - Nat - ... Captured - Nat}} - {"#Local" "#Captured"} +("lux def" Ref + ("lux type check" + Type + {#Named [..prelude "Ref"] + {#Sum + ... Local + Nat + ... Captured + Nat}}) .public) -... TODO: Get rid of both #name & #inner +("lux def" ref_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Local"] + {#Item [..prelude "#Captured"] + {#End}}}) + #0) +("lux def" #Local (tag [{#Some [0 #0 ..ref_tags]} Ref]) .public) +("lux def" #Captured (tag [{#Some [0 #1 ..ref_tags]} Ref]) .public) + +... TODO: Get rid of both #scope_name & #inner_scopes ... (type .public Scope ... (Record -... [#name (List Text) -... #inner Nat -... #locals (Bindings Text [Type Nat]) +... [#scope_name (List Text) +... #inner_scopes Nat +... #locals (Bindings Text [Type Nat]) ... #captured (Bindings Text [Type Ref])])) -("lux def type tagged" Scope - {#Named [..prelude "Scope"] - {#Product - ... name - {#Apply Text List} +("lux def" Scope + ("lux type check" + Type + {#Named [..prelude "Scope"] {#Product - ... inner - Nat + ... name + {#Apply Text List} {#Product - ... locals - {#Apply {#Product Type Nat} {#Apply Text Bindings}} - ... captured - {#Apply {#Product Type Ref} {#Apply Text Bindings}}}}}} - ["#name" "#inner" "#locals" "#captured"] + ... inner + Nat + {#Product + ... locals + {#Apply {#Product Type Nat} {#Apply Text Bindings}} + ... captured + {#Apply {#Product Type Ref} {#Apply Text Bindings}}}}}}) .public) +("lux def" scope_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#scope_name"] + {#Item [..prelude "#inner_scopes"] + {#Item [..prelude "#locals"] + {#Item [..prelude "#captured"] + {#End}}}}}) + #0) +("lux def" #scope_name (slot [{#Some [0 #0 ..scope_slots]} Scope]) .public) +("lux def" #inner_scopes (slot [{#Some [1 #0 ..scope_slots]} Scope]) .public) +("lux def" #locals (slot [{#Some [2 #0 ..scope_slots]} Scope]) .public) +("lux def" #captured (slot [{#Some [2 #1 ..scope_slots]} Scope]) .public) + ("lux def" Code_List - ("lux type check type" + ("lux type check" + Type {#Apply Code List}) #0) @@ -467,22 +656,34 @@ ... (Variant ... {#Left l} ... {#Right r})) -("lux def type tagged" Either - {#Named [..prelude "Either"] - {#UnivQ {#End} - {#UnivQ {#End} - {#Sum - ... Left - {#Parameter 3} - ... Right - {#Parameter 1}}}}} - {"#Left" "#Right"} +("lux def" Either + ("lux type check" + Type + {#Named [..prelude "Either"] + {#UnivQ {#End} + {#UnivQ {#End} + {#Sum + ... Left + {#Parameter 3} + ... Right + {#Parameter 1}}}}}) .public) +("lux def" either_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Left"] + {#Item [..prelude "#Right"] + {#End}}}) + #0) +("lux def" #Left (tag [{#Some [0 #0 ..either_tags]} Either]) .public) +("lux def" #Right (tag [{#Some [0 #1 ..either_tags]} Either]) .public) + ... (type .public Source ... [Location Nat Text]) ("lux def" Source - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Source"] {#Product Location {#Product Nat Text}}}) .public) @@ -492,19 +693,32 @@ ... #Active ... #Compiled ... #Cached)) -("lux def type tagged" Module_State - {#Named [..prelude "Module_State"] - {#Sum - ... #Active - Any +("lux def" Module_State + ("lux type check" + Type + {#Named [..prelude "Module_State"] {#Sum - ... #Compiled + ... #Active Any - ... #Cached - Any}}} - {"#Active" "#Compiled" "#Cached"} + {#Sum + ... #Compiled + Any + ... #Cached + Any}}}) .public) +("lux def" module_state_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Active"] + {#Item [..prelude "#Compiled"] + {#Item [..prelude "#Cached"] + {#End}}}}) + #0) +("lux def" #Active (tag [{#Some [0 #0 ..module_state_tags]} Module_State]) .public) +("lux def" #Compiled (tag [{#Some [1 #0 ..module_state_tags]} Module_State]) .public) +("lux def" #Cached (tag [{#Some [1 #1 ..module_state_tags]} Module_State]) .public) + ... (type .public Module ... (Record ... [#module_hash Nat @@ -512,80 +726,141 @@ ... #definitions (List [Text Global]) ... #imports (List Text) ... #module_state Module_State])) -("lux def type tagged" Module - {#Named [..prelude "Module"] - {#Product - ... module_hash - Nat +("lux def" Module + ("lux type check" + Type + {#Named [..prelude "Module"] {#Product - ... module_aliases - {#Apply {#Product Text Text} List} + ... module_hash + Nat {#Product - ... definitions - {#Apply {#Product Text Global} List} + ... module_aliases + {#Apply {#Product Text Text} List} {#Product - ... imports - {#Apply Text List} - ... module_state - Module_State - }}}}} - ["#module_hash" "#module_aliases" "#definitions" "#imports" "#module_state"] + ... definitions + {#Apply {#Product Text Global} List} + {#Product + ... imports + {#Apply Text List} + ... module_state + Module_State + }}}}}) .public) +("lux def" module_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#module_hash"] + {#Item [..prelude "#module_aliases"] + {#Item [..prelude "#definitions"] + {#Item [..prelude "#imports"] + {#Item [..prelude "#module_state"] + {#End}}}}}}) + #0) +("lux def" #module_hash (slot [{#Some [0 #0 ..module_slots]} Module]) .public) +("lux def" #module_aliases (slot [{#Some [1 #0 ..module_slots]} Module]) .public) +("lux def" #definitions (slot [{#Some [2 #0 ..module_slots]} Module]) .public) +("lux def" #imports (slot [{#Some [3 #0 ..module_slots]} Module]) .public) +("lux def" #module_state (slot [{#Some [3 #1 ..module_slots]} Module]) .public) + ... (type .public Type_Context ... (Record ... [#ex_counter Nat ... #var_counter Nat ... #var_bindings (List [Nat (Maybe Type)])])) -("lux def type tagged" Type_Context - {#Named [..prelude "Type_Context"] - {#Product ... ex_counter - Nat - {#Product ... var_counter +("lux def" Type_Context + ("lux type check" + Type + {#Named [..prelude "Type_Context"] + {#Product ... ex_counter Nat - ... var_bindings - {#Apply {#Product Nat {#Apply Type Maybe}} - List}}}} - ["#ex_counter" "#var_counter" "#var_bindings"] + {#Product ... var_counter + Nat + ... var_bindings + {#Apply {#Product Nat {#Apply Type Maybe}} + List}}}}) .public) +("lux def" type_context_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#ex_counter"] + {#Item [..prelude "#var_counter"] + {#Item [..prelude "#var_bindings"] + {#End}}}}) + #0) +("lux def" #ex_counter (slot [{#Some [0 #0 ..type_context_slots]} Type_Context]) .public) +("lux def" #var_counter (slot [{#Some [1 #0 ..type_context_slots]} Type_Context]) .public) +("lux def" #var_bindings (slot [{#Some [1 #1 ..type_context_slots]} Type_Context]) .public) + ... (type .public Mode -... #Build -... #Eval -... #Interpreter) -("lux def type tagged" Mode - {#Named [..prelude "Mode"] - {#Sum ... Build - Any - {#Sum ... Eval +... (Variant +... {#Build} +... {#Eval} +... {#Interpreter})) +("lux def" Mode + ("lux type check" + Type + {#Named [..prelude "Mode"] + {#Sum + ... Build Any - ... Interpreter - Any}}} - {"#Build" "#Eval" "#Interpreter"} + {#Sum + ... Eval + Any + ... Interpreter + Any}}}) .public) +("lux def" mode_tags + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#Build"] + {#Item [..prelude "#Eval"] + {#Item [..prelude "#Interpreter"] + {#End}}}}) + #0) +("lux def" #Build (tag [{#Some [0 #0 ..mode_tags]} Mode]) .public) +("lux def" #Eval (tag [{#Some [1 #0 ..mode_tags]} Mode]) .public) +("lux def" #Interpreter (tag [{#Some [1 #1 ..mode_tags]} Mode]) .public) + ... (type .public Info ... (Record ... [#target Text ... #version Text ... #mode Mode ... #configuration (List [Text Text])])) -("lux def type tagged" Info - {#Named [..prelude "Info"] - {#Product - ... target - Text +("lux def" Info + ("lux type check" + Type + {#Named [..prelude "Info"] {#Product - ... version + ... target Text {#Product - ... mode - Mode - ... configuration - {#Apply {#Product Text Text} List}}}}} - ["#target" "#version" "#mode" "#configuration"] + ... version + Text + {#Product + ... mode + Mode + ... configuration + {#Apply {#Product Text Text} List}}}}}) .public) +("lux def" info_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#target"] + {#Item [..prelude "#version"] + {#Item [..prelude "#mode"] + {#Item [..prelude "#configuration"] + {#End}}}}}) + #0) +("lux def" #target (slot [{#Some [0 #0 ..info_slots]} Info]) .public) +("lux def" #version (slot [{#Some [1 #0 ..info_slots]} Info]) .public) +("lux def" #mode (slot [{#Some [2 #0 ..info_slots]} Info]) .public) +("lux def" #configuration (slot [{#Some [2 #1 ..info_slots]} Info]) .public) + ... (type .public Lux ... (Rec Lux ... (Record @@ -602,60 +877,94 @@ ... #extensions Any ... #eval (-> Type Code (-> Lux (Either Text [Lux Any]))) ... #host Any]))) -("lux def type tagged" Lux - {#Named [..prelude "Lux"] - ({Lux - {#Apply {0 #0 ["" {#End}]} - {#UnivQ {#End} - {#Product - ... info - Info +("lux def" Lux + ("lux type check" + Type + {#Named [..prelude "Lux"] + ({Lux + {#Apply {0 #0 ["" {#End}]} + {#UnivQ {#End} {#Product - ... source - Source + ... info + Info {#Product - ... location - Location + ... source + Source {#Product - ... current_module - {#Apply Text Maybe} + ... location + Location {#Product - ... modules - {#Apply {#Product Text Module} List} + ... current_module + {#Apply Text Maybe} {#Product - ... scopes - {#Apply Scope List} + ... modules + {#Apply {#Product Text Module} List} {#Product - ... type_context - Type_Context + ... scopes + {#Apply Scope List} {#Product - ... expected - {#Apply Type Maybe} + ... type_context + Type_Context {#Product - ... seed - Nat + ... expected + {#Apply Type Maybe} {#Product - ... scope_type_vars - {#Apply Nat List} + ... seed + Nat {#Product - ... extensions - Any + ... scope_type_vars + {#Apply Nat List} {#Product - ... eval - {#Function Type - {#Function Code - {#Function Lux - {#Sum Text {#Product Lux Any}}}}} - ... host - Any}}}}}}}}}}}}}}} - {#Apply {0 #0 ["" {#End}]} {#Parameter 0}})} - ["#info" "#source" "#location" "#current_module" "#modules" "#scopes" "#type_context" "#expected" "#seed" "#scope_type_vars" "#extensions" "#eval" "#host"] + ... extensions + Any + {#Product + ... eval + {#Function Type + {#Function Code + {#Function Lux + {#Sum Text {#Product Lux Any}}}}} + ... host + Any}}}}}}}}}}}}}}} + {#Apply {0 #0 ["" {#End}]} {#Parameter 0}})}) .public) +("lux def" lux_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#info"] + {#Item [..prelude "#source"] + {#Item [..prelude "#location"] + {#Item [..prelude "#current_module"] + {#Item [..prelude "#modules"] + {#Item [..prelude "#scopes"] + {#Item [..prelude "#type_context"] + {#Item [..prelude "#expected"] + {#Item [..prelude "#seed"] + {#Item [..prelude "#scope_type_vars"] + {#Item [..prelude "#extensions"] + {#Item [..prelude "#eval"] + {#Item [..prelude "#host"] + {#End}}}}}}}}}}}}}}) + #0) +("lux def" #info (slot [{#Some [0 #0 ..lux_slots]} Lux]) .public) +("lux def" #source (slot [{#Some [1 #0 ..lux_slots]} Lux]) .public) +("lux def" #location (slot [{#Some [2 #0 ..lux_slots]} Lux]) .public) +("lux def" #current_module (slot [{#Some [3 #0 ..lux_slots]} Lux]) .public) +("lux def" #modules (slot [{#Some [4 #0 ..lux_slots]} Lux]) .public) +("lux def" #scopes (slot [{#Some [5 #0 ..lux_slots]} Lux]) .public) +("lux def" #type_context (slot [{#Some [6 #0 ..lux_slots]} Lux]) .public) +("lux def" #expected (slot [{#Some [7 #0 ..lux_slots]} Lux]) .public) +("lux def" #seed (slot [{#Some [8 #0 ..lux_slots]} Lux]) .public) +("lux def" #scope_type_vars (slot [{#Some [9 #0 ..lux_slots]} Lux]) .public) +("lux def" #extensions (slot [{#Some [10 #0 ..lux_slots]} Lux]) .public) +("lux def" #eval (slot [{#Some [11 #0 ..lux_slots]} Lux]) .public) +("lux def" #host (slot [{#Some [11 #1 ..lux_slots]} Lux]) .public) + ... (type .public (Meta a) ... (-> Lux (Either Text [Lux a]))) ("lux def" Meta - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Meta"] {#UnivQ {#End} {#Function Lux @@ -666,7 +975,8 @@ ... (type .public Macro' ... (-> (List Code) (Meta (List Code)))) ("lux def" Macro' - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Macro'"] {#Function Code_List {#Apply Code_List Meta}}}) .public) @@ -674,7 +984,8 @@ ... (type .public Macro ... (Primitive "#Macro")) ("lux def" Macro - ("lux type check type" + ("lux type check" + Type {#Named [..prelude "Macro"] {#Primitive "#Macro" {#End}}}) .public) @@ -783,19 +1094,22 @@ #0) ("lux def" as_def - ("lux type check" {#Function Code {#Function Code {#Function Code Code}}} + ("lux type check" + {#Function Code {#Function Code {#Function Code Code}}} (function'' [name value export_policy] (form$ {#Item (text$ "lux def") {#Item name {#Item value {#Item export_policy {#End}}}}}))) #0) ("lux def" as_checked - ("lux type check" {#Function Code {#Function Code Code}} + ("lux type check" + {#Function Code {#Function Code Code}} (function'' [type value] (form$ {#Item (text$ "lux type check") {#Item type {#Item value {#End}}}}))) #0) ("lux def" as_function - ("lux type check" {#Function Code {#Function {#Apply Code List} {#Function Code Code}}} + ("lux type check" + {#Function Code {#Function {#Apply Code List} {#Function Code Code}}} (function'' as_function [self inputs output] ({{#End} output @@ -808,7 +1122,8 @@ #0) ("lux def" as_macro - ("lux type check" {#Function Code Code} + ("lux type check" + {#Function Code Code} (function'' [expression] (form$ {#Item (text$ "lux type as") {#Item (symbol$ [..prelude "Macro"]) @@ -894,8 +1209,9 @@ (def' .private (list#reversed list) {#UnivQ {#End} {#Function ($ List {#Parameter 1}) ($ List {#Parameter 1})}} - (list#mix ("lux type check" {#UnivQ {#End} - {#Function {#Parameter 1} {#Function ($ List {#Parameter 1}) ($ List {#Parameter 1})}}} + (list#mix ("lux type check" + {#UnivQ {#End} + {#Function {#Parameter 1} {#Function ($ List {#Parameter 1}) ($ List {#Parameter 1})}}} (function'' [head tail] {#Item head tail})) {#End} list)) @@ -1108,7 +1424,7 @@ ..#scope_type_vars _ ..#eval _] (list#mix (function'' [scope verdict] ({[#1] #1 - _ ({[..#name _ ..#inner _ ..#captured _ + _ ({[..#scope_name _ ..#inner_scopes _ ..#captured _ ..#locals [..#counter _ ..#mappings locals]] (list#mix (function'' [local verdict] @@ -1197,7 +1513,8 @@ Macro (macro (_ tokens) ({{#Item output inputs} - (meta#in {#Item (list#mix ("lux type check" {#Function Code {#Function Code Code}} + (meta#in {#Item (list#mix ("lux type check" + {#Function Code {#Function Code Code}} (function'' [i o] (variant$ {#Item (symbol$ [..prelude "#Function"]) {#Item i {#Item o {#End}}}}))) output inputs) @@ -1305,8 +1622,9 @@ (macro (_ tokens) ({{#Item [_ {#Tuple bindings}] {#Item body {#End}}} ({{#Some bindings} - (meta#in (list (list#mix ("lux type check" (-> (Tuple Code Code) Code - Code) + (meta#in (list (list#mix ("lux type check" + (-> (Tuple Code Code) Code + Code) (function' [binding body] ({[label value] (form$ (list (variant$ (list label body)) value))} @@ -1408,17 +1726,27 @@ ... #in) ... (is (All (_ a b) (-> (-> a (m b)) (m a) (m b))) ... #then))) -("lux def type tagged" Monad - {#Named [..prelude "Monad"] - (All (_ !) - (Tuple (All (_ a) - (-> a ($ ! a))) - (All (_ a b) - (-> (-> a ($ ! b)) - ($ ! a) - ($ ! b)))))} - ["#in" "#then"] +("lux def" Monad + ("lux type check" + Type + {#Named [..prelude "Monad"] + (All (_ !) + (Tuple (All (_ a) + (-> a ($ ! a))) + (All (_ a b) + (-> (-> a ($ ! b)) + (-> ($ ! a) ($ ! b))))))}) + #0) + +("lux def" monad_slots + ("lux type check" + {#Apply Symbol List} + {#Item [..prelude "#in"] + {#Item [..prelude "#then"] + {#End}}}) #0) +("lux def" #in (slot [{#Some [0 #0 ..monad_slots]} Monad]) .private) +("lux def" #then (slot [{#Some [0 #1 ..monad_slots]} Monad]) .private) (def' .private maybe#monad ($ Monad Maybe) @@ -1427,8 +1755,11 @@ #then (function' [f ma] - ({{#None} {#None} - {#Some a} (f a)} + ({{#None} + {#None} + + {#Some a} + (f a)} ma))]) (def' .private meta#monad @@ -1455,7 +1786,8 @@ ({{#Some bindings} (let' [g!in (local$ "in") g!then (local$ " then ") - body' (list#mix ("lux type check" (-> (Tuple Code Code) Code Code) + body' (list#mix ("lux type check" + (-> (Tuple Code Code) Code Code) (function' [binding body'] (let' [[var value] binding] ({[_ {#Symbol [module short]}] @@ -1571,10 +1903,8 @@ ..#scope_type_vars scope_type_vars ..#eval _eval] state] ({{#Some [..#module_hash _ ..#module_aliases _ ..#definitions definitions ..#imports _ ..#module_state _]} ({{#Some constant} - ({{#Definition _} {#Right [state full_name]} - {#Tag _} {#Right [state full_name]} - {#Slot _} {#Right [state full_name]} - {#Type _} {#Right [state full_name]} + ({{#Definition _} + {#Right [state full_name]} {#Alias real_name} {#Right [state real_name]}} @@ -1648,8 +1978,8 @@ (list#one ("lux type check" (-> Scope ($ Maybe Type)) (function' [env] - (let' [[..#name _ - ..#inner _ + (let' [[..#scope_name _ + ..#inner_scopes _ ..#locals [..#counter _ ..#mappings locals] ..#captured _] env] (list#one ("lux type check" @@ -1707,18 +2037,7 @@ {#Definition [exported? def_type def_value]} (if (available? expected_module current_module exported?) {#Right [state [def_type def_value]]} - {#Left (text#composite "Unavailable definition: " (symbol#encoded name))}) - - {#Type [exported? type labels]} - (if (available? expected_module current_module exported?) - {#Right [state [..Type type]]} - {#Left (text#composite "Unavailable definition: " (symbol#encoded name))}) - - {#Tag _} - {#Left (text#composite "Unknown definition: " (symbol#encoded name))} - - {#Slot _} - {#Left (text#composite "Unknown definition: " (symbol#encoded name))}} + {#Left (text#composite "Unavailable definition: " (symbol#encoded name))})} definition)} (property#value expected_short definitions))} (property#value expected_module modules)))) @@ -1742,7 +2061,7 @@ (definition_value global lux)} module)))) -(def' .private (bit#and left right) +(def' .private (and' left right) (-> Bit Bit Bit) (if left right @@ -1752,7 +2071,7 @@ (-> Symbol Symbol Bit) (let' [[moduleL shortL] left [moduleR shortR] right] - (all bit#and + (all and' (text#= moduleL moduleR) (text#= shortL shortR)))) @@ -1779,29 +2098,29 @@ (def' .private (type#= left right) (-> Type Type Bit) ({[{#Primitive nameL parametersL} {#Primitive nameR parametersR}] - (all bit#and + (all and' (text#= nameL nameR) ("lux i64 =" (list#size parametersL) (list#size parametersR)) (every? (function' [l,r] (let' [[itL itR] l,r] (type#= itL itR))) (zipped_2 parametersL parametersR))) [{#Sum leftL rightL} {#Sum leftR rightR}] - (all bit#and + (all and' (type#= leftL leftR) (type#= rightL rightR)) [{#Product leftL rightL} {#Product leftR rightR}] - (all bit#and + (all and' (type#= leftL leftR) (type#= rightL rightR)) [{#Function leftL rightL} {#Function leftR rightR}] - (all bit#and + (all and' (type#= leftL leftR) (type#= rightL rightR)) [{#Apply leftL rightL} {#Apply leftR rightR}] - (all bit#and + (all and' (type#= leftL leftR) (type#= rightL rightR)) @@ -1815,21 +2134,21 @@ ("lux i64 =" idL idR) [{#UnivQ envL bodyL} {#UnivQ envR bodyR}] - (all bit#and + (all and' ("lux i64 =" (list#size envL) (list#size envR)) (every? (function' [l,r] (let' [[itL itR] l,r] (type#= itL itR))) (zipped_2 envL envR)) (type#= bodyL bodyR)) [{#ExQ envL bodyL} {#ExQ envR bodyR}] - (all bit#and + (all and' ("lux i64 =" (list#size envL) (list#size envR)) (every? (function' [l,r] (let' [[itL itR] l,r] (type#= itL itR))) (zipped_2 envL envR)) (type#= bodyL bodyR)) [{#Named nameL anonL} {#Named nameR anonR}] - (all bit#and + (all and' (symbol#= nameL nameR) (type#= anonL anonR)) @@ -2109,7 +2428,8 @@ Macro (macro (_ tokens) ({{#Item [init apps]} - (meta#in (list (list#mix ("lux type check" (-> Code Code Code) + (meta#in (list (list#mix ("lux type check" + (-> Code Code Code) (function' [app acc] ({[_ {#Variant parts}] (variant$ (list#composite parts (list acc))) @@ -2134,7 +2454,8 @@ Macro (macro (_ tokens) ({{#Item [init apps]} - (meta#in (list (list#mix ("lux type check" (-> Code Code Code) + (meta#in (list (list#mix ("lux type check" + (-> Code Code Code) (function' [app acc] ({[_ {#Variant parts}] (variant$ (list#composite parts (list acc))) @@ -2254,7 +2575,8 @@ (macro (_ tokens) ({{#Item [[_ {#Tuple bindings}] {#Item [[_ {#Tuple templates}] data]}]} ({[{#Some bindings'} {#Some data'}] - (let' [apply ("lux type check" (-> Replacement_Environment ($ List Code)) + (let' [apply ("lux type check" + (-> Replacement_Environment ($ List Code)) (function' [env] (list#each (realized_template env) templates))) num_bindings (list#size bindings')] (if (every? (function' [size] ("lux i64 =" num_bindings size)) @@ -2321,7 +2643,8 @@ (def' .private (nat#encoded value) (-> Nat Text) ({[0] "0" - _ (let' [loop ("lux type check" (-> Nat Text Text) + _ (let' [loop ("lux type check" + (-> Nat Text Text) (function' again [input output] (if ("lux i64 =" 0 input) output @@ -2344,7 +2667,8 @@ (let' [sign (if ("lux i64 <" value +0) "+" "-")] - (("lux type check" (-> Int Text Text) + (("lux type check" + (-> Int Text Text) (function' again [input output] (if ("lux i64 =" +0 input) (text#composite sign output) @@ -2389,16 +2713,7 @@ (if (text#= module current_module) {#Some ("lux type as" Macro def_value)} {#None})) - {#None}) - - {#Type [exported? type labels]} - {#None} - - {#Tag _} - {#None} - - {#Slot _} - {#None}} + {#None})} ("lux type check" Global gdef)))) (def' .private (named_macro full_name) @@ -2654,7 +2969,8 @@ (do meta#monad [type_fn (normal_type type_fn) args (monad#each meta#monad normal_type args)] - (in (list#mix ("lux type check" (-> Code Code Code) + (in (list#mix ("lux type check" + (-> Code Code Code) (function' [arg type_fn] (` {.#Apply (, arg) (, type_fn)}))) type_fn args))) @@ -2713,8 +3029,8 @@ ..#source source/pre ..#current_module current_module/pre ..#modules modules/pre - ..#scopes (list#partial [#name (list) - #inner 0 + ..#scopes (list#partial [#scope_name (list) + #inner_scopes 0 #locals [#counter 0 #mappings (list [..quantification_level [.Nat ("lux type as" Nat -1)]])] #captured [#counter 0 @@ -2817,9 +3133,9 @@ (macro (_ tokens) ({{#Item value actions} (let' [dummy (local$ "")] - (meta#in (list (list#mix ("lux type check" (-> Code Code Code) - (function' [pre post] (` ({(, dummy) (, post)} - (, pre))))) + (meta#in (list (list#mix ("lux type check" + (-> Code Code Code) + (function' [pre post] (` ({(, dummy) (, post)} (, pre))))) value actions)))) @@ -2855,12 +3171,13 @@ (def' .private (type#encoded type) (-> Type Text) ({{#Primitive name params} - ({{#End} - name - - _ - (all text#composite "(" name " " (|> params (list#each type#encoded) (list#interposed " ") list#reversed (list#mix text#composite "")) ")")} - params) + (all text#composite + "(Primitive " (text#encoded name) + (|> params + (list#each (function' [it] (|> it type#encoded (text#composite " ")))) + list#reversed + (list#mix text#composite "")) + ")") {#Sum _} (all text#composite "{" (|> (flat_variant type) (list#each type#encoded) (list#interposed " ") list#reversed (list#mix text#composite "")) "}") @@ -2943,6 +3260,12 @@ {#Primitive "#I64" {#Item {#Primitive "#Rev" {#End}} {#End}}} (in (rev$ (as Rev value))) + + {#Primitive "#Tag" {#End}} + (in (symbol$ name)) + + {#Primitive "#Slot" {#End}} + (in (symbol$ name)) _ (failure (all text#composite @@ -3621,7 +3944,7 @@ {#Left (all text#composite "Unknown module: " name)})))) (def (type_slot [module name]) - (-> Symbol (Meta [Nat (List Symbol) Bit Type])) + (-> Symbol (Meta [Bit Label])) (do meta#monad [=module (..module module) .let [[..#module_hash _ @@ -3630,17 +3953,50 @@ ..#imports _ ..#module_state _] =module]] (when (property#value name definitions) - {#Some {#Slot [exported type group index]}} - (meta#in [index - (list#each (function (_ slot) - [module slot]) - group) - exported - type]) + {#Some {#Definition [exported type value]}} + (meta#in [exported (as Label value)]) _ (failure (text#composite "Unknown slot: " (symbol#encoded [module name])))))) +(def (slot_family expected_module expected_record) + (-> Text Type (Meta (Maybe (List Symbol)))) + (do meta#monad + [module (..module expected_module) + actual_module ..current_module_name + .let [[..#module_hash _ + ..#module_aliases _ + ..#definitions definitions + ..#imports _ + ..#module_state _] module]] + (in ((is (-> (List [Text Global]) + (Maybe (List Symbol))) + (function (again remaining) + (when remaining + {#Item [slot head] tail} + (when head + {#Definition [exported? type value]} + (if (and (type#= Slot type) + (or exported? + (text#= expected_module actual_module))) + (let [[label actual_record] (as Label value)] + (if (type#= expected_record actual_record) + (when label + {#Some [lefts right? family]} + {#Some family} + + {#None} + {#Some (list [expected_module slot])}) + (again tail))) + (again tail)) + + _ + (again tail)) + + {#End} + {#None}))) + definitions)))) + (def (record_slots type) (-> Type (Meta (Maybe [(List Symbol) (List Type)]))) (when type @@ -3662,15 +4018,17 @@ ..#imports _ ..#module_state _] =module]] (when (property#value name definitions) - {#Some {#Type [exported? {#Named _ _type} {#Right slots}]}} - (when (interface_methods _type) - {#Some members} - (meta#in {#Some [(list#each (function (_ slot) [module slot]) - {#Item slots}) - members]}) + {#Some {#Definition [exported? type value]}} + (if (type#= Type type) + (do meta#monad + [slots (slot_family module (as Type value))] + (when [slots (interface_methods (as Type value))] + [{#Some slots} {#Some members}] + (in {#Some [slots members]}) - _ - (meta#in {#None})) + _ + (record_slots unnamed))) + (in {#None})) _ (record_slots unnamed))) @@ -3867,6 +4225,51 @@ (meta#in [type {#None}])} it)) +(def (enumeration' idx xs) + (All (_ a) + (-> Nat (List a) (List [Nat a]))) + (when xs + {#Item x xs'} + {#Item [idx x] (enumeration' ("lux i64 +" 1 idx) xs')} + + {#End} + {#End})) + +(def (enumeration xs) + (All (_ a) + (-> (List a) (List [Nat a]))) + (enumeration' 0 xs)) + +(def (label_definitions module export_policy associated_type label_type family labels) + (-> Text Code Code Code Code (List Text) (List Code)) + (when (list#reversed labels) + (list single) + (list (` (def (, export_policy) (, (local$ single)) + (<| (as (, label_type)) + (is Label) + [{#None} (, associated_type)])))) + + (list#partial right lefts) + (list#partial + (` (def (, family) + (List Symbol) + (list (,* (list#each (function (_ it) + (` [(, (text$ module)) (, (text$ it))])) + labels))))) + (` (def (, export_policy) (, (local$ right)) + (<| (as (, label_type)) + (is Label) + [{#Some [(, (nat$ ("lux i64 -" 1 (list#size lefts)))) #1 (, family)]} (, associated_type)]))) + (list#each (function (_ [lefts it]) + (` (def (, export_policy) (, (local$ it)) + (<| (as (, label_type)) + (is Label) + [{#Some [(, (nat$ lefts)) #0 (, family)]} (, associated_type)])))) + (enumeration (list#reversed lefts)))) + + _ + (list))) + (def .public type (macro (_ tokens) (when (typeP tokens) @@ -3874,6 +4277,7 @@ (do meta#monad [type+labels?? (..type_declaration type_codes) module_name current_module_name + g!family (..generated_symbol "g!family") .let' [type_name (local$ name) [type labels??] type+labels?? type' (is (Maybe Code) @@ -3889,23 +4293,22 @@ (let [typeC (` {.#Named [(, (text$ module_name)) (, (text$ name))] (..type_literal (, type''))})] - (meta#in (list (when labels?? - {#Some labels} - (` ("lux def type tagged" (, type_name) - (, typeC) - (, (when labels - {#Left tags} - (` {(,* (list#each text$ tags))}) - - {#Right slots} - (` [(,* (list#each text$ slots))]))) - (, export_policy))) - - _ - (` ("lux def" (, type_name) - ("lux type check type" - (, typeC)) - (, export_policy))))))) + (in (when labels?? + {#Some labels} + (list#partial (` (def (, export_policy) (, type_name) + Type + (, typeC))) + (when labels + {#Left tags} + (label_definitions module_name export_policy type_name (` Tag) g!family tags) + + {#Right slots} + (label_definitions module_name export_policy type_name (` Slot) g!family slots))) + + _ + (list (` (def (, export_policy) (, type_name) + Type + (, typeC))))))) {#None} (failure (..wrong_syntax_error (symbol ..type))))) @@ -4141,18 +4544,7 @@ {#Definition [exported? def_type def_value]} (if exported? (list name) - (list)) - - {#Type [exported? type labels]} - (if exported? - (list name) - (list)) - - {#Tag _} - (list) - - {#Slot _} - (list)))) + (list))))) (let [[..#module_hash _ ..#module_aliases _ ..#definitions definitions ..#imports _ ..#module_state _] =module] definitions))] {#Right state (list#conjoint to_alias)}) @@ -4284,16 +4676,7 @@ (definition_type real_name state) {#Definition [exported? def_type def_value]} - {#Some def_type} - - {#Type [exported? type labels]} - {#Some ..Type} - - {#Tag _} - {#None} - - {#Slot _} - {#None}))))) + {#Some def_type}))))) (def (type_variable idx bindings) (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) @@ -4505,20 +4888,32 @@ _ (failure (..wrong_syntax_error (symbol ..cond)))))) -(def (enumeration' idx xs) - (All (_ a) - (-> Nat (List a) (List [Nat a]))) - (when xs - {#Item x xs'} - {#Item [idx x] (enumeration' ("lux i64 +" 1 idx) xs')} +(type (Try value) + (Variant + {#Failure Text} + {#Success value})) + +(def (access_pattern g!_ g!output lefts right? members) + (-> Code Code Nat Bit (List Type) (Try (List Code))) + (when ((is (-> Nat (List Type) (List Code) + (List Code)) + (function (again index input output) + (when input + (list#partial head tail) + (if ("lux i64 =" index (if right? + ("lux i64 +" 1 lefts) + lefts)) + (list#reversed (list#partial g!output output)) + (again ("lux i64 +" 1 index) tail (list#partial g!_ output))) + + (list) + (list)))) + 0 members (list)) + (list) + {#Failure "Cannot synthesize access pattern."} - {#End} - {#End})) - -(def (enumeration xs) - (All (_ a) - (-> (List a) (List [Nat a]))) - (enumeration' 0 xs)) + pattern + {#Success pattern})) (def .public the (macro (_ tokens) @@ -4527,24 +4922,27 @@ (do meta#monad [slot (normal slot') output (..type_slot slot) - .let [[idx tags exported? type] output] - g!_ (..generated_symbol "_") - g!output (..generated_symbol "")] - (when (interface_methods type) - {#Some members} - (let [pattern (|> (zipped_2 tags (enumeration members)) - (list#each (is (-> [Symbol [Nat Type]] (List Code)) - (function (_ [[r_module r_name] [r_idx r_type]]) - (list (symbol$ [r_module r_name]) - (if ("lux i64 =" idx r_idx) - g!output - g!_))))) - list#conjoint - tuple$)] - (meta#in (list (` ({(, pattern) (, g!output)} (, record)))))) - - _ - (failure "the can only use records."))) + .let [[exported? [label' type]] output]] + (when label' + {.#None} + (in (list record)) + + {.#Some [lefts right? family]} + (do meta#monad + [g!_ (..generated_symbol "_") + g!output (..generated_symbol "") + .let [idx (if right? + (is Nat ("lux i64 +" 1 lefts)) + lefts) + pattern (|> (enumeration family) + (list#each (is (-> [Nat Symbol] (List Code)) + (function (_ [r_idx slot]) + (list (symbol$ slot) + (if ("lux i64 =" idx r_idx) + g!output + g!_))))) + list#conjoint)]] + (in (list (` ({[(,* pattern)] (, g!output)} (, record)))))))) (list [_ {#Tuple slots}] record) (meta#in (list (list#mix (is (-> Code Code Code) @@ -4757,37 +5155,38 @@ (do meta#monad [slot (normal slot') output (..type_slot slot) - .let [[idx tags exported? type] output]] - (when (interface_methods type) - {#Some members} + .let [[exported? [label' type]] output]] + (when label' + {.#None} + (in (list value)) + + {.#Some [lefts right? family]} (do meta#monad [pattern' (monad#each meta#monad - (is (-> [Symbol [Nat Type]] (Meta [Symbol Nat Code])) - (function (_ [r_slot_name [r_idx r_type]]) + (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) + (function (_ [r_idx r_slot_name]) (do meta#monad [g!slot (..generated_symbol "")] - (meta#in [r_slot_name r_idx g!slot])))) - (zipped_2 tags (enumeration members)))] - (let [pattern (|> pattern' + (in [r_slot_name r_idx g!slot])))) + (enumeration family)) + .let [pattern (|> pattern' + (list#each (is (-> [Symbol Nat Code] (List Code)) + (function (_ [r_slot_name r_idx r_var]) + (list (symbol$ r_slot_name) + r_var)))) + list#conjoint) + idx (if right? + (is Nat ("lux i64 +" 1 lefts)) + lefts) + output (|> pattern' (list#each (is (-> [Symbol Nat Code] (List Code)) (function (_ [r_slot_name r_idx r_var]) (list (symbol$ r_slot_name) - r_var)))) - list#conjoint - tuple$) - output (|> pattern' - (list#each (is (-> [Symbol Nat Code] (List Code)) - (function (_ [r_slot_name r_idx r_var]) - (list (symbol$ r_slot_name) - (if ("lux i64 =" idx r_idx) - value - r_var))))) - list#conjoint - tuple$)] - (meta#in (list (` ({(, pattern) (, output)} (, record))))))) - - _ - (failure "has can only use records."))) + (if ("lux i64 =" idx r_idx) + value + r_var))))) + list#conjoint)]] + (in (list (` ({[(,* pattern)] [(,* output)]} (, record)))))))) (list [_ {#Tuple slots}] value record) (when slots @@ -4841,37 +5240,38 @@ (do meta#monad [slot (normal slot') output (..type_slot slot) - .let [[idx tags exported? type] output]] - (when (interface_methods type) - {#Some members} + .let [[exported? [label' type]] output]] + (when label' + {.#None} + (in (list (` ((, fun) (, record))))) + + {.#Some [lefts right? family]} (do meta#monad [pattern' (monad#each meta#monad - (is (-> [Symbol [Nat Type]] (Meta [Symbol Nat Code])) - (function (_ [r_slot_name [r_idx r_type]]) + (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) + (function (_ [r_idx r_slot_name]) (do meta#monad [g!slot (..generated_symbol "")] - (meta#in [r_slot_name r_idx g!slot])))) - (zipped_2 tags (enumeration members)))] - (let [pattern (|> pattern' + (in [r_slot_name r_idx g!slot])))) + (enumeration family)) + .let [pattern (|> pattern' + (list#each (is (-> [Symbol Nat Code] (List Code)) + (function (_ [r_slot_name r_idx r_var]) + (list (symbol$ r_slot_name) + r_var)))) + list#conjoint) + idx (if right? + (is Nat ("lux i64 +" 1 lefts)) + lefts) + output (|> pattern' (list#each (is (-> [Symbol Nat Code] (List Code)) (function (_ [r_slot_name r_idx r_var]) (list (symbol$ r_slot_name) - r_var)))) - list#conjoint - tuple$) - output (|> pattern' - (list#each (is (-> [Symbol Nat Code] (List Code)) - (function (_ [r_slot_name r_idx r_var]) - (list (symbol$ r_slot_name) - (if ("lux i64 =" idx r_idx) - (` ((, fun) (, r_var))) - r_var))))) - list#conjoint - tuple$)] - (meta#in (list (` ({(, pattern) (, output)} (, record))))))) - - _ - (failure "revised can only use records."))) + (if ("lux i64 =" idx r_idx) + (` ((, fun) (, r_var))) + r_var))))) + list#conjoint)]] + (in (list (` ({[(,* pattern)] [(,* output)]} (, record)))))))) (list [_ {#Tuple slots}] fun record) (when slots diff --git a/stdlib/source/library/lux/data/format/tar.lux b/stdlib/source/library/lux/data/format/tar.lux index e682544bc..cc6317ae5 100644 --- a/stdlib/source/library/lux/data/format/tar.lux +++ b/stdlib/source/library/lux/data/format/tar.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Mode and) + [lux (.except Mode #mode and) [ffi (.only)] [abstract [monad (.only do)]] @@ -32,7 +32,7 @@ [macro ["^" pattern]] [type - [primitive (.except)]]] + [primitive (.except #name)]]] [world ["[0]" file] [time diff --git a/stdlib/source/library/lux/data/format/xml.lux b/stdlib/source/library/lux/data/format/xml.lux index 0978967f1..120c0a4dc 100644 --- a/stdlib/source/library/lux/data/format/xml.lux +++ b/stdlib/source/library/lux/data/format/xml.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except symbol) + [lux (.except Tag #Text symbol) [abstract [monad (.only do)] [equivalence (.only Equivalence)] diff --git a/stdlib/source/library/lux/documentation.lux b/stdlib/source/library/lux/documentation.lux index af0d07a07..ca27859fd 100644 --- a/stdlib/source/library/lux/documentation.lux +++ b/stdlib/source/library/lux/documentation.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Definition Module) + [lux (.except Definition Module #Definition #module) [abstract [monad (.only do)] ["[0]" enum]] diff --git a/stdlib/source/library/lux/ffi/export.jvm.lux b/stdlib/source/library/lux/ffi/export.jvm.lux index 9c16d04a4..af5ab079a 100644 --- a/stdlib/source/library/lux/ffi/export.jvm.lux +++ b/stdlib/source/library/lux/ffi/export.jvm.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except function) + [lux (.except #Function function) [control ["<>" parser]] [data diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index 2b68b7e89..8f5195d1f 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -12,7 +12,7 @@ ["[0]" product] ["[0]" text (.use "[1]#[0]" monoid order)] [collection - ["[0]" list (.use "[1]#[0]" monoid monad) + ["[0]" list (.use "[1]#[0]" monoid monad mix) ["[0]" property]]]] [math [number @@ -185,16 +185,7 @@ {.#Definition [exported? def_type def_value]} (if (macro_type? def_type) {.#Some (as Macro def_value)} - {.#None}) - - {.#Type [exported? type labels]} - {.#None} - - {.#Tag _} - {.#None} - - {.#Slot _} - {.#None})))) + {.#None}))))) {try.#Failure error} {.#None})]})))) @@ -328,23 +319,13 @@ (the .#definitions) (list.all (function (_ [def_name global]) (`` (when global - (,, (with_template [<pattern>] - [<pattern> - (if (and exported? - (text#= normal_short def_name)) - {.#Some (symbol#encoded [module_name def_name])} - {.#None})] - - [{.#Definition [exported? _]}] - [{.#Type [exported? _]}])) + {.#Definition [exported? _]} + (if (and exported? + (text#= normal_short def_name)) + {.#Some (symbol#encoded [module_name def_name])} + {.#None}) {.#Alias _} - {.#None} - - {.#Tag _} - {.#None} - - {.#Slot _} {.#None}))))))) list.together (list.sorted text#<) @@ -383,24 +364,9 @@ (in definition) (failure (all text#composite "Definition is not an export: " (symbol#encoded name))))))) - {.#Type [exported? type labels]} - (if exported? - (in [exported? .Type type]) - (failure (all text#composite "Type is not an export: " (symbol#encoded name)))) - {.#Alias de_aliased} (failure (all text#composite "Aliases are not considered exports: " - (symbol#encoded name))) - - {.#Tag _} - (failure (all text#composite - "Tags are not considered exports: " - (symbol#encoded name))) - - {.#Slot _} - (failure (all text#composite - "Slots are not considered exports: " (symbol#encoded name)))))) (def .public (definition_type name) @@ -412,20 +378,7 @@ (definition_type de_aliased) {.#Definition [exported? def_type def_value]} - (clean_type def_type) - - {.#Type [exported? type labels]} - (in .Type) - - {.#Tag _} - (failure (all text#composite - "Tags have no type: " - (symbol#encoded name))) - - {.#Slot _} - (failure (all text#composite - "Slots have no type: " - (symbol#encoded name)))))) + (clean_type def_type)))) (def .public (type name) (-> Symbol (Meta Type)) @@ -452,16 +405,7 @@ (type_code .Type) (type_code def_type))) (in (as Type def_value)) - (..failure (all text#composite "Definition is not a type: " (symbol#encoded name))))) - - {.#Type [exported? type labels]} - (in type) - - {.#Tag _} - (..failure (all text#composite "Tag is not a type: " (symbol#encoded name))) - - {.#Slot _} - (..failure (all text#composite "Slot is not a type: " (symbol#encoded name)))))) + (..failure (all text#composite "Definition is not a type: " (symbol#encoded name)))))))) (def .public (globals module) (-> Text (Meta (List [Text Global]))) @@ -482,16 +426,7 @@ {.#None} {.#Definition definition} - {.#Some [name definition]} - - {.#Type [exported? type labels]} - {.#Some [name [exported? .Type type]]} - - {.#Tag _} - {.#None} - - {.#Slot _} - {.#None}))) + {.#Some [name definition]}))) (..globals module))) (def .public (exports module_name) @@ -512,24 +447,40 @@ [lux] {try.#Success}))) -(`` (def .public (tags_of type_name) - (-> Symbol (Meta (Maybe (List Symbol)))) - (do ..monad - [.let [[module_name name] type_name] - module (..module module_name)] - (when (property.value name (the .#definitions module)) - {.#Some {.#Type [exported? type labels]}} - (when labels - (,, (with_template [<pattern>] - [<pattern> - (in {.#Some (list#each (|>> [module_name]) - {.#Item labels})})] +(def type#= + (`` ("lux in-module" (,, (static .prelude)) .type#=))) + +(def type#encoded + (`` ("lux in-module" (,, (static .prelude)) .type#encoded))) - [{.#Left labels}] - [{.#Right labels}]))) +(def .public (tags_of type_name) + (-> Symbol (Meta (Maybe (List Symbol)))) + (do ..monad + [.let [[module_name name] type_name] + module (..module module_name)] + (in (list.one (function (_ [short global]) + (when global + {.#Definition [exported? type value]} + (if (type#= Slot type) + (let [[label type] (as Label value)] + (when type + {.#Named actual_name anonymous} + (if (symbol#= type_name actual_name) + {.#Some (when label + {.#Some [lefts right? family]} + family + + {.#None} + (list [module_name short]))} + {.#None}) + + _ + {.#None})) + {.#None}) - _ - (in {.#None}))))) + _ + {.#None})) + (the .#definitions module))))) (def .public location (Meta Location) @@ -564,26 +515,28 @@ (|>> (the .#imports) (list.any? (text#= import))) ..current_module)) -(with_template [<name> <tag> <description>] +(with_template [<name> <description> <type>] [(def .public (<name> label_name) - (-> Symbol (Meta [Nat (List Symbol) Type])) + (-> Symbol (Meta Label)) (do ..monad [.let [[module name] label_name] =module (..module module) this_module_name ..current_module_name] (when (property.value name (the .#definitions =module)) - {.#Some {<tag> [exported? type group idx]}} + {.#Some {.#Definition [exported? def_type def_value]}} (if (or (text#= this_module_name module) exported?) - (in [idx (list#each (|>> [module]) group) type]) + (if (type#= <type> def_type) + (in (as Label def_value)) + (..failure (all text#composite "Invalid type for " <description> " " (symbol#encoded label_name) " : " (type#encoded def_type)))) (..failure (all text#composite "Cannot access " <description> ": " (symbol#encoded label_name) " from module " this_module_name))) _ (..failure (all text#composite "Unknown " <description> ": " (symbol#encoded label_name))))))] - [tag .#Tag "tag"] - [slot .#Slot "slot"] + [tag "tag" .Tag] + [slot "slot" .Slot] ) (def .public (tag_lists module) @@ -591,24 +544,32 @@ (do ..monad [=module (..module module) this_module_name ..current_module_name] - (in (list.all (function (_ [short global]) - (when global - {.#Type [exported? type labels]} - (if (or exported? - (text#= this_module_name module)) - {.#Some [(list#each (|>> [module]) - (when labels - {.#Left tags} - {.#Item tags} - - {.#Right slots} - {.#Item slots})) - type]} - {.#None}) - - _ - {.#None})) - (the .#definitions =module))))) + (in (property.values + (list#mix (function (_ [short global] output) + (when global + {.#Definition [exported? type value]} + (if (and (type#= Slot type) + (or exported? + (text#= this_module_name module))) + (let [[label type] (as Label value)] + (when label + {.#Some [lefts right? family]} + (when family + (list.partial [_ short] _) + (property.has short [family type] output) + + (list) + (property.has short [(list [module short]) type] output)) + + {.#None} + (property.has short [(list [module short]) type] output))) + output) + + _ + output)) + (is (property.List [(List Symbol) Type]) + (list)) + (the .#definitions =module)))))) (def .public locals (Meta (List (List [Text Type]))) @@ -633,15 +594,6 @@ real_def_name {.#Definition _} - def_name - - {.#Type _} - def_name - - {.#Tag _} - def_name - - {.#Slot _} def_name)))) (def .public compiler_state diff --git a/stdlib/source/library/lux/meta/compiler.lux b/stdlib/source/library/lux/meta/compiler.lux index 64f5a38fd..5f2d00605 100644 --- a/stdlib/source/library/lux/meta/compiler.lux +++ b/stdlib/source/library/lux/meta/compiler.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Module Code) + [lux (.except Module Code #module) [control ["<>" parser (.only)] ["[0]" try (.only Try)] diff --git a/stdlib/source/library/lux/meta/compiler/default/platform.lux b/stdlib/source/library/lux/meta/compiler/default/platform.lux index 1d60192d3..427625283 100644 --- a/stdlib/source/library/lux/meta/compiler/default/platform.lux +++ b/stdlib/source/library/lux/meta/compiler/default/platform.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Module) + [lux (.except Module #host) ["[0]" debug] [abstract ["[0]" monad (.only Monad do)]] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux.lux index 14adeb6d6..1176afc91 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux.lux @@ -24,21 +24,11 @@ (Format .Module) (let [definition (is (Format Definition) (all _.and _.bit _.type _.any)) - labels (is (Format [Text (List Text)]) - (_.and _.text (_.list _.text))) - global_type (is (Format [Bit Type (Either [Text (List Text)] - [Text (List Text)])]) - (all _.and _.bit _.type (_.or labels labels))) - global_label (is (Format .Label) - (all _.and _.bit _.type (_.list _.text) _.nat)) alias (is (Format Alias) (_.and _.text _.text)) global (is (Format Global) (all _.or definition - global_type - global_label - global_label alias))] (all _.and ... #module_hash @@ -59,22 +49,6 @@ <binary>.bit <binary>.type <binary>.any)) - labels (is (Parser [Text (List Text)]) - (all <>.and - <binary>.text - (<binary>.list <binary>.text))) - global_type (is (Parser [Bit Type (Either [Text (List Text)] - [Text (List Text)])]) - (all <>.and - <binary>.bit - <binary>.type - (<binary>.or labels labels))) - global_label (is (Parser .Label) - (all <>.and - <binary>.bit - <binary>.type - (<binary>.list <binary>.text) - <binary>.nat)) alias (is (Parser Alias) (all <>.and <binary>.text @@ -82,9 +56,6 @@ global (is (Parser Global) (all <binary>.or definition - global_type - global_label - global_label alias))] (all <>.and ... #module_hash diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux index 7df0d6232..2b8a26b2b 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Tuple Variant Pattern nat int rev when local except) + [lux (.except Tuple Variant Pattern #Function #Apply nat int rev when local except) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux index 40d90f729..7d3f9f1cf 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Tuple Variant) + [lux (.except Tag Tuple Variant #Variant #Tuple) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)]] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux index 8799f8b57..c4c6da56d 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Variant Pattern) + [lux (.except Variant Pattern #Bit #Nat #Int #Rev #Frac #Text #Variant) [abstract [equivalence (.except)] ["[0]" monad (.only do)]] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux index e6f531191..98df6e6ad 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Label with) + [lux (.except with) ["[0]" meta] [abstract ["[0]" monad (.only do)]] @@ -21,25 +21,11 @@ [/// ["[1]" phase]]]]) -(type .public Label - Text) - (exception.def .public (unknown_module module) (Exception Text) (exception.report (list ["Module" module]))) -(with_template [<name>] - [(exception.def .public (<name> [labels owner]) - (Exception [(List Label) Type]) - (exception.report - (list ["Labels" (text.interposed " " labels)] - ["Type" (%.type owner)])))] - - [cannot_declare_labels_for_anonymous_type] - [cannot_declare_labels_for_foreign_type] - ) - (exception.def .public (cannot_define_more_than_once [name already_existing]) (Exception [Symbol Global]) (exception.report @@ -49,16 +35,7 @@ (format "alias " (%.symbol alias)) {.#Definition definition} - (format "definition " (%.symbol name)) - - {.#Type _} - (format "type " (%.symbol name)) - - {.#Tag _} - (format "tag " (%.symbol name)) - - {.#Slot _} - (format "slot " (%.symbol name)))]))) + (format "definition " (%.symbol name)))]))) (exception.def .public (can_only_change_state_of_active_module [module state]) (Exception [Text Module_State]) @@ -207,22 +184,3 @@ [set_compiled compiled? .#Compiled] [set_cached cached? .#Cached] ) - -(def .public (declare_labels record? labels exported? type) - (-> Bit (List Label) Bit Type (Operation Any)) - (do [! ///.monad] - [self_name (///extension.lifted meta.current_module_name) - [type_module type_name] (when type - {.#Named type_name _} - (in type_name) - - _ - (/.except ..cannot_declare_labels_for_anonymous_type [labels type])) - _ (///.assertion ..cannot_declare_labels_for_foreign_type [labels type] - (text#= self_name type_module))] - (monad.each ! (function (_ [index short]) - (..define short - (if record? - {.#Slot [exported? type labels index]} - {.#Tag [exported? type labels index]}))) - (list.enumeration labels)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux index ba360a38b..833bb997c 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux @@ -144,9 +144,9 @@ (let [bindings (is Bindings [.#counter 0 .#mappings (list)])] - [.#name (list) - .#inner 0 - .#locals bindings + [.#scope_name (list) + .#inner_scopes 0 + .#locals bindings .#captured bindings])) (def .public (reset action) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux index 239bb848c..b848b2a4e 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #Bit #Nat #Int #Rev #Frac #Text) [abstract [equivalence (.only Equivalence)]] [data diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux b/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux index 1f2b4505a..8eff3ed65 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Module) + [lux (.except Module #module #imports) [abstract [monad (.only do)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux b/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux index 93e1420f8..78587f280 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except symbol) + [lux (.except #module #counter #host symbol) [abstract [monad (.only do)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux index 21c5fba14..885f2c364 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except Tag) [abstract ["[0]" monad (.only do)]] [control @@ -21,7 +21,7 @@ ["[0]" meta (.only) ["[0]" symbol] ["[0]" code] - ["[0]" type (.only) + ["[0]" type (.use "[1]#[0]" equivalence) ["[0]" check]]]]] ["[0]" // ["[1][0]" simple] @@ -74,6 +74,17 @@ ["Tag" (%.symbol tag)] ["Expression" (%.code code)]))) +(exception.def .public (cannot_order_record [@ code]) + (Exception [Code (List [Symbol Code])]) + (exception.report + (list ["@" (%.code @)] + ["Expression" (|> code + (list#each (function (_ [slot value]) + (list (code.symbol slot) value))) + list#conjoint + code.tuple + %.code)]))) + (exception.def .public (cannot_repeat_slot [key record]) (Exception [Symbol (List [Symbol Code])]) (exception.report @@ -176,9 +187,13 @@ (-> Phase Symbol Phase) (do [! ///.monad] [tag (///extension.lifted (meta.normal tag)) - [idx group variantT] (///extension.lifted (meta.tag tag)) - .let [case_size (list.size group) - [lefts right?] (/complex.choice case_size idx)] + [lefts,right? variantT] (///extension.lifted (meta.tag tag)) + [lefts right?] (when lefts,right? + {.#Some [lefts right? family]} + (in [lefts right?]) + + {.#None} + (in [0 false])) expectedT (///extension.lifted meta.expected_type)] (when expectedT {.#Var _} @@ -323,45 +338,83 @@ (list.any? (list.any? (|>> product.left (text#= name)))) meta.locals)) +(def (slot it) + (-> Symbol (Meta Label)) + (do meta.monad + [it (meta.normal it)] + (meta.slot it))) + +(def (slot_type [[_ it] _]) + (-> [Label Code] Type) + it) + +(def (same_record? it) + (-> (List [Label Code]) Bit) + (when it + (list.partial head tail) + (let [expected (slot_type head)] + (list.every? (|>> slot_type (type#= expected)) tail)) + + (list) + false)) + +(def (complete_record? it) + (-> (List [Label Code]) Bit) + (loop (again [expected_lefts 0 + remaining it]) + (when remaining + {.#Item [[{.#Some [lefts .true family]} type] value] {.#End}} + (n.= (-- expected_lefts) lefts) + + {.#Item [[{.#None} type] value] {.#End}} + (n.= 0 expected_lefts) + + {.#Item [[{.#Some [lefts .false family]} type] value] tail} + (and (n.= expected_lefts lefts) + (again (++ expected_lefts) tail)) + + _ + false))) + +(def sorted_record + (-> (List [Label Code]) (List [Label Code])) + (list.sorted (function (_ left right) + (when [left right] + [[[{.#Some [leftsL right?L familyL]} typeL] valueL] + [[{.#Some [leftsR right?R familyR]} typeR] valueR]] + (if (n.= leftsL leftsR) + (not right?R) + (n.< leftsL leftsR)) + + _ + false)))) + ... Lux already possesses the means to analyse tuples, so ... re-implementing the same functionality for records makes no sense. ... Records, thus, get transformed into tuples by ordering the elements. -(def (order' head_k record) +(def (order' head_k original_record) (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) (do [! ///.monad] - [slotH' (///extension.lifted - (do meta.monad - [head_k (meta.normal head_k)] - (meta.try (meta.slot head_k))))] - (when slotH' - {try.#Success [_ slot_set recordT]} + [record (<| ///extension.lifted + meta.try + (monad.each ! (function (_ [slot value]) + (do ! + [slot (..slot slot)] + (in [slot value]))) + original_record))] + (when record + {try.#Success record} (do ! - [.let [size_record (list.size record) - size_ts (list.size slot_set)] - _ (if (n.= size_ts size_record) - (in []) - (/.except ..record_size_mismatch [size_ts size_record recordT record])) - .let [tuple_range (list.indices size_ts) - tag->idx (dictionary.of_list symbol.hash (list.zipped_2 slot_set tuple_range))] - idx->val (monad.mix ! - (function (_ [key val] idx->val) - (do ! - [key (///extension.lifted (meta.normal key))] - (when (dictionary.value key tag->idx) - {.#Some idx} - (if (dictionary.key? idx->val idx) - (/.except ..cannot_repeat_slot [key record]) - (in (dictionary.has idx val idx->val))) - - {.#None} - (/.except ..slot_does_not_belong_to_record [key recordT])))) - (is (Dictionary Nat Code) - (dictionary.empty n.hash)) - record) - .let [ordered_tuple (list#each (function (_ idx) - (maybe.trusted (dictionary.value idx idx->val))) - tuple_range)]] - (in {.#Some [size_ts ordered_tuple recordT]})) + [.let [record (sorted_record record)] + _ (///.assertion ..cannot_order_record [(` same_record?) original_record] + (same_record? record)) + _ (///.assertion ..cannot_order_record [(` complete_record?) original_record] + (complete_record? record))] + (in (do maybe.monad + [[[_ :record:] _] (list.head record)] + (in [(list.size record) + (list#each product.right record) + :record:])))) {try.#Failure error} (in {.#None})))) @@ -402,10 +455,13 @@ [head_k (///extension.lifted (meta.normal pseudo_slot)) slot (///extension.lifted (meta.try (meta.slot head_k)))] (when slot - {try.#Success [_ slot_set recordT]} - (when (list.size slot_set) - 1 (analyse archive singletonC) - _ (..product analyse archive members)) + {try.#Success [lefts,right? recordT]} + (when lefts,right? + {.#None} + (analyse archive singletonC) + + _ + (..product analyse archive members)) _ (..product analyse archive members))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux index 51816df59..26831fe0a 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux @@ -63,29 +63,7 @@ (text#= quoted_module ::module)) <return> (/.except ..foreign_module_has_not_been_imported [current ::module quoted_module def_name]))) - (/.except ..definition_has_not_been_exported def_name)))) - - {.#Type [exported? value labels]} - (do ! - [_ (/type.inference .Type) - (^.let def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) - current (///extension.lifted meta.current_module_name)] - (if (text#= current ::module) - <return> - (if exported? - (do ! - [imported! (///extension.lifted (meta.imported_by? ::module current))] - (if (or imported! - (text#= quoted_module ::module)) - <return> - (/.except ..foreign_module_has_not_been_imported [current ::module quoted_module def_name]))) - (/.except ..definition_has_not_been_exported def_name)))) - - {.#Tag _} - (/.except ..labels_are_not_definitions [def_name]) - - {.#Slot _} - (/.except ..labels_are_not_definitions [def_name]))))) + (/.except ..definition_has_not_been_exported def_name)))))))) (def (variable var_name) (-> Text (Operation (Maybe Analysis))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/when.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/when.lux index 84fd24cc2..3378f2a4c 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/when.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/when.lux @@ -160,7 +160,7 @@ (def (tuple_pattern_analysis pattern_analysis :input: sub_patterns next) (All (_ a) - (-> (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])) + (-> (-> Type Code (Operation a) (Operation [Pattern a])) Type (List Code) (Operation a) (Operation [Pattern a]))) (do [! ///.monad] [[@ex_var+ :input:'] (/type.check (..tuple :input:))] @@ -194,9 +194,9 @@ (Operation [(List Pattern) a]))) (function (_ [memberT memberC] then) (do ! - [[memberP [memberP+ thenA]] ((as (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + [[memberP [memberP+ thenA]] ((as (All (_ a) (-> Type Code (Operation a) (Operation [Pattern a]))) pattern_analysis) - {.#None} memberT memberC then)] + memberT memberC then)] (in [(list.partial memberP memberP+) thenA])))) (do ! [nextA next] @@ -225,8 +225,8 @@ ... body expressions. ... That is why the body must be analysed in the context of the ... pattern, and not separately. -(def (pattern_analysis num_tags :input: pattern next) - (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) +(def (pattern_analysis :input: pattern next) + (All (_ a) (-> Type Code (Operation a) (Operation [Pattern a]))) (.when pattern [location {.#Symbol ["" name]}] (/.with_location location @@ -248,7 +248,7 @@ [Any {.#Tuple {.#End}} {/simple.#Unit}]) [location {.#Tuple (list singleton)}] - (pattern_analysis {.#None} :input: singleton next) + (pattern_analysis :input: singleton next) [location {.#Tuple sub_patterns}] (/.with_location location @@ -276,7 +276,7 @@ (in []))] (.when members (list singleton) - (pattern_analysis {.#None} :input: singleton next) + (pattern_analysis :input: singleton next) _ (..tuple_pattern_analysis pattern_analysis :input: members next))) @@ -292,19 +292,17 @@ {.#Sum _} (let [flat_sum (type.flat_variant :input:') size_sum (list.size flat_sum) - num_cases (maybe.else size_sum num_tags) idx (/complex.tag right? lefts)] (.when (list.item idx flat_sum) (^.multi {.#Some caseT} - (n.< num_cases idx)) + (n.< size_sum idx)) (do ///.monad - [[testP nextA] (if (and (n.> num_cases size_sum) - (n.= (-- num_cases) idx)) - (pattern_analysis {.#None} - (type.variant (list.after (-- num_cases) flat_sum)) + [[testP nextA] (if (and (n.> size_sum size_sum) + (n.= (-- size_sum) idx)) + (pattern_analysis (type.variant (list.after (-- size_sum) flat_sum)) (` [(,* values)]) next) - (pattern_analysis {.#None} caseT (` [(,* values)]) next)) + (pattern_analysis caseT (` [(,* values)]) next)) _ (/type.check (monad.each check.monad check.forget! @ex_var+))] (in [(/pattern.variant [lefts right? testP]) nextA])) @@ -315,8 +313,7 @@ {.#UnivQ _} (do ///.monad [[ex_id exT] (/type.check check.existential) - it (pattern_analysis num_tags - (maybe.trusted (type.applied (list exT) :input:')) + it (pattern_analysis (maybe.trusted (type.applied (list exT) :input:')) pattern next) _ (/type.check (monad.each check.monad check.forget! @ex_var+))] @@ -329,10 +326,15 @@ (/.with_location location (do ///.monad [tag (///extension.lifted (meta.normal tag)) - [idx group variantT] (///extension.lifted (meta.tag tag)) - _ (/type.check (check.check :input: variantT)) - .let [[lefts right?] (/complex.choice (list.size group) idx)]] - (pattern_analysis {.#Some (list.size group)} :input: (` {(, (code.nat lefts)) (, (code.bit right?)) (,* values)}) next))) + [lefts,right? variantT] (///extension.lifted (meta.tag tag)) + [lefts right?] (in (.when lefts,right? + {.#Some [lefts right? family]} + [lefts right?] + + {.#None} + [0 false])) + _ (/type.check (check.check :input: variantT))] + (pattern_analysis :input: (` {(, (code.nat lefts)) (, (code.bit right?)) (,* values)}) next))) _ (/.except ..invalid [pattern]) @@ -345,10 +347,10 @@ (do [! ///.monad] [[:input: inputA] (<| /type.inferring (analyse archive inputC)) - outputH (pattern_analysis {.#None} :input: patternH (analyse archive bodyH)) + outputH (pattern_analysis :input: patternH (analyse archive bodyH)) outputT (monad.each ! (function (_ [patternT bodyT]) - (pattern_analysis {.#None} :input: patternT (analyse archive bodyT))) + (pattern_analysis :input: patternT (analyse archive bodyT))) branchesT) outputHC (|> outputH product.left /coverage.coverage /.of_try) outputTC (monad.each ! (|>> product.left /coverage.coverage /.of_try) outputT) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux index 050c6263d..2ea6deb7d 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux @@ -262,53 +262,6 @@ _ (phase.except ///.invalid_syntax [extension_name %.code inputsC+])))) -(def (announce_labels! labels owner) - (All (_ anchor expression declaration) - (-> (List Text) Type (Operation anchor expression declaration (List Any)))) - (/////declaration.lifted_generation - (monad.each phase.monad - (function (_ tag) - (/////generation.log! (format tag " : Tag of " (%.type owner)))) - labels))) - -(def (def_type_tagged expander host_analysis) - (-> Expander /////analysis.Bundle Handler) - (..custom - [(all <>.and <code>.local <code>.any - (<>.or (<code>.variant (<>.some <code>.text)) - (<code>.tuple (<>.some <code>.text))) - <code>.any) - (function (_ extension_name phase archive [short_name valueC labels exported?C]) - (do phase.monad - [current_module (/////declaration.lifted_analysis - (///.lifted meta.current_module_name)) - .let [full_name [current_module short_name]] - [_ _ exported?] (evaluate! archive Bit exported?C) - .let [exported? (as Bit exported?)] - [type valueT value] (..definition archive full_name {.#Some .Type} valueC) - labels (/////declaration.lifted_analysis - (do phase.monad - [.let [[record? labels] (when labels - {.#Left tags} - [false tags] - - {.#Right slots} - [true slots])] - _ (when labels - {.#End} - (moduleA.define short_name {.#Definition [exported? type value]}) - - {.#Item labels} - (moduleA.define short_name {.#Type [exported? (as .Type value) (if record? - {.#Right labels} - {.#Left labels})]})) - _ (moduleA.declare_labels record? labels exported? (as .Type value))] - (in labels))) - _ (..refresh expander host_analysis) - _ (..announce_definition! short_name type) - _ (..announce_labels! labels (as Type value))] - (in /////declaration.no_requirements)))])) - (def imports (Parser (List Import)) (|> (<code>.tuple (<>.and <code>.text <code>.text)) @@ -339,12 +292,6 @@ ["Foreign alias" (%.symbol foreign)] ["Target definition" (%.symbol target)]))) -(exception.def .public (cannot_alias_a_label [local foreign]) - (Exception [Alias Alias]) - (exception.report - (list ["Alias" (%.symbol local)] - ["Label" (%.symbol foreign)]))) - (def (define_alias alias original) (-> Text Symbol (/////analysis.Operation Any)) (do phase.monad @@ -354,13 +301,8 @@ {.#Alias de_aliased} (phase.except ..cannot_alias_an_alias [[current_module alias] original de_aliased]) - (^.or {.#Definition _} - {.#Type _}) - (moduleA.define alias {.#Alias original}) - - (^.or {.#Tag _} - {.#Slot _}) - (phase.except ..cannot_alias_a_label [[current_module alias] original])))) + {.#Definition _} + (moduleA.define alias {.#Alias original})))) (def defalias Handler @@ -491,7 +433,6 @@ (|> ///bundle.empty (dictionary.has "module" defmodule) (dictionary.has "alias" defalias) - (dictionary.has "type tagged" (def_type_tagged expander host_analysis)) (dictionary.has "analysis" (def_analysis anchorT,expressionT,declarationT extender)) (dictionary.has "synthesis" (def_synthesis anchorT,expressionT,declarationT extender)) (dictionary.has "generation" (def_generation anchorT,expressionT,declarationT extender)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux index 29b3604b8..377e232b1 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Scope i64) + [lux (.except Scope #Function #Apply #locals i64) [abstract [monad (.only do)] [equivalence (.only Equivalence)] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux index a44021d1f..80d6447b9 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #Bit #Text) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)]] diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/archive.lux index 994b6cd4b..46ede92f0 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/archive.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/archive.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Module has) + [lux (.except Module #module has) [abstract ["[0]" equivalence (.only Equivalence)] ["[0]" monad (.only do)]] diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux index 0afb9adc5..5c547a425 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Definition) + [lux (.except Definition #Definition) [abstract [equivalence (.only Equivalence)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux index e9220d028..5d3ff086c 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #version) [abstract [equivalence (.only Equivalence)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux index 82d29c16b..5f7b20e00 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #module) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)]] diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux index 60e4af536..9b8f0934a 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #module #imports) [abstract ["[0]" monad (.only do)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/meta/cli.lux b/stdlib/source/library/lux/meta/compiler/meta/cli.lux index 37adb69f4..1c590b24b 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/cli.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/cli.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Module Source) + [lux (.except Module Source #module #target #configuration) [abstract [monad (.only do)] [equivalence (.only Equivalence)]] diff --git a/stdlib/source/library/lux/meta/compiler/meta/context.lux b/stdlib/source/library/lux/meta/compiler/meta/context.lux index 668d828e2..ef520917a 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/context.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/context.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #host #target) [meta ["@" target (.only Target)]] [world diff --git a/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux index 29b8539ac..1d1aaca4b 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux @@ -221,12 +221,8 @@ content (document.content $.key document) definitions (monad.each ! (function (_ [def_name def_global]) (when def_global - (^.with_template [<tag>] - [{<tag> payload} - (in [def_name {<tag> payload}])]) - ([.#Alias] - [.#Tag] - [.#Slot]) + {.#Alias payload} + (in [def_name def_global]) {.#Definition [exported? type _]} (|> definitions @@ -234,14 +230,7 @@ try.of_maybe (at ! each (|>> [exported? type] {.#Definition} - [def_name]))) - - {.#Type [exported? _ labels]} - (|> definitions - (dictionary.value def_name) - try.of_maybe - (at ! each (function (_ def_value) - [def_name {.#Type [exported? (as .Type def_value) labels]}]))))) + [def_name]))))) (the .#definitions content))] (in [(document.document $.key (has .#definitions definitions content)) bundles]))) diff --git a/stdlib/source/library/lux/meta/compiler/phase.lux b/stdlib/source/library/lux/meta/compiler/phase.lux index b5d04c40e..77574a4aa 100644 --- a/stdlib/source/library/lux/meta/compiler/phase.lux +++ b/stdlib/source/library/lux/meta/compiler/phase.lux @@ -108,7 +108,7 @@ (try#each (|>> [state]) error))) (def .public assertion - (template (assertion exception message test) + (template (_ exception message test) [(if test (at ..monad in []) (..except exception message))])) diff --git a/stdlib/source/library/lux/meta/compiler/reference/variable.lux b/stdlib/source/library/lux/meta/compiler/reference/variable.lux index 0e038ed06..7de1dee16 100644 --- a/stdlib/source/library/lux/meta/compiler/reference/variable.lux +++ b/stdlib/source/library/lux/meta/compiler/reference/variable.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #Local) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)]] diff --git a/stdlib/source/library/lux/meta/target/jvm/attribute.lux b/stdlib/source/library/lux/meta/target/jvm/attribute.lux index c6ff2472f..21578c4e5 100644 --- a/stdlib/source/library/lux/meta/target/jvm/attribute.lux +++ b/stdlib/source/library/lux/meta/target/jvm/attribute.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Info Code Type) + [lux (.except Info Code Type #info) [abstract [monad (.only do)] ["[0]" equivalence (.only Equivalence)]] diff --git a/stdlib/source/library/lux/meta/target/jvm/constant.lux b/stdlib/source/library/lux/meta/target/jvm/constant.lux index d05df9511..7c23d49c7 100644 --- a/stdlib/source/library/lux/meta/target/jvm/constant.lux +++ b/stdlib/source/library/lux/meta/target/jvm/constant.lux @@ -23,7 +23,7 @@ ["^" pattern] ["[0]" template]] [type - [primitive (.except)]]]]] + [primitive (.except #name)]]]]] ["[0]" / ["[1][0]" tag] ["/[1]" // diff --git a/stdlib/source/library/lux/meta/target/jvm/constant/tag.lux b/stdlib/source/library/lux/meta/target/jvm/constant/tag.lux index bcd1d4209..f6917a5d0 100644 --- a/stdlib/source/library/lux/meta/target/jvm/constant/tag.lux +++ b/stdlib/source/library/lux/meta/target/jvm/constant/tag.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except Tag) [abstract [equivalence (.only Equivalence)]] [control diff --git a/stdlib/source/library/lux/meta/target/jvm/type.lux b/stdlib/source/library/lux/meta/target/jvm/type.lux index f9944b0eb..aabf16518 100644 --- a/stdlib/source/library/lux/meta/target/jvm/type.lux +++ b/stdlib/source/library/lux/meta/target/jvm/type.lux @@ -16,7 +16,7 @@ ["n" nat]]] [meta [type - [primitive (.except)]]]]] + [primitive (.except #name)]]]]] ["[0]" // [encoding ["[1][0]" name (.only External)]]] diff --git a/stdlib/source/library/lux/meta/type/implicit.lux b/stdlib/source/library/lux/meta/type/implicit.lux index df5da5767..f265ac780 100644 --- a/stdlib/source/library/lux/meta/type/implicit.lux +++ b/stdlib/source/library/lux/meta/type/implicit.lux @@ -99,13 +99,13 @@ tag_lists)]] (when candidates {.#End} - (///.failure (format "Unknown tag: " (%.symbol member))) + (///.failure (format "Unknown slot: " (%.symbol member))) {.#Item winner {.#End}} (in winner) _ - (///.failure (format "Too many candidate tags: " (%.list %.symbol candidates)))))) + (///.failure (format "Too many candidate slots: " (%.list %.symbol candidates)))))) _ (at ///.monad in member))) @@ -114,8 +114,16 @@ (-> Symbol (Meta [Nat Type])) (do ///.monad [member (member_name member) - [idx tag_list sig_type] (///.slot member)] - (in [idx sig_type]))) + [lefts,right? sig_type] (///.slot member)] + (when lefts,right? + {.#Some [lefts right? family]} + (in [(if right? + (++ lefts) + lefts) + sig_type]) + + {.#None} + (in [0 sig_type])))) (def (compatible_type? interface candidate) (-> Type Type Bit) diff --git a/stdlib/source/library/lux/meta/type/row.lux b/stdlib/source/library/lux/meta/type/row.lux index 1966a4768..a51add3cd 100644 --- a/stdlib/source/library/lux/meta/type/row.lux +++ b/stdlib/source/library/lux/meta/type/row.lux @@ -1,7 +1,7 @@ ... https://en.wikipedia.org/wiki/Row_polymorphism (.require [library - [lux (.except macro type the has revised) + [lux (.except Slot macro type the has revised) [abstract ["[0]" monad (.only do)]] [control diff --git a/stdlib/source/library/lux/test/tally.lux b/stdlib/source/library/lux/test/tally.lux index afbab607a..7c587d688 100644 --- a/stdlib/source/library/lux/test/tally.lux +++ b/stdlib/source/library/lux/test/tally.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except and) + [lux (.except #expected and) [data [collection ["[0]" set (.only Set)]]] diff --git a/stdlib/source/library/lux/world/locale/language.lux b/stdlib/source/library/lux/world/locale/language.lux index ae11c87b1..f5ceb4852 100644 --- a/stdlib/source/library/lux/world/locale/language.lux +++ b/stdlib/source/library/lux/world/locale/language.lux @@ -10,7 +10,7 @@ [macro ["[0]" template]] [type - [primitive (.except)]]]]]) + [primitive (.except #name)]]]]]) ... https://en.wikipedia.org/wiki/List_of_ISO_639-2_codes (primitive .public Language diff --git a/stdlib/source/library/lux/world/locale/territory.lux b/stdlib/source/library/lux/world/locale/territory.lux index 74c30fce6..9cd72ae2a 100644 --- a/stdlib/source/library/lux/world/locale/territory.lux +++ b/stdlib/source/library/lux/world/locale/territory.lux @@ -10,7 +10,7 @@ [macro ["[0]" template]] [type - [primitive (.except)]]]]]) + [primitive (.except #name)]]]]]) ... https://en.wikipedia.org/wiki/ISO_3166-1 (primitive .public Territory diff --git a/stdlib/source/library/lux/world/net/http.lux b/stdlib/source/library/lux/world/net/http.lux index 0582c9192..0ca8327aa 100644 --- a/stdlib/source/library/lux/world/net/http.lux +++ b/stdlib/source/library/lux/world/net/http.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except #version #host) [control [try (.only Try)] [concurrency diff --git a/stdlib/source/parser/lux/data/format/xml.lux b/stdlib/source/parser/lux/data/format/xml.lux index ce03568f6..603cfe6c5 100644 --- a/stdlib/source/parser/lux/data/format/xml.lux +++ b/stdlib/source/parser/lux/data/format/xml.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except Tag) [abstract [monad (.only do)]] [control diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux index 0b5dca612..e04705902 100644 --- a/stdlib/source/test/lux/data/format/json.lux +++ b/stdlib/source/test/lux/data/format/json.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Variant Record) + [lux (.except Variant Record #Bit #Text #Frac) [abstract [codec (.except)] [monad (.only do)] diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/analysis/module.lux b/stdlib/source/test/lux/meta/compiler/language/lux/analysis/module.lux index 58a2e03fa..7442e7a3c 100644 --- a/stdlib/source/test/lux/meta/compiler/language/lux/analysis/module.lux +++ b/stdlib/source/test/lux/meta/compiler/language/lux/analysis/module.lux @@ -269,80 +269,6 @@ {try.#Failure _} true))))) ))) -(def test|label - Test - (do [! random.monad] - [lux ..random_state - .let [state [/extension.#bundle /extension.empty - /extension.#state lux]] - module_name (random.lower_case 1) - hash random.nat - def_name (random.lower_case 2) - foreign_module (random.lower_case 3) - - public? random.bit - def_type ..primitive - arity (at ! each (|>> (n.% 10) ++) random.nat) - labels|head (random.lower_case 1) - labels|tail (|> (random.lower_case 1) - (random.only (|>> (text#= labels|head) not)) - (random.set text.hash (-- arity)) - (at ! each set.list))] - (all _.and - (_.coverage [/.declare_labels] - (`` (and (,, (with_template [<side> <record?> <query> <on_success>] - [(|> (/.with hash module_name - (do [! /phase.monad] - [.let [it {.#Named [module_name def_name] def_type}] - _ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]}) - _ (/.declare_labels <record?> (list.partial labels|head labels|tail) public? it)] - (monad.each ! (|>> [module_name] <query> /extension.lifted) - (list.partial labels|head labels|tail)))) - (/phase.result state) - (pipe.when - {try.#Success _} <on_success> - {try.#Failure _} (not <on_success>)))] - - [.#Left false meta.tag true] - [.#Left false meta.slot false] - [.#Right true meta.slot true] - [.#Right true meta.tag false]))))) - (_.coverage [/.cannot_declare_labels_for_anonymous_type] - (`` (and (,, (with_template [<side> <record?>] - [(|> (/.with hash module_name - (do [! /phase.monad] - [.let [it def_type] - _ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]})] - (/.declare_labels <record?> (list.partial labels|head labels|tail) public? it))) - (/phase.result state) - (pipe.when - {try.#Success _} - false - - {try.#Failure error} - (text.contains? (the exception.#label /.cannot_declare_labels_for_anonymous_type) error)))] - - [.#Left false] - [.#Right true]))))) - (_.coverage [/.cannot_declare_labels_for_foreign_type] - (`` (and (,, (with_template [<side> <record?>] - [(|> (/.with hash module_name - (do [! /phase.monad] - [.let [it {.#Named [foreign_module def_name] def_type}] - _ (/.define def_name {.#Type [public? it {<side> [labels|head labels|tail]}]})] - (/.declare_labels <record?> (list.partial labels|head labels|tail) public? it))) - (/phase.result state) - (pipe.when - {try.#Success _} - false - - {try.#Failure error} - (text.contains? (the exception.#label /.cannot_declare_labels_for_foreign_type) error)))] - - [.#Left false] - [.#Right true]))))) - ))) - (def .public test Test (<| (_.covering /._) @@ -350,6 +276,4 @@ ..test|module ..test|state ..test|definition - (_.for [/.Label] - ..test|label) ))) diff --git a/stdlib/source/test/lux/meta/macro/context.lux b/stdlib/source/test/lux/meta/macro/context.lux index 095fed836..49ebbe6db 100644 --- a/stdlib/source/test/lux/meta/macro/context.lux +++ b/stdlib/source/test/lux/meta/macro/context.lux @@ -113,19 +113,12 @@ [_ (/.revised {.#None} ++ <real_stack>)] (in (list))))))) (_.coverage [/.not_a_definition] - (and (<| (text.contains? (the exception.#label /.not_a_definition)) - macro_error - static.expansion - (do meta.monad - [actual (/.peek' [<real_stack> (symbol <fake_stack>)])] - (in (list)))) - (with_expansions [<expected> (static.random_nat)] - (<| (text.contains? (the exception.#label /.not_a_definition)) - macro_error - static.expansion - (do meta.monad - [_ (/.push' <expected> [<real_stack> (symbol .#Item)])] - (in (list))))))) + (<| (text.contains? (the exception.#label /.not_a_definition)) + macro_error + static.expansion + (do meta.monad + [actual (/.peek' [<real_stack> (symbol <fake_stack>)])] + (in (list))))) (_.coverage [/.not_a_global] (with_expansions [<expected> (static.random_nat)] (<| (text.contains? (the exception.#label /.not_a_global)) |