aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/base.clj8
-rw-r--r--src/lux/analyser/case.clj60
-rw-r--r--src/lux/analyser/lux.clj18
-rw-r--r--src/lux/type.clj13
4 files changed, 62 insertions, 37 deletions
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 414d005f1..7f7980e76 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -139,6 +139,14 @@
_
(fail "[Analyser Error] Can't expand to other than 1 element."))))
+(defn analyse-1+ [analyse ?token]
+ (&type/with-var
+ (fn [$var]
+ (|do [=expr (analyse-1 analyse $var ?token)
+ :let [[?item ?type] =expr]
+ =type (&type/clean $var ?type)]
+ (return (&/T ?item =type))))))
+
(defn resolved-ident [ident]
(|let [[?module ?name] ident]
(|do [module* (if (.equals "" ?module)
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index f302088d9..3b12270c2 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -184,11 +184,7 @@
(&/$RecordS pairs)
(|do [?members (&&record/order-record pairs)
- ;; :let [_ (prn 'PRE (&type/show-type value-type))]
- value-type* (adjust-type value-type)
- ;; :let [_ (prn 'POST (&type/show-type value-type*))]
- ;; value-type* (resolve-type value-type)
- ]
+ value-type* (adjust-type value-type)]
(|case value-type*
(&/$TupleT ?member-types)
(if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
@@ -333,6 +329,15 @@
(return (&/V $VariantTotal (&/T 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]
;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct))
(|case struct
@@ -340,34 +345,45 @@
(return ?total)
($BoolTotal ?total ?values)
- (return (or ?total
- (= #{true false} (set (&/->seq ?values)))))
+ (|do [_ (&type/check value-type &type/Bool)]
+ (return (or ?total
+ (= #{true false} (set (&/->seq ?values))))))
($IntTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Int)]
+ (return ?total))
($RealTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Real)]
+ (return ?total))
($CharTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Char)]
+ (return ?total))
($TextTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Text)]
+ (return ?total))
($TupleTotal ?total ?structs)
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
- (&/$TupleT ?members)
- (|do [totals (&/map2% (fn [sub-struct ?member]
- (check-totality ?member sub-struct))
- ?structs ?members)]
- (return (&/fold #(and %1 %2) true totals)))
+ (|do [unknown? (&type/unknown? value-type)]
+ (if unknown?
+ (|do [=structs (&/map% (check-totality+ check-totality) ?structs)
+ _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))]
+ (return (or ?total
+ (&/fold #(and %1 %2) true (&/|map &/|first =structs)))))
+ (if ?total
+ (return true)
+ (|do [value-type* (resolve-type value-type)]
+ (|case value-type*
+ (&/$TupleT ?members)
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
+ (return (&/fold #(and %1 %2) true totals)))
- _
- (fail "[Pattern-maching Error] Tuple is not total."))))
+ _
+ (fail "[Pattern-maching Error] Tuple is not total."))))))
($VariantTotal ?total ?structs)
(if ?total
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 62202c1c9..3a9b822ca 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -18,19 +18,11 @@
[module :as &&module]
[record :as &&record])))
-(defn ^:private analyse-1+ [analyse ?token]
- (&type/with-var
- (fn [$var]
- (|do [=expr (&&/analyse-1 analyse $var ?token)
- :let [[?item ?type] =expr]
- =type (&type/clean $var ?type)]
- (return (&/T ?item =type))))))
-
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
(|do [unknown? (&type/unknown? exo-type)]
(if unknown?
- (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)]
+ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
(return =analysis))
?elems)
_ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))]
@@ -52,7 +44,7 @@
(analyse-tuple analyse exo-type** ?elems))))
_
- (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))))
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type))))))))
(defn ^:private analyse-variant-body [analyse exo-type ?values]
(|do [output (|case ?values
@@ -303,7 +295,7 @@
(|do [:let [num-branches (&/|length ?branches)]
_ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.")
_ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.")
- =value (analyse-1+ analyse ?value)
+ =value (&&/analyse-1+ analyse ?value)
=match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))]
(return (&/|list (&/T (&/V &&/$case (&/T =value =match))
exo-type)))))
@@ -382,7 +374,7 @@
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
(|do [=value (&/with-scope ?name
- (analyse-1+ analyse ?value))]
+ (&&/analyse-1+ analyse ?value))]
(|case =value
[(&&/$var (&/$Global ?r-module ?r-name)) _]
(|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))
@@ -452,6 +444,6 @@
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
_ (&type/check exo-type ==type)
- =value (analyse-1+ analyse ?value)]
+ =value (&&/analyse-1+ analyse ?value)]
(return (&/|list (&/T (&/V &&/$ann (&/T =value =type))
==type)))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index f067867d8..5fbc33de2 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -336,6 +336,14 @@
(fail* (str "[Type Error] Unbound type-var: " id)))
(fail* (str "[Type Error] <deref> Unknown type-var: " id)))))
+(defn deref+ [type]
+ (|case type
+ (&/$VarT id)
+ (deref id)
+
+ _
+ (fail (str "[Type Error] Type is not a variable: " (show-type type)))))
+
(defn set-var [id type]
(fn [state]
(if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
@@ -914,8 +922,9 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
- (&/$VarT ?id)
- (deref ?id)
+ (&/$VarT id)
+ (|do [=type (deref id)]
+ (actual-type =type))
(&/$NamedT ?name ?type)
(actual-type ?type)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 06:37:17 +0000