aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--source/lux.lux84
-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
5 files changed, 134 insertions, 105 deletions
diff --git a/source/lux.lux b/source/lux.lux
index e9b4484c5..32fde1d8a 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -752,10 +752,6 @@
#Nil
ys))
-## (: (All [a b]
-## (-> (-> a b) (List a) (List b)))
-## map)
-
(def (splice untemplate tag elems)
(->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
(case' (any? spliced? elems)
@@ -779,29 +775,6 @@
false
(wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
-## (def (splice untemplate tag elems)
-## (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
-## (case' (any? spliced? elems)
-## true
-## (let [elems' (map (:' (->' Syntax Syntax)
-## (lambda [elem]
-## (case' elem
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))])
-## spliced
-
-## _
-## ($form (list ($symbol ["" ":'"])
-## ($symbol ["lux" "SyntaxList"])
-## ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))))
-## elems)]
-## (wrap-meta ($form (list tag
-## ($form (list& ($symbol ["lux" "$"])
-## ($symbol ["lux" "list:++"])
-## elems'))))))
-
-## false
-## (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
-
(def (untemplate token)
(->' Syntax Syntax)
(case' token
@@ -939,18 +912,6 @@
(return (:' SyntaxList
(list (` (#TupleT (list (~@ tokens))))))))
-## (: (All [a b]
-## (-> (-> a b a) a (List b) a))
-## fold)
-
-## (: (All [a]
-## (-> (List a) (List a)))
-## reverse)
-
-## (: (All [a]
-## (-> (List a) (List (, a a))))
-## as-pairs)
-
(defmacro (do tokens)
(case' tokens
(#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])])
@@ -979,33 +940,39 @@
(-> (B' a) ($' (B' m) (B' b)))
($' List (B' a))
($' (B' m) ($' List (B' b)))))
- (let [{#;return ;return #;bind ;bind} m]
+ (let [{#;return ;return #;bind _} m]
(case' xs
#Nil
- (;return #Nil)
+ (;return (:' List #Nil))
(#Cons [x xs'])
(do m
[y (f x)
ys (map% m f xs')]
- (;return (#Cons [y ys])))
+ (;return (:' List (#Cons [y ys]))))
)))
+(def (ident->text ident)
+ (-> Ident Text)
+ (let [[module name] ident]
+ ($ text:++ module ";" name)))
+
(defmacro #export (| tokens)
(do Lux:Monad
[pairs (map% Lux:Monad
- (lambda [token]
- (case' token
- (#Tag ident)
- (;return (` [(~ ($text (ident->text ident))) (,)]))
-
- (#Form (#Cons [(#Tag ident) (#Cons [value #Nil])]))
- (;return (` [(~ ($text (ident->text ident))) (~ value)]))
-
- _
- (fail "Wrong syntax for |")))
+ (:' (-> Syntax ($' Lux Syntax))
+ (lambda [token]
+ (case' token
+ (#Meta [_ (#Tag ident)])
+ (;return (:' Syntax (` [(~ ($text (ident->text ident))) (,)])))
+
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))])
+ (;return (:' Syntax (` [(~ ($text (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for |"))))
tokens)]
- (` (#VariantT (list (~@ pairs))))))
+ (;return (:' SyntaxList (list (` (#VariantT (list (~@ pairs)))))))))
(defmacro #export (& tokens)
(if (not (int:= 2 (length tokens)))
@@ -1014,13 +981,13 @@
[pairs (map% Lux:Monad
(lambda [pair]
(case' pair
- [(#Tag ident) value]
- (;return (` [(~ ($text (ident->text ident))) (~ value)]))
+ [(#Meta [_ (#Tag ident)]) value]
+ (;return (:' Syntax (` [(~ ($text (ident->text ident))) (~ value)])))
_
(fail "Wrong syntax for &")))
(as-pairs tokens))]
- (` (#RecordT (list (~@ pairs)))))))
+ (;return (:' SyntaxList (list (` (#RecordT (list (~@ pairs))))))))))
## (defmacro #export (All tokens)
## (case' (:' (, Ident SyntaxList)
@@ -1061,11 +1028,6 @@
## (fail "Wrong syntax for All"))
## ))
-## (def (ident->text ident)
-## (->' Ident Text)
-## (let [[module name] ident]
-## ($ text:++ module ";" name)))
-
## (def #export (find-macro ident state)
## (->' Ident ($' Lux Macro))
## (let [[module name] ident]
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-26 23:03:06 +0000