diff options
Diffstat (limited to 'lux-bootstrapper')
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser.clj | 19 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/case.clj | 434 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/lux.clj | 57 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/module.clj | 174 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/record.clj | 172 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/base.clj | 25 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/cache.clj | 17 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/core.clj | 43 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/jvm/lux.clj | 15 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/optimizer.clj | 10 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/type.clj | 28 |
11 files changed, 447 insertions, 547 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 _) |