aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux27
-rw-r--r--src/lux/analyser/case.clj49
-rw-r--r--src/lux/base.clj33
-rw-r--r--src/lux/compiler/case.clj2
4 files changed, 73 insertions, 38 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 04f9df811..22d49315b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -2140,14 +2140,7 @@
_
($ text:++ "(| "
(|> cases
- (map (: (-> (, Text Type) Text)
- (lambda [kv]
- (case kv
- [k (#TupleT #;Nil)]
- ($ text:++ "#" k)
-
- [k v]
- ($ text:++ "(#" k " " (type:show v) ")")))))
+ (map type:show)
(interpose " ")
(foldL text:++ ""))
")"))
@@ -2160,11 +2153,7 @@
_
($ text:++ "(& "
(|> fields
- (map (: (-> (, Text Type) Text)
- (: (-> (, Text Type) Text)
- (lambda [kv]
- (let [[k v] kv]
- ($ text:++ "(#" k " " (type:show v) ")"))))))
+ (map type:show)
(interpose " ")
(foldL text:++ ""))
")"))
@@ -2192,18 +2181,10 @@
(-> (List (, Text Type)) Type Type)
(case type
(#VariantT ?cases)
- (#VariantT (map (: (-> (, Text Type) (, Text Type))
- (lambda [kv]
- (let [[k v] kv]
- [k (beta-reduce env v)])))
- ?cases))
+ (#VariantT (map (beta-reduce env) ?cases))
(#RecordT ?fields)
- (#RecordT (map (: (-> (, Text Type) (, Text Type))
- (lambda [kv]
- (let [[k v] kv]
- [k (beta-reduce env v)])))
- ?fields))
+ (#RecordT (map (beta-reduce env) ?fields))
(#TupleT ?members)
(#TupleT (map (beta-reduce env) ?members))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 34cbf8b48..148e2822a 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -223,13 +223,14 @@
value-type* (adjust-type value-type)
;; :let [_ (println "#02")]
idx (&module/tag-index =module =name)
+ group (&module/tag-group =module =name)
;; :let [_ (println "#03")]
case-type (&type/variant-case idx value-type*)
;; :let [_ (println "#04")]
[=test =kont] (analyse-pattern case-type unit kont)
;; :let [_ (println "#05")]
]
- (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont)))
+ (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
(&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident))
?values))
@@ -239,6 +240,7 @@
value-type* (adjust-type value-type)
;; :let [_ (println "#12" (&type/show-type value-type*))]
idx (&module/tag-index =module =name)
+ group (&module/tag-group =module =name)
;; :let [_ (println "#13")]
case-type (&type/variant-case idx value-type*)
;; :let [_ (println "#14" (&type/show-type case-type))]
@@ -249,7 +251,7 @@
(analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))
;; :let [_ (println "#15")]
]
- (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont)))
+ (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
)))
(defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns]
@@ -311,21 +313,40 @@
(return (&/V $TupleTotal (&/T total? structs))))
(fail "[Pattern-matching Error] Inconsistent tuple-size."))
- [($DefaultTotal total?) ($VariantTestAC ?tag ?test)]
+ [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)]
(|do [sub-struct (merge-total (&/V $DefaultTotal total?)
- (&/T ?test ?body))]
- (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct (&/|table))))))
-
- [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?test)]
- (|do [sub-struct (merge-total (or (&/|get ?tag ?branches)
- (&/V $DefaultTotal total?))
- (&/T ?test ?body))]
- (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct ?branches)))))
+ (&/T ?test ?body))
+ structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?)))
+ (&/$Some list)
+ (return list)
+
+ (&/$None)
+ (fail "[Pattern-matching Error] YOLO"))]
+ (return (&/V $VariantTotal (&/T total? structs))))
+
+ [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)]
+ (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches)
+ (&/$Some sub)
+ sub
+
+ (&/$None)
+ (&/V $DefaultTotal total?))
+ (&/T ?test ?body))
+ structs (|case (&/|list-put ?tag sub-struct ?branches)
+ (&/$Some list)
+ (return list)
+
+ (&/$None)
+ (fail "[Pattern-matching Error] YOLO"))]
+ (return (&/V $VariantTotal (&/T total? structs))))
))))
(defn ^:private check-totality [value-type struct]
;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct))
(|case struct
+ ($DefaultTotal ?total)
+ (return ?total)
+
($BoolTotal ?total ?values)
(return (or ?total
(= #{true false} (set (&/->seq ?values)))))
@@ -369,6 +390,9 @@
(|case value-type*
(&/$VariantT ?members)
(|do [totals (&/map2% (fn [sub-struct ?member]
+ ;; (prn '$VariantTotal
+ ;; (&/adt->text sub-struct)
+ ;; (&type/show-type ?member))
(check-totality ?member sub-struct))
?structs ?members)]
(return (&/fold #(and %1 %2) true totals)))
@@ -376,9 +400,6 @@
_
(fail "[Pattern-maching Error] Variant is not total."))))
- ($DefaultTotal ?total)
- (return ?total)
-
;; _
;; (assert false (prn-str 'check-totality (&type/show-type value-type)
;; (&/adt->text struct)))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index b8b7118f4..89620ce97 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -116,6 +116,13 @@
(defn R [& kvs]
(to-array kvs))
+;; Constructors
+(def None$ (V $None nil))
+(defn Some$ [x] (V $Some x))
+
+(def Nil$ (V $Nil nil))
+(defn Cons$ [h t] (V $Cons (T h t)))
+
(defn get$ [slot ^objects record]
(aget record slot))
@@ -894,3 +901,29 @@
[ymodule yname] y]
(and (= xmodule ymodule)
(= xname yname))))
+
+;; (defn |list-put [idx val xs]
+;; (|case [idx xs]
+;; [_ ($Nil)]
+;; (V $None nil)
+
+;; [0 ($Cons x xs*)]
+;; (V $Some (V $Cons (T val xs*)))
+
+;; [_ ($Cons x xs*)]
+;; (|case (|list-put idx val xs*)
+;; ($None) (V $None nil)
+;; ($Some xs**) (V $Some (V $Cons (T x xs**))))))
+
+(defn |list-put [idx val xs]
+ (|case xs
+ ($Nil)
+ (V $None nil)
+
+ ($Cons x xs*)
+ (if (= idx 0)
+ (V $Some (V $Cons (T val xs*)))
+ (|case (|list-put (dec idx) val xs*)
+ ($None) (V $None nil)
+ ($Some xs**) (V $Some (V $Cons (T x xs**))))
+ )))
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 4d8ac2190..dd3258059 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -102,7 +102,7 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- (&a-case/$VariantTestAC ?tag ?test)
+ (&a-case/$VariantTestAC ?tag ?count ?test)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-22 21:04:19 +0000