aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--source/lux.lux154
-rw-r--r--src/lux/analyser/case.clj28
-rw-r--r--src/lux/analyser/lambda.clj8
-rw-r--r--src/lux/analyser/module.clj31
-rw-r--r--src/lux/base.clj4
-rw-r--r--src/lux/compiler/base.clj1
-rw-r--r--src/lux/compiler/case.clj25
-rw-r--r--src/lux/compiler/lux.clj4
-rw-r--r--src/lux/type.clj14
9 files changed, 158 insertions, 111 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 7c5fd5c8d..bdb845f1b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -63,7 +63,7 @@
## (1 a)))
(_lux_def Maybe
(11 ["lux" "Maybe"]
- (9 (1 (0)) "lux;Maybe" "a"
+ (9 (1 #Nil) "lux;Maybe" "a"
(2 ## "lux;None"
Unit
## "lux;Some"
@@ -92,7 +92,7 @@
Type
(_lux_case (10 List (3 Text Type))
TypeEnv
- (10 (9 (1 (0)) "Type" "_"
+ (10 (9 (#Some #Nil) "Type" "_"
(2 ## lux;VoidT
Unit
(2 ## lux;UnitT
@@ -493,7 +493,7 @@
(_lux_: Macro
(_lux_lambda _ tokens
(_lux_case tokens
- (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))
+ (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))
(return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
(#Cons (_meta (#SymbolS "" ""))
(#Cons arg
@@ -508,7 +508,7 @@
#Nil))))))
#Nil))
- (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)))
+ (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)))
(return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
(#Cons (_meta (#SymbolS self))
(#Cons arg
@@ -531,9 +531,9 @@
(_lux_: Macro
(lambda'' [tokens]
(_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])])
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])])
+ (#Cons [_ (#TagS ["" "export"])]
+ (#Cons [_ (#FormS (#Cons name args))]
+ (#Cons type (#Cons body #Nil))))
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
(#Cons [name
(#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
@@ -547,7 +547,7 @@
(#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
#Nil])]))
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (#Cons [_ (#TagS "" "export")] (#Cons name (#Cons type (#Cons body #Nil))))
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
(#Cons [name
(#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
@@ -558,8 +558,8 @@
(#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])])))
#Nil])]))
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
- (#Cons [type (#Cons [body #Nil])])])
+ (#Cons [_ (#FormS (#Cons name args))]
+ (#Cons type (#Cons body #Nil)))
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
(#Cons [name
(#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
@@ -572,7 +572,7 @@
#Nil])])])))
#Nil]))
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (#Cons name (#Cons type (#Cons body #Nil)))
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
(#Cons [name
(#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
@@ -590,7 +590,7 @@
(def'' (defmacro tokens)
Macro
(_lux_case tokens
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
+ (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])
(return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"])
(#Cons [(form$ (#Cons [name args]))
(#Cons [(symbol$ ["lux" "Macro"])
@@ -600,7 +600,7 @@
(#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])]))
#Nil])]))
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])])
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])])
(return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"])
(#Cons [(tag$ ["" "export"])
(#Cons [(form$ (#Cons [name args]))
@@ -640,12 +640,12 @@
(defmacro (All' tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS #Nil)])
+ (#Cons [[_ (#TupleS #Nil)]
(#Cons [body #Nil])])
(return (#Cons [body
#Nil]))
- (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))])
+ (#Cons [[_ (#TupleS (#Cons [[_ (#SymbolS ["" arg-name])] other-args]))]
(#Cons [body #Nil])])
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"]))
(#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"]))
@@ -664,7 +664,7 @@
(defmacro (B' tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS ["" bound-name])])
+ (#Cons [[_ (#SymbolS ["" bound-name])]
#Nil])
(return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"]))
(#Cons [(_meta (#TextS bound-name))
@@ -732,15 +732,15 @@
(fail "Wrong syntax for list&")))
(defmacro (lambda' tokens)
- (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST)))
+ (let'' [name tokens'] (_lux_: (#ProdT Ident ($' List AST))
(_lux_case tokens
- (#Cons [(#Meta [_ (#SymbolS name)]) tokens'])
+ (#Cons [[_ (#SymbolS name)] tokens'])
[name tokens']
_
[["" ""] tokens]))
(_lux_case tokens'
- (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
+ (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])])
(_lux_case args
#Nil
(fail "lambda' requires a non-empty arguments tuple.")
@@ -762,8 +762,8 @@
(defmacro (def''' tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])])
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [[_ (#TagS ["" "export"])]
+ (#Cons [[_ (#FormS (#Cons [name args]))]
(#Cons [type (#Cons [body #Nil])])])])
(return (list (form$ (list (symbol$ ["" "_lux_def"])
name
@@ -775,7 +775,7 @@
body))))))
(form$ (list (symbol$ ["" "_lux_export"]) name))))
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
(return (list (form$ (list (symbol$ ["" "_lux_def"])
name
(form$ (list (symbol$ ["" "_lux_:"])
@@ -783,7 +783,7 @@
body))))
(form$ (list (symbol$ ["" "_lux_export"]) name))))
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))])
+ (#Cons [[_ (#FormS (#Cons [name args]))]
(#Cons [type (#Cons [body #Nil])])])
(return (list (form$ (list (symbol$ ["" "_lux_def"])
name
@@ -805,7 +805,7 @@
(def''' (as-pairs xs)
(All' [a]
- (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a))))))
+ (->' ($' List (B' a)) ($' List (#ProdT (B' a) (B' a)))))
(_lux_case xs
(#Cons [x (#Cons [y xs'])])
(#Cons [[x y] (as-pairs xs')])
@@ -815,8 +815,8 @@
(defmacro (let' tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])
- (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST))
+ (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])])
+ (return (list (foldL (_lux_: (->' AST (#ProdT AST AST)
AST)
(lambda' [body binding]
(_lux_case binding
@@ -853,7 +853,7 @@
(def''' (spliced? token)
(->' AST Bool)
(_lux_case token
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))])
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))]
true
_
@@ -861,9 +861,8 @@
(def''' (wrap-meta content)
(->' AST AST)
- (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"]))
- (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
- content)))))))
+ (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1)))))
+ content))))
(def''' (untemplate-list tokens)
(->' ($' List AST) AST)
@@ -902,7 +901,7 @@
true
(let' [elems' (map (lambda' [elem]
(_lux_case elem
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))]
spliced
_
@@ -923,23 +922,23 @@
(def''' (untemplate replace? subst token)
(->' Bool Text AST AST)
- (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token])
- [_ (#Meta [_ (#BoolS value)])]
+ (_lux_case (_lux_: (#ProdT Bool AST) [replace? token])
+ [_ [_ (#BoolS value)]]
(wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
- [_ (#Meta [_ (#IntS value)])]
+ [_ [_ (#IntS value)]]
(wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
- [_ (#Meta [_ (#RealS value)])]
+ [_ [_ (#RealS value)]]
(wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
- [_ (#Meta [_ (#CharS value)])]
+ [_ [_ (#CharS value)]]
(wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
- [_ (#Meta [_ (#TextS value)])]
+ [_ [_ (#TextS value)]]
(wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
- [_ (#Meta [_ (#TagS [module name])])]
+ [_ [_ (#TagS [module name])]]
(let' [module' (_lux_case module
""
subst
@@ -948,7 +947,7 @@
module)]
(wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
- [_ (#Meta [_ (#SymbolS [module name])])]
+ [_ [_ (#SymbolS [module name])]]
(let' [module' (_lux_case module
""
subst
@@ -957,19 +956,19 @@
module)]
(wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
- [_ (#Meta [_ (#TupleS elems)])]
+ [_ [_ (#TupleS elems)]]
(splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
- [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
+ [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]]
unquoted
- [_ (#Meta [meta (#FormS elems)])]
- (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)]
- (#Meta [meta form']))
+ [_ [meta (#FormS elems)]]
+ (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)]
+ [meta form'])
- [_ (#Meta [_ (#RecordS fields)])]
+ [_ [_ (#RecordS fields)]]
(wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
- (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST)
+ (untemplate-list (map (_lux_: (->' (#ProdT AST AST) AST)
(lambda' [kv]
(let' [[k v] kv]
(tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v))))))
@@ -995,16 +994,17 @@
(defmacro #export (|> tokens)
(_lux_case tokens
(#Cons [init apps])
- (return (list (foldL (lambda' [acc app]
- (_lux_case app
- (#Meta [_ (#TupleS parts)])
- (tuple$ (list:++ parts (list acc)))
+ (return (list (foldL (_lux_: (->' AST AST AST)
+ (lambda' [acc app]
+ (_lux_case app
+ [_ (#TupleS parts)]
+ (tuple$ (list:++ parts (list acc)))
- (#Meta [_ (#FormS parts)])
- (form$ (list:++ parts (list acc)))
+ [_ (#FormS parts)]
+ (form$ (list:++ parts (list acc)))
- _
- (`' ((~ app) (~ acc)))))
+ _
+ (`' ((~ app) (~ acc))))))
init
apps)))
@@ -1026,7 +1026,7 @@
(def''' #export Lux
Type
(All' [a]
- (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a)))))))
+ (->' Compiler ($' Either Text (#ProdT Compiler (B' a))))))
## (defsig (Monad m)
## (: (All [a] (-> a (m a)))
@@ -1037,10 +1037,10 @@
Type
(#NamedT ["lux" "Monad"]
(All' [m]
- (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a))))
- (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
- ($' (B' m) (B' a))
- ($' (B' m) (B' b)))))))))
+ (#ProdT (All' [a] (->' (B' a) ($' (B' m) (B' a))))
+ (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
+ ($' (B' m) (B' a))
+ ($' (B' m) (B' b))))))))
(_lux_declare-tags [#return #bind] Monad)
(def''' Maybe/Monad
@@ -1074,7 +1074,7 @@
(defmacro #export (^ tokens)
(_lux_case tokens
- (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil)
+ (#Cons [_ (#SymbolS "" class-name)] #Nil)
(return (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))
_
@@ -1083,7 +1083,8 @@
(defmacro #export (-> tokens)
(_lux_case (reverse tokens)
(#Cons output inputs)
- (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))
+ (return (list (foldL (_lux_: (->' AST AST AST)
+ (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))))
output
inputs)))
@@ -1091,16 +1092,25 @@
(fail "Wrong syntax for ->")))
(defmacro #export (, tokens)
- (return (list (`' (#;TupleT (~ (untemplate-list tokens)))))))
+ (_lux_case (reverse tokens)
+ (#Cons last prevs)
+ (return (list (foldL (_lux_: (->' AST AST AST)
+ (lambda' [r l] (`' (#;ProdT (~ l) (~ r)))))
+ last
+ prevs)))
+
+ _
+ (fail "Wrong syntax for ,"))
+ )
(defmacro (do tokens)
(_lux_case tokens
- (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil)))
+ (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil)))
(let' [body' (foldL (_lux_: (-> AST (, AST AST) AST)
(lambda' [body' binding]
(let' [[var value] binding]
(_lux_case var
- (#Meta _ (#TagS "" "let"))
+ [_ (#TagS "" "let")]
(`' (;let' (~ value) (~ body')))
_
@@ -1146,7 +1156,7 @@
(def''' (get-ident x)
(-> AST ($' Maybe Ident))
(_lux_case x
- (#Meta [_ (#SymbolS sname)])
+ [_ (#SymbolS sname)]
(#Some sname)
_
@@ -1155,7 +1165,7 @@
(def''' (get-name x)
(-> AST ($' Maybe Text))
(_lux_case x
- (#Meta [_ (#SymbolS ["" sname])])
+ [_ (#SymbolS ["" sname])]
(#Some sname)
_
@@ -1164,7 +1174,7 @@
(def''' (tuple->list tuple)
(-> AST ($' Maybe ($' List AST)))
(_lux_case tuple
- (#Meta [_ (#TupleS members)])
+ [_ (#TupleS members)]
(#Some members)
_
@@ -1203,7 +1213,7 @@
(def''' (apply-template env template)
(-> RepEnv AST AST)
(_lux_case template
- (#Meta [_ (#SymbolS ["" sname])])
+ [_ (#SymbolS ["" sname])]
(_lux_case (get-rep sname env)
(#Some subst)
subst
@@ -1211,13 +1221,13 @@
_
template)
- (#Meta [_ (#TupleS elems)])
+ [_ (#TupleS elems)]
(tuple$ (map (apply-template env) elems))
- (#Meta [_ (#FormS elems)])
+ [_ (#FormS elems)]
(form$ (map (apply-template env) elems))
- (#Meta [_ (#RecordS members)])
+ [_ (#RecordS members)]
(record$ (map (_lux_: (-> (, AST AST) (, AST AST))
(lambda' [kv]
(let' [[slot value] kv]
@@ -1239,7 +1249,7 @@
(defmacro #export (do-template tokens)
(_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])])
+ (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])])
(_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST))))
[(map% Maybe/Monad get-name bindings)
(map% Maybe/Monad tuple->list data)])
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index aab25d741..212f02665 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -25,6 +25,7 @@
"RealTotal"
"CharTotal"
"TextTotal"
+ "UnitTotal"
"ProdTotal"
"SumTotal"]
)
@@ -36,6 +37,7 @@
"RealTestAC"
"CharTestAC"
"TextTestAC"
+ "UnitTestAC"
"ProdTestAC"
"SumTestAC"]
)
@@ -113,11 +115,14 @@
type* (adjust-type type)
idx (&module/tag-index =module =name)
group (&module/tag-group =module =name)
+ ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))]
case-type (&type/variant-case idx type*)]
(return ($$ &/P idx (&/|length group) case-type))))
(defn ^:private analyse-pattern [value-type pattern kont]
- (|let [[_ pattern*] pattern]
+ (|let [[_ pattern*] pattern
+ ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))]
+ ]
(|case pattern*
(&/$SymbolS "" name)
(|do [=kont (&env/with-local name value-type
@@ -153,6 +158,11 @@
=kont kont]
(return (&/P (&/S $TextTestAC ?value) =kont)))
+ (&/$TupleS (&/$Nil))
+ (|do [_ (&type/check value-type &type/Unit)
+ =kont kont]
+ (return (&/P (&/S $UnitTestAC nil) =kont)))
+
(&/$TupleS (&/$Cons ?_left ?tail))
(|do [value-type* (adjust-type value-type)]
(|case value-type*
@@ -168,7 +178,7 @@
_
(analyse-pattern ?right (&/S &/$TupleS ?tail) kont))]
(return (&/P =right =kont))))]
- (return (&/P (&/S $ProdTestAC =left =right) =kont)))
+ (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont)))
_
(fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*)))))
@@ -182,8 +192,7 @@
[=test =kont] (analyse-pattern case-type unit kont)]
(return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont)))
- (&/$FormS (&/$Cons [_ (&/$TagS ?ident)]
- ?values))
+ (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))
(|do [[idx group-count case-type] (resolve-tag ?ident value-type)
[=test =kont] (case (&/|length ?values)
0 (analyse-pattern case-type unit kont)
@@ -240,6 +249,12 @@
[($TextTotal total? ?values) ($TextTestAC ?value)]
(return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values))))
+ [($DefaultTotal total?) ($UnitTestAC)]
+ (return (&/S $UnitTotal nil))
+
+ [($UnitTotal) ($UnitTestAC)]
+ (return (&/S $UnitTotal nil))
+
[($DefaultTotal total?) ($ProdTestAC ?left ?right)]
(|do [:let [_default (&/S $DefaultTotal total?)]
=left (merge-total _default (&/P ?left ?body))
@@ -301,6 +316,9 @@
($TextTotal ?total _)
(return ?total)
+ ($UnitTotal)
+ (return true)
+
($ProdTotal ?total ?_left ?_right)
(if ?total
(return true)
@@ -329,7 +347,7 @@
(fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.")
_
- (check-totality ?right ($SumTotal ?total ?tail)))]
+ (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))]
(return (and =left =right)))
_
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 696c816e9..b30953f67 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -30,10 +30,10 @@
(->> frame (&/$get-closure) (&/$get-counter))
register))
register-type)]
- (do (prn 'close-over 'updating-closure
- [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
- [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
- (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
+ (do ;; (prn 'close-over 'updating-closure
+ ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
+ ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
+ ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
($$ &/P register* (&/$update-closure #(->> %
(&/$update-counter inc)
(&/$update-mappings (fn [mps] (&/|put name register* mps))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 909e7e2c4..bc9647f9f 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -349,20 +349,17 @@
nil))
(fail* (str "[Lux Error] Unknown module: " module))))))
-(defn tag-index [module tag-name]
- "(-> Text Text (Lux Int))"
- (fn [state]
- (if-let [=module (->> state (&/$get-modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
- (return* state (aget idx+tags 0))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
-
-(defn tag-group [module tag-name]
- "(-> Text Text (Lux (List Ident)))"
- (fn [state]
- (if-let [=module (->> state (&/$get-modules) (&/|get module))]
- (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
- (return* state (aget idx+tags 1))
- (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
- (fail* (str "[Module Error] Unknown module: " module)))))
+(do-template [<name> <member> <type>]
+ (defn <name> [module tag-name]
+ <type>
+ (fn [state]
+ (if-let [=module (->> state (&/$get-modules) (&/|get module))]
+ (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
+ (|let [[idx tags type] idx+tags]
+ (return* state <member>))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
+
+ tag-index idx "(-> Text Text (Lux Int))"
+ tag-group tags "(-> Text Text (Lux (List Ident)))"
+ )
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 2f0925586..d261145ae 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -21,7 +21,7 @@
(defmacro deftags [names]
(assert (vector? names))
`(do ~@(for [[name idx] (map vector names (range (count names)))]
- `(def ~(symbol (str "$" name)) ~idx))))
+ `(def ~(symbol (str "$" name)) (int ~idx)))))
(defn ^:private unfold-accesses
([elems]
@@ -793,7 +793,7 @@
(defn with-writer [writer body]
(fn [state]
- (prn 'with-writer writer body)
+ ;; (prn 'with-writer writer body)
(let [output (body ($update-host #($set-writer (Some$ writer) %) state))]
(|case output
($Right ?state ?value)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 72d569ed1..e327d1de4 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -94,6 +94,7 @@
(do-template [<name> <class> <sig> <method>]
(defn <name> [^MethodVisitor writer]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST <class>)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> (str "()" <sig>))))
unwrap-boolean "java/lang/Boolean" "Z" "booleanValue"
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index b30fcb4f8..0a928a056 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -84,27 +84,36 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
+ (&a-case/$UnitTestAC)
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target))
+
(&a-case/$ProdTestAC left right)
(let [$post-left (new Label)
- $post-right (new Label)]
+ $post-right (new Label)
+ $pre-else (new Label)]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitInsn Opcodes/AALOAD)
- (compile-match left $post-left $else)
+ (compile-match left $post-left $pre-else)
(.visitLabel $post-left)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
- (compile-match right $post-right $else)
+ (compile-match right $post-right $pre-else)
(.visitLabel $post-right)
(.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $target)))
+ (.visitJumpInsn Opcodes/GOTO $target)
+ (.visitLabel $pre-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else)))
(&a-case/$SumTestAC ?tag ?count ?test)
(let [$value-then (new Label)
- $sum-else (new Label)]
+ $pre-else (new Label)]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
(.visitInsn Opcodes/DUP)
@@ -112,15 +121,15 @@
(.visitInsn Opcodes/AALOAD)
(&&/unwrap-int)
(.visitLdcInsn (int ?tag))
- (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1))
(.visitInsn Opcodes/AALOAD)
- (compile-match ?test $value-then $sum-else)
+ (compile-match ?test $value-then $pre-else)
(.visitLabel $value-then)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target)
- (.visitLabel $sum-else)
+ (.visitLabel $pre-else)
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $else)))
)))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 79383acc0..10ee40839 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -138,7 +138,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$TypeD) ;; VVIT
- (&&/wrap-long)
+ (&&/wrap-int)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
@@ -165,7 +165,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$ValueD) ;; VVIT
- (&&/wrap-long)
+ (&&/wrap-int)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 4193d8df4..91bc6e480 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -548,6 +548,12 @@
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
(let [output (|case [x y]
+ [(&/$UnitT) (&/$UnitT)]
+ true
+
+ [(&/$VoidT) (&/$VoidT)]
+ true
+
[(&/$DataT xname) (&/$DataT yname)]
(.equals ^Object xname yname)
@@ -704,6 +710,9 @@
(if (clojure.lang.Util/identical expected actual)
(return (&/P fixpoints nil))
(|case [expected actual]
+ [(&/$UnitT) (&/$UnitT)]
+ (return (&/P fixpoints nil))
+
[(&/$VarT ?eid) (&/$VarT ?aid)]
(if (.equals ^Object ?eid ?aid)
(return (&/P fixpoints nil))
@@ -840,7 +849,7 @@
(println 'FIXPOINTS (->> (&/|keys fixpoints)
(&/|map (fn [pair]
(|let [[e a] pair]
- (str (show-type e) ":+:"
+ (str (show-type e) " :+: "
(show-type a)))))
(&/|interpose "\n\n")
(&/fold str "")))
@@ -909,6 +918,9 @@
[_ (&/$NamedT ?aname ?atype)]
(check* class-loader fixpoints expected ?atype)
+ [_ (&/$VoidT)]
+ (return (&/P fixpoints nil))
+
[_ _]
(fail (check-error expected actual))
)))