aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux/analyser/base.clj2
-rw-r--r--src/lux/analyser/case.clj65
-rw-r--r--src/lux/analyser/lux.clj36
-rw-r--r--src/lux/analyser/meta.clj2
-rw-r--r--src/lux/base.clj19
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/base.clj3
-rw-r--r--src/lux/compiler/case.clj4
-rw-r--r--src/lux/compiler/host.clj29
-rw-r--r--src/lux/compiler/lux.clj8
-rw-r--r--src/lux/compiler/type.clj4
-rw-r--r--src/lux/host.clj2
-rw-r--r--src/lux/parser.clj2
-rw-r--r--src/lux/type.clj233
-rw-r--r--src/lux/type/host.clj6
15 files changed, 246 insertions, 173 deletions
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 710da6eda..2d6d72fb8 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -185,7 +185,7 @@
(return ?module))]
(return (&/T module* ?name))))
-(let [tag-names #{"DataT" "VoidT" "UnitT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}]
+(let [tag-names #{"DataT" "VoidT" "UnitT" "SumT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}]
(defn type-tag? [module name]
(and (= "lux" module)
(contains? tag-names name))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 0fad10cea..3b6dceb27 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -45,7 +45,7 @@
(|case type
(&/$VarT ?id)
(|do [type* (&/try-all% (&/|list (&type/deref ?id)
- (fail "##9##")))]
+ (fail "##1##")))]
(resolve-type type*))
(&/$UnivQ _)
@@ -89,20 +89,20 @@
up))
?members*))))
- (&/$VariantT ?members)
- (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena]
- (|let [[_aenv _aidx (&/$VarT _avar)] ena]
- (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))]
- (&type/clean* _avar _abody))))
- type
- up)]
- (return (&/V &/$VariantT (&/|map (fn [v]
- (&/fold (fn [_abody ena]
- (|let [[_aenv _aidx _avar] ena]
- (&/V &/$UnivQ (&/T _aenv _abody))))
- v
- up))
- ?members*))))
+ (&/$SumT ?left ?right)
+ (|do [(&/$SumT =left =right) (&/fold% (fn [_abody ena]
+ (|let [[_aenv _aidx (&/$VarT _avar)] ena]
+ (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))]
+ (&type/clean* _avar _abody))))
+ type
+ up)
+ :let [distributor (fn [v]
+ (&/fold (fn [_abody ena]
+ (|let [[_aenv _aidx _avar] ena]
+ (&/V &/$UnivQ (&/T _aenv _abody))))
+ v
+ up))]]
+ (return (&type/Sum$ (distributor =left) (distributor =right))))
(&/$AppT ?tfun ?targ)
(|do [=type (&type/apply-type ?tfun ?targ)]
@@ -110,7 +110,7 @@
(&/$VarT ?id)
(|do [type* (&/try-all% (&/|list (&type/deref ?id)
- (fail "##9##")))]
+ (fail "##2##")))]
(adjust-type* up type*))
(&/$NamedT ?name ?type)
@@ -205,7 +205,7 @@
value-type* (adjust-type value-type)
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
- case-type (&type/variant-case idx value-type*)
+ case-type (&type/sum-at idx value-type*)
[=test =kont] (analyse-pattern &/None$ case-type unit kont)]
(return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
@@ -215,7 +215,7 @@
value-type* (adjust-type value-type)
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
- case-type (&type/variant-case idx value-type*)
+ case-type (&type/sum-at idx value-type*)
[=test =kont] (case (int (&/|length ?values))
0 (analyse-pattern &/None$ case-type unit kont)
1 (analyse-pattern &/None$ case-type (&/|head ?values) kont)
@@ -239,9 +239,27 @@
[($DefaultTotal total?) ($StoreTestAC ?idx)]
(return (&/V $DefaultTotal true))
- [[?tag [total? ?values]] ($StoreTestAC ?idx)]
- (return (&/V ?tag (&/T true ?values)))
-
+ [($BoolTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $BoolTotal (&/T true ?values)))
+
+ [($IntTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $IntTotal (&/T true ?values)))
+
+ [($RealTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $RealTotal (&/T true ?values)))
+
+ [($CharTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $CharTotal (&/T true ?values)))
+
+ [($TextTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $TextTotal (&/T true ?values)))
+
+ [($TupleTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $TupleTotal (&/T true ?values)))
+
+ [($VariantTotal total? ?values) ($StoreTestAC ?idx)]
+ (return (&/V $VariantTotal (&/T true ?values)))
+
[($DefaultTotal total?) ($BoolTestAC ?value)]
(return (&/V $BoolTotal (&/T total? (&/|list ?value))))
@@ -385,8 +403,9 @@
(return true)
(|do [value-type* (resolve-type value-type)]
(|case value-type*
- (&/$VariantT ?members)
- (|do [totals (&/map2% check-totality ?members ?structs)]
+ (&/$SumT _)
+ (|do [:let [?members (&type/flatten-sum value-type*)]
+ totals (&/map2% check-totality ?members ?structs)]
(return (&/fold #(and %1 %2) true totals)))
_
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 834b75f5a..415565c7c 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -181,24 +181,24 @@
(&type/actual-type exo-type))]
(&/with-attempt
(|case exo-type*
- (&/$VariantT ?cases)
- (|case (&/|at idx ?cases)
- (&/$Some vtype)
- (|do [_cursor &/cursor
- =value (&/with-attempt
- (analyse-variant-body analyse vtype ?values)
- (fn [err]
- (|do [_exo-type (&type/deref+ exo-type)]
- (fail (str err "\n"
- 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type)
- " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&/V &&/$variant (&/T idx =value))
- ))))
-
- (&/$None)
- (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*))))
+ (&/$SumT _)
+ (|do [vtype (&type/sum-at idx exo-type*)
+ =value (&/with-attempt
+ (analyse-variant-body analyse vtype ?values)
+ (fn [err]
+ (|do [_exo-type (|case exo-type
+ (&/$VarT _id)
+ (&type/deref _id)
+
+ _
+ (return exo-type))]
+ (fail (str err "\n"
+ 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type)
+ " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&/V &&/$variant (&/T idx =value))
+ ))))
(&/$UnivQ _)
(|do [$var &type/existential
diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj
index 6b9d91695..fb75003e8 100644
--- a/src/lux/analyser/meta.clj
+++ b/src/lux/analyser/meta.clj
@@ -31,7 +31,7 @@
&/None$))
(do-template [<name> <tag-name>]
- (def <name> (&/V tag-prefix <tag-name>))
+ (def <name> (&/T tag-prefix <tag-name>))
type?-tag "type?"
alias-tag "alias"
diff --git a/src/lux/base.clj b/src/lux/base.clj
index e0517940a..fe8ce184a 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -47,7 +47,7 @@
["DataT"
"VoidT"
"UnitT"
- "VariantT"
+ "SumT"
"TupleT"
"LambdaT"
"BoundT"
@@ -144,12 +144,14 @@
(def tags-field "_tags")
(def module-class-name "_")
(def +name-separator+ ";")
+(def sum-tag (str (char 0) "sum" (char 0)))
+(def product-tag (str (char 0) "product" (char 0)))
(defn T [& elems]
(to-array elems))
(defn V [^Long tag value]
- (to-array [tag value]))
+ (to-array [sum-tag tag value]))
;; Constructors
(def None$ (V $None nil))
@@ -183,12 +185,13 @@
(defn transform-pattern [pattern]
(cond (vector? pattern) (mapv transform-pattern pattern)
(seq? pattern) (let [parts (mapv transform-pattern (rest pattern))]
- (vec (cons (eval (first pattern))
- (list (case (count parts)
- 0 nil
- 1 (first parts)
- ;; else
- `[~@parts])))))
+ ['_
+ (eval (first pattern))
+ (case (count parts)
+ 0 nil
+ 1 (first parts)
+ ;; else
+ `[~@parts])])
:else pattern
))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 2a8c64c25..8d748df53 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -492,7 +492,9 @@
.visitEnd)
(.visitSource file-name nil))]
_ (if (= "lux" name)
- &&host/compile-Function-class
+ (|do [_ &&host/compile-Function-class
+ _ &&host/compile-LuxUtils-class]
+ (return nil))
(return nil))]
(fn [state]
(|case ((&/with-writer =class
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 988502a5f..6ad21aef7 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -30,6 +30,9 @@
(def ^String output-dir "target/jvm")
(def ^String output-package (str output-dir "/" "program.jar"))
(def ^String function-class "lux/Function")
+(def ^String lux-utils-class "lux/LuxUtils")
+(def ^String sum-tag-field "sum_tag")
+(def ^String product-tag-field "product_tag")
;; Formats
(def ^String local-prefix "l")
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index 61209b7fb..e0d1b886e 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -111,14 +111,14 @@
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 0))
+ (.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
(.visitLdcInsn ?tag)
(&&/wrap-long)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
(.visitJumpInsn Opcodes/IFEQ $else)
(.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1))
+ (.visitLdcInsn (int 2))
(.visitInsn Opcodes/AALOAD)
(-> (doto (compile-match ?test $value-then $value-else)
(.visitLabel $value-then)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index afa2d1bf9..72f36975f 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -613,8 +613,9 @@
init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
(&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil)
(|do [^MethodVisitor =method &/get-writer
- :let [_ (doto =method (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0))]
+ :let [_ (doto =method
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0))]
_ (&/map% (fn [type+term]
(|let [[type term] type+term]
(|do [_ (compile term)
@@ -678,7 +679,7 @@
(def compile-Function-class
(let [object-class (&/V &/$GenericClass (&/T "java.lang.Object" (&/|list)))
- interface-decl (&/T "Function" (&/|list))
+ interface-decl (&/T (second (string/split &&/function-class #"/")) (&/|list))
?supers (&/|list)
?anns (&/|list)
?methods (&/|list (&/T "apply"
@@ -689,6 +690,28 @@
object-class))]
(compile-jvm-interface nil interface-decl ?supers ?anns ?methods)))
+(def compile-LuxUtils-class
+ (|do [_ (return nil)
+ :let [full-name &&/lux-utils-class
+ super-class (&host-generics/->bytecode-class-name "java.lang.Object")
+ tag-sig (&host-generics/->type-signature "java.lang.String")
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ full-name nil super-class (into-array String [])))
+ =sum-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/sum-tag-field tag-sig nil &/sum-tag)
+ (.visitEnd))
+ =product-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/product-tag-field tag-sig nil &/product-tag)
+ (.visitEnd))
+ =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (&&/save-class! (second (string/split &&/lux-utils-class #"/"))
+ (.toByteArray (doto =class .visitEnd)))))
+
(defn compile-jvm-try [compile ?body ?catches ?finally]
(|do [^MethodVisitor *writer* &/get-writer
:let [$from (new Label)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index f6abed570..edafc67e2 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -75,15 +75,19 @@
(defn compile-variant [compile ?tag ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
- (.visitLdcInsn (int 2))
+ (.visitLdcInsn (int 3))
(.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
+ (.visitFieldInsn Opcodes/GETSTATIC &&/lux-utils-class &&/sum-tag-field "Ljava/lang/String;")
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 1))
(.visitLdcInsn ?tag)
(&&/wrap-long)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1)))]
+ (.visitLdcInsn (int 2)))]
_ (compile ?value)
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
index 06aac90a0..e053c8b3c 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -71,8 +71,8 @@
(&/$TupleT members)
(variant$ &/$TupleT (List$ (&/|map type->analysis members)))
- (&/$VariantT members)
- (variant$ &/$VariantT (List$ (&/|map type->analysis members)))
+ (&/$SumT left right)
+ (variant$ &/$SumT (tuple$ (&/|list (type->analysis left) (type->analysis right))))
(&/$LambdaT input output)
(variant$ &/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output))))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 3b0cc241d..c54da0799 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -66,7 +66,7 @@
(&/$UnitT)
(return "V")
- (&/$VariantT _)
+ (&/$SumT _)
(return object-array)
(&/$TupleT _)
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index 516b6a947..d25010620 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -16,7 +16,7 @@
(|do [elems (&/repeat% parse)
token &lexer/lex]
(|case token
- [meta [<close-token> _]]
+ [meta (<close-tag> _)]
(return (&/V <tag> (&/fold &/|++ &/Nil$ elems)))
_
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 8a43eeda6..66ea59f6c 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -38,9 +38,8 @@
(defn Tuple$ [members]
(assert (> (&/|length members) 0))
(&/V &/$TupleT members))
-(defn Variant$ [members]
- (assert (> (&/|length members) 0))
- (&/V &/$VariantT members))
+(defn Sum$ [left right]
+ (&/V &/$SumT (&/T left right)))
(defn Univ$ [env body]
(&/V &/$UnivQ (&/T env body)))
(defn Ex$ [env body]
@@ -65,24 +64,23 @@
(def List
(Named$ (&/T "lux" "List")
(Univ$ empty-env
- (Variant$ (&/|list
- ;; lux;Nil
- Unit
- ;; lux;Cons
- (Tuple$ (&/|list (Bound$ 1)
- (App$ (Bound$ 0)
- (Bound$ 1))))
- )))))
+ (Sum$
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ 1)
+ (App$ (Bound$ 0)
+ (Bound$ 1))))))))
(def Maybe
(Named$ (&/T "lux" "Maybe")
(Univ$ empty-env
- (Variant$ (&/|list
- ;; lux;None
- Unit
- ;; lux;Some
- (Bound$ 1)
- )))))
+ (Sum$
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ 1))
+ )))
(def Type
(Named$ (&/T "lux" "Type")
@@ -90,58 +88,75 @@
TypeList (App$ List Type)
TypePair (Tuple$ (&/|list Type Type))]
(App$ (Univ$ empty-env
- (Variant$ (&/|list
- ;; DataT
- (Tuple$ (&/|list Text TypeList))
- ;; VoidT
- Unit
- ;; UnitT
- Unit
- ;; VariantT
- TypeList
- ;; TupleT
- TypeList
- ;; LambdaT
- TypePair
- ;; BoundT
- Int
- ;; VarT
- Int
- ;; ExT
- Int
- ;; UnivQ
- (Tuple$ (&/|list TypeList Type))
+ (Sum$
+ ;; DataT
+ (Tuple$ (&/|list Text TypeList))
+ (Sum$
+ ;; VoidT
+ Unit
+ (Sum$
+ ;; UnitT
+ Unit
+ (Sum$
+ ;; SumT
+ TypePair
+ (Sum$
+ ;; TupleT
+ TypeList
+ (Sum$
+ ;; LambdaT
+ TypePair
+ (Sum$
+ ;; BoundT
+ Int
+ (Sum$
+ ;; VarT
+ Int
+ (Sum$
+ ;; ExT
+ Int
+ (Sum$
+ ;; UnivQ
+ (Tuple$ (&/|list TypeList Type))
+ (Sum$
;; ExQ
(Tuple$ (&/|list TypeList Type))
- ;; AppT
- TypePair
- ;; NamedT
- (Tuple$ (&/|list Ident Type))
- )))
+ (Sum$
+ ;; AppT
+ TypePair
+ ;; NamedT
+ (Tuple$ (&/|list Ident Type))))))))))))))
+ )
$Void))))
(def DefMetaValue
(Named$ (&/T "lux" "DefMetaValue")
(let [DefMetaValue (App$ (Bound$ 0) (Bound$ 1))]
(App$ (Univ$ empty-env
- (Variant$ (&/|list
- ;; BoolM
- Bool
- ;; IntM
- Int
- ;; RealM
- Real
- ;; CharM
- Char
- ;; TextM
- Text
- ;; IdentM
- Ident
- ;; ListM
- (App$ List DefMetaValue)
- ;; DictM
- (App$ List (Tuple$ (&/|list Text DefMetaValue)))
- )))
+ (Sum$
+ ;; BoolM
+ Bool
+ (Sum$
+ ;; IntM
+ Int
+ (Sum$
+ ;; RealM
+ Real
+ (Sum$
+ ;; CharM
+ Char
+ (Sum$
+ ;; TextM
+ Text
+ (Sum$
+ ;; IdentM
+ Ident
+ (Sum$
+ ;; ListM
+ (App$ List DefMetaValue)
+ ;; DictM
+ (App$ List (Tuple$ (&/|list Text DefMetaValue))))))))))
+ )
$Void))))
(def DefMeta
@@ -194,7 +209,7 @@
(&/$None)
(return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %)
- ts))
+ ts))
state)
nil))
(fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))))))
@@ -279,9 +294,10 @@
(|do [=members (&/map% (partial clean* ?tid) ?members)]
(return (Tuple$ =members)))
- (&/$VariantT ?members)
- (|do [=members (&/map% (partial clean* ?tid) ?members)]
- (return (Variant$ =members)))
+ (&/$SumT ?left ?right)
+ (|do [=left (clean* ?tid ?left)
+ =right (clean* ?tid ?right)]
+ (return (Sum$ =left =right)))
(&/$UnivQ ?env ?body)
(|do [=env (&/map% (partial clean* ?tid) ?env)
@@ -318,6 +334,32 @@
_
(&/T fun-type &/Nil$)))
+(defn flatten-sum [type]
+ "(-> Type (List Type))"
+ (|case type
+ (&/$SumT left right)
+ (&/Cons$ left (flatten-sum right))
+
+ _
+ (&/|list type)))
+
+(defn sum-at [tag type]
+ "(-> Int Type (Lux Type))"
+ (|case type
+ (&/$NamedT ?name ?type)
+ (sum-at tag ?type)
+
+ (&/$SumT ?left ?right)
+ (|case (&/T tag ?right)
+ [0 _] (return ?left)
+ [1 (&/$SumT ?left* _)] (return ?left*)
+ [1 _] (return ?right)
+ [_ (&/$SumT _ _)] (sum-at (dec tag) ?right)
+ _ (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type))))
+
+ _
+ (fail (str "[Type Error] Type is not a variant: " (show-type type)))))
+
(defn show-type [^objects type]
(|case type
(&/$DataT name params)
@@ -339,13 +381,8 @@
"(,)"
(str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")"))
- (&/$VariantT cases)
- (if (&/|empty? cases)
- "(|)"
- (str "(| " (->> cases
- (&/|map show-type)
- (&/|interpose " ")
- (&/fold str "")) ")"))
+ (&/$SumT _)
+ (str "(|| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
(&/$LambdaT input output)
(|let [[?out ?ins] (unravel-fun type)]
@@ -399,10 +436,9 @@
true
xelems yelems)
- [(&/$VariantT xcases) (&/$VariantT ycases)]
- (&/fold2 (fn [old x y] (and old (type= x y)))
- true
- xcases ycases)
+ [(&/$SumT xL xR) (&/$SumT yL yR)]
+ (and (type= xL yL)
+ (type= xR yR))
[(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)]
(and (type= xinput yinput)
@@ -464,10 +500,11 @@
_
(return (show-type type))))
-(defn ^:private check-error [expected actual]
+(defn ^:private check-error [err expected actual]
(|do [=expected (show-type+ expected)
=actual (show-type+ actual)]
- (fail (str "[Type Checker]\n"
+ (fail (str (if (= "" err) err (str err "\n"))
+ "[Type Checker]\n"
"Expected: " =expected "\n\n"
"Actual: " =actual
"\n"))))
@@ -477,8 +514,10 @@
(&/$DataT ?name ?params)
(Data$ ?name (&/|map (partial beta-reduce env) ?params))
- (&/$VariantT ?members)
- (Variant$ (&/|map (partial beta-reduce env) ?members))
+ (&/$SumT ?left ?right)
+ (let [=left (beta-reduce env ?left)
+ =right (beta-reduce env ?right)]
+ (Sum$ =left =right))
(&/$TupleT ?members)
(Tuple$ (&/|map (partial beta-reduce env) ?members))
@@ -599,7 +638,7 @@
[(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)]
(if (= eid aid)
(check* class-loader fixpoints invariant?? eA aA)
- (check-error expected actual))
+ (check-error "" expected actual))
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
@@ -648,7 +687,7 @@
(&/$Some ?)
(if ?
(return (&/T fixpoints nil))
- (check-error expected actual))
+ (check-error "" expected actual))
(&/$None)
(|do [expected* (apply-type F A)]
@@ -714,18 +753,14 @@
e!members a!members)]
(return (&/T fixpoints* nil)))
- [(&/$VariantT e!cases) (&/$VariantT a!cases)]
- (|do [fixpoints* (&/fold2% (fn [fp e a]
- (|do [[fp* _] (check* class-loader fp invariant?? e a)]
- (return fp*)))
- fixpoints
- e!cases a!cases)]
- (return (&/T fixpoints* nil)))
+ [(&/$SumT eL eR) (&/$SumT aL aR)]
+ (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? eL aL)]
+ (check* class-loader fixpoints* invariant?? eR aR))
[(&/$ExT e!id) (&/$ExT a!id)]
(if (.equals ^Object e!id a!id)
(return (&/T fixpoints nil))
- (check-error expected actual))
+ (check-error "" expected actual))
[(&/$NamedT ?ename ?etype) _]
(check* class-loader fixpoints invariant?? ?etype actual)
@@ -736,7 +771,7 @@
[_ _]
(fail ""))
(fn [err]
- (check-error expected actual)))))
+ (check-error err expected actual)))))
(defn check [expected actual]
(|do [class-loader &/loader
@@ -761,22 +796,6 @@
(return type)
))
-(defn variant-case [tag type]
- (|case type
- (&/$NamedT ?name ?type)
- (variant-case tag ?type)
-
- (&/$VariantT ?cases)
- (|case (&/|at tag ?cases)
- (&/$Some case-type)
- (return case-type)
-
- (&/$None)
- (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type))))
-
- _
- (fail (str "[Type Error] Type is not a variant: " (show-type type)))))
-
(defn type-name [type]
"(-> Type (Lux Ident))"
(|case type
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
index b83c74a60..b782f6c44 100644
--- a/src/lux/type/host.clj
+++ b/src/lux/type/host.clj
@@ -220,16 +220,16 @@
(= null-data-tag a!name)
(if (not (primitive-type? e!name))
(return (&/T fixpoints nil))
- (check-error (&/V &/$DataT expected) (&/V &/$DataT actual)))
+ (check-error "" (&/V &/$DataT expected) (&/V &/$DataT actual)))
(= null-data-tag e!name)
(if (= null-data-tag a!name)
(return (&/T fixpoints nil))
- (check-error (&/V &/$DataT expected) (&/V &/$DataT actual)))
+ (check-error "" (&/V &/$DataT expected) (&/V &/$DataT actual)))
(and (= array-data-tag e!name)
(not= array-data-tag a!name))
- (check-error (&/V &/$DataT expected) (&/V &/$DataT actual))
+ (check-error "" (&/V &/$DataT expected) (&/V &/$DataT actual))
:else
(let [e!name (as-obj e!name)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:56:27 +0000