aboutsummaryrefslogtreecommitdiff
path: root/lux-bootstrapper
diff options
context:
space:
mode:
Diffstat (limited to 'lux-bootstrapper')
-rw-r--r--lux-bootstrapper/src/lux/analyser.clj19
-rw-r--r--lux-bootstrapper/src/lux/analyser/case.clj434
-rw-r--r--lux-bootstrapper/src/lux/analyser/lux.clj57
-rw-r--r--lux-bootstrapper/src/lux/analyser/module.clj174
-rw-r--r--lux-bootstrapper/src/lux/analyser/record.clj172
-rw-r--r--lux-bootstrapper/src/lux/base.clj25
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache.clj17
-rw-r--r--lux-bootstrapper/src/lux/compiler/core.clj43
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/lux.clj15
-rw-r--r--lux-bootstrapper/src/lux/optimizer.clj10
-rw-r--r--lux-bootstrapper/src/lux/type.clj28
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 _)