aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/case.clj61
-rw-r--r--src/lux/analyser/lux.clj28
-rw-r--r--src/lux/compiler/case.clj25
-rw-r--r--src/lux/type.clj41
4 files changed, 111 insertions, 44 deletions
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 0c459f0de..8fa2bbaff 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -72,22 +72,31 @@
[_]
(fail "[Analyser Error] Tuple requires tuple-type."))
- [["lux;Record" ?fields]]
- (&type/with-vars (&/|length ?fields)
- (fn [=vars]
- (|do [_ (&type/check value-type (&/V "lux;RecordT" (&/zip2 (&/|keys ?fields) =vars)))
- [=tests =kont] (&/fold (fn [kont* vm]
- (|let [[v [k m]] vm]
- (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
- (matchv ::M/objects [=kont]
- [["Expression" [?val ?type]]]
- (|do [=type (&type/clean v ?type)]
- (return (&/T (&/|put k =test =tests)
- (&/V "Expression" (&/T ?val =type)))))))))
- (|do [=kont kont]
- (return (&/T (&/|table) =kont)))
- (&/|reverse (&/zip2 =vars ?fields)))]
- (return (&/T (&/V "RecordTestAC" =tests) =kont)))))
+ [["lux;Record" ?slots]]
+ (|do [value-type* (resolve-type value-type)]
+ (matchv ::M/objects [value-type*]
+ [["lux;RecordT" ?slot-types]]
+ (if (not (= (&/|length ?slot-types) (&/|length ?slots)))
+ (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* slot]
+ (|let [[sn sv] slot]
+ (matchv ::M/objects [sn]
+ [["lux;Meta" [_ ["lux;Tag" ?ident]]]]
+ (|do [=tag (&&/resolved-ident ?ident)]
+ (if-let [=slot-type (&/|get =tag ?slot-types)]
+ (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
+ (return (&/T (&/|put =tag =test =tests) =kont)))
+ (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag))))
+
+ [_]
+ (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
+ (|do [=kont kont]
+ (return (&/T (&/|table) =kont)))
+ (&/|reverse ?slots))]
+ (return (&/T (&/V "RecordTestAC" =tests) =kont))))
+
+ [_]
+ (fail "[Analyser Error] Record requires record-type.")))
[["lux;Tag" ?ident]]
(|do [=tag (&&/resolved-ident ?ident)
@@ -172,21 +181,27 @@
[["DefaultTotal" total?] ["RecordTestAC" ?tests]]
(|do [structs (&/map% (fn [t]
(|let [[slot value] t]
- (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))]
- (return (&/T slot struct)))))
- (sort compare-kv ?tests))]
+ (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))]
+ (return (&/T slot struct*)))))
+ (->> ?tests
+ &/->seq
+ (sort compare-kv)
+ &/->list))]
(return (&/V "RecordTotal" (&/T total? structs))))
[["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]]
(if (= (&/|length ?values) (&/|length ?tests))
(|do [structs (&/map% (fn [lr]
- (|let [[[lslot struct] [rslot value]] lr]
+ (|let [[[lslot sub-struct] [rslot value]] lr]
(if (= lslot rslot)
- (|do [struct (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))]
- (return (&/T lslot struct)))
+ (|do [sub-struct* (merge-total sub-struct (&/T value ?body))]
+ (return (&/T lslot sub-struct*)))
(fail "[Pattern-matching error] Record slots mismatch."))))
(&/zip2 ?values
- (sort compare-kv ?tests)))]
+ (->> ?tests
+ &/->seq
+ (sort compare-kv)
+ &/->list)))]
(return (&/V "RecordTotal" (&/T total? structs))))
(fail "[Pattern-matching error] Inconsistent record-size."))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 87db5a125..b9a3ffbf2 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -53,20 +53,26 @@
[_]
(&type/actual-type exo-type))
- ?tag (&&/resolved-ident ident)
;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))]
]
(matchv ::M/objects [exo-type*]
[["lux;VariantT" ?cases]]
- (if-let [vtype (&/|get ?tag ?cases)]
- (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))]
- =value (&&/analyse-1 analyse vtype ?value)
- ;; :let [_ (prn 'GOT_VALUE =value)]
- ]
- (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value))
- exo-type)))))
- (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))
-
+ (|do [?tag (&&/resolved-ident ident)]
+ (if-let [vtype (&/|get ?tag ?cases)]
+ (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))]
+ =value (&&/analyse-1 analyse vtype ?value)
+ ;; :let [_ (prn 'GOT_VALUE =value)]
+ ]
+ (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value))
+ exo-type)))))
+ (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*)))))
+
+ [["lux;AllT" _]]
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-variant analyse exo-type** ident ?value))))
+
[_]
(fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
@@ -291,7 +297,7 @@
[_]
(fail (str "[Analyser Error] Functions require function types: "
;; (str (aget ?self 0) ";" (aget ?self 1))
- ;; (str (aget ?arg 0) ";" (aget ?arg 1))
+ ;; (str( aget ?arg 0) ";" (aget ?arg 1))
;; (&/show-ast ?body)
(&type/show-type exo-type)))))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 2f051903b..4e33bd7b1 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -18,7 +18,8 @@
;; [Utils]
(let [+tag-sig+ (&host/->type-signature "java.lang.String")
+oclass+ (&host/->class "java.lang.Object")
- +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")]
+ +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z")
+ compare-kv #(compare (aget %1 0) (aget %2 0))]
(defn ^:private compile-match [writer ?match $target $else]
;; (prn 'compile-match (aget ?match 0) $target $else)
(matchv ::M/objects [?match]
@@ -95,6 +96,28 @@
(doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))])))
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
+
+ [["RecordTestAC" ?slots]]
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (-> (doto (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int idx))
+ (.visitInsn Opcodes/AALOAD)
+ (compile-match test $next $sub-else)
+ (.visitLabel $sub-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else)
+ (.visitLabel $next))
+ (->> (|let [[idx [_ test]] idx+member
+ $next (new Label)
+ $sub-else (new Label)])
+ (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?slots))
+ (->> ?slots
+ &/->seq
+ (sort compare-kv)
+ &/->list)))])))
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
[["VariantTestAC" [?tag ?test]]]
(doto writer
diff --git a/src/lux/type.clj b/src/lux/type.clj
index b1b77d5ab..e5c96d7bd 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -235,7 +235,8 @@
(matchv ::M/objects [type]
[["lux;VarT" ?id]]
(if (= ?tid ?id)
- (deref ?id)
+ (&/try-all% (&/|list (deref ?id)
+ (return type)))
(return type))
[["lux;LambdaT" [?arg ?return]]]
@@ -573,16 +574,32 @@
;; (|do [_ (check* fixpoints F1 F2)
;; _ (check* fixpoints A1 A2)]
;; (return (&/T fixpoints nil)))
-
- [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
- (|do [[fixpoints _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
- [fixpoints _] (check* fixpoints A1 A2)]
+ [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]]
+ (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid))
+ _ (check* fixpoints A1 A2)]
(return (&/T fixpoints nil)))
-
+
+ ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
+ ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
+ ;; [fixpoints** _] (check* fixpoints* A1 A2)]
+ ;; (return (&/T fixpoints** nil)))
+ [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
+ (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
+ e* (apply-type F2 A1)
+ a* (apply-type F2 A2)
+ [fixpoints** _] (check* fixpoints* e* a*)]
+ (return (&/T fixpoints** nil)))
+
+ ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
+ ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
+ ;; [fixpoints** _] (check* fixpoints* A1 A2)]
+ ;; (return (&/T fixpoints** nil)))
[["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
- (|do [[fixpoints _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
- [fixpoints _] (check* fixpoints A1 A2)]
- (return (&/T fixpoints nil)))
+ (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
+ e* (apply-type F1 A1)
+ a* (apply-type F1 A2)
+ [fixpoints** _] (check* fixpoints* e* a*)]
+ (return (&/T fixpoints** nil)))
[["lux;AppT" [F A]] _]
(let [fp-pair (&/T expected actual)
@@ -734,6 +751,12 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
+ ;; [["lux;AllT" [?env ?self ?arg ?body]]]
+ ;; (with-var
+ ;; (fn [$var]
+ ;; (|do [type* (apply-type type $var)]
+ ;; (actual-type type*))))
+
[_]
(return type)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 09:01:03 +0000