aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux143
-rw-r--r--source/lux/data/list.lux4
-rw-r--r--source/lux/meta/lux.lux2
-rw-r--r--source/lux/meta/syntax.lux5
-rw-r--r--src/lux/analyser/base.clj8
-rw-r--r--src/lux/analyser/case.clj60
-rw-r--r--src/lux/analyser/lux.clj18
-rw-r--r--src/lux/type.clj13
8 files changed, 134 insertions, 119 deletions
diff --git a/source/lux.lux b/source/lux.lux
index c1e7b0046..d661b9268 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -691,8 +691,7 @@
(def'' (make-env xs ys)
(#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv))
- (_lux_case (_lux_: (#TupleT (#Cons ($' List Text) (#Cons ($' List AST) #Nil)))
- [xs ys])
+ (_lux_case [xs ys]
[(#Cons x xs') (#Cons y ys')]
(#Cons [x y] (make-env xs' ys'))
@@ -823,13 +822,12 @@
(foldL f (f init x) xs')))
(defmacro' #export (All tokens)
- (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil)))
- (_lux_case tokens
- (#Cons [_ (#SymbolS "" self-name)] tokens)
- [self-name tokens]
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
- _
- ["" tokens]))
+ _
+ ["" tokens])
(_lux_case tokens
(#Cons [_ (#TupleS args)] (#Cons body #Nil))
(parse-univq-args args
@@ -850,13 +848,12 @@
))
(defmacro' #export (Ex tokens)
- (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil)))
- (_lux_case tokens
- (#Cons [_ (#SymbolS "" self-name)] tokens)
- [self-name tokens]
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
- _
- ["" tokens]))
+ _
+ ["" tokens])
(_lux_case tokens
(#Cons [_ (#TupleS args)] (#Cons body #Nil))
(parse-univq-args args
@@ -1313,7 +1310,7 @@
(resolve-global-symbol [subst name])
_
- (wrap (_lux_: Ident [module name])))
+ (wrap [module name]))
#let [[module name] real-name]]
(return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name))))))))
@@ -1330,7 +1327,7 @@
(do Lux/Monad
[output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)
#let [[_ form'] output]]
- (return (_lux_: AST [meta form'])))
+ (return [meta form']))
[_ [_ (#RecordS fields)]]
(do Lux/Monad
@@ -1576,7 +1573,7 @@
["" name]
(do Lux/Monad
[module-name get-module-name]
- (wrap (_lux_: Ident [module-name name])))
+ (wrap [module-name name]))
_
(return ident)))
@@ -1910,20 +1907,18 @@
#None))]
(_lux_case parts
(#Some name args ?type body)
- (let' [body' (: AST
- (_lux_case args
- #Nil
- body
+ (let' [body' (_lux_case args
+ #Nil
+ body
- _
- (` (lambda' (~ name) [(~@ args)] (~ body)))))
- body'' (: AST
- (_lux_case ?type
- (#Some type)
- (` (: (~ type) (~ body')))
-
- #None
- body'))]
+ _
+ (` (lambda' (~ name) [(~@ args)] (~ body))))
+ body'' (_lux_case ?type
+ (#Some type)
+ (` (: (~ type) (~ body')))
+
+ #None
+ body')]
(return (@list& (` (;_lux_def (~ name) (~ body'')))
(if export?
(@list (` (;_lux_export (~ name))))
@@ -2081,14 +2076,14 @@
(#Some ident head tail body)
(let [g!blank (symbol$ ["" ""])
g!name (symbol$ ident)
- body+ (: AST (foldL (: (-> AST AST AST)
- (lambda' [body' arg]
- (if (symbol? arg)
- (` (;_lux_lambda (~ g!blank) (~ arg) (~ body')))
- (` (;_lux_lambda (~ g!blank) (~ g!blank)
- (case (~ g!blank) (~ arg) (~ body')))))))
- body
- (reverse tail)))]
+ body+ (foldL (: (-> AST AST AST)
+ (lambda' [body' arg]
+ (if (symbol? arg)
+ (` (;_lux_lambda (~ g!blank) (~ arg) (~ body')))
+ (` (;_lux_lambda (~ g!blank) (~ g!blank)
+ (case (~ g!blank) (~ arg) (~ body')))))))
+ body
+ (reverse tail))]
(return (@list (if (symbol? head)
(` (;_lux_lambda (~ g!name) (~ head) (~ body+)))
(` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+))))))))
@@ -2121,20 +2116,18 @@
#None))]
(case parts
(#Some name args ?type body)
- (let [body (: AST
- (case args
- #Nil
- body
+ (let [body (case args
+ #Nil
+ body
- _
- (` (lambda (~ name) [(~@ args)] (~ body)))))
- body (: AST
- (case ?type
- (#Some type)
- (` (: (~ type) (~ body)))
-
- #None
- body))]
+ _
+ (` (lambda (~ name) [(~@ args)] (~ body))))
+ body (case ?type
+ (#Some type)
+ (` (: (~ type) (~ body)))
+
+ #None
+ body)]
(return (@list& (` (;_lux_def (~ name) (~ body)))
(if export?
(@list (` (;_lux_export (~ name))))
@@ -2163,12 +2156,12 @@
(case name+args+body??
(#Some [name args body])
(let [name (symbol$ name)
- decls (list:++ (: (List AST) (if exported? (@list (` (;_lux_export (~ name)))) #;Nil))
- (: (List AST) (@list (` (;;_lux_declare-macro (~ name))))))
- def-sig (: AST
- (case args
- #;Nil name
- _ (` ((~ name) (~@ args)))))]
+ decls (: (List AST)
+ (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil)
+ (@list (` (;;_lux_declare-macro (~ name))))))
+ def-sig (case args
+ #;Nil name
+ _ (` ((~ name) (~@ args))))]
(return (@list& (` (;;def (~ def-sig) ;;Macro (~ body)))
decls)))
@@ -2212,15 +2205,14 @@
def-name (symbol$ name)
tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members))
types (map second members)
- sig-type (: AST (` (#TupleT (~ (untemplate-list types)))))
- sig-decl (: AST (` (;_lux_declare-tags [(~@ tags)] (~ def-name))))
- sig+ (: AST
- (case args
- #Nil
- sig-type
+ sig-type (` (#TupleT (~ (untemplate-list types))))
+ sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name)))
+ sig+ (case args
+ #Nil
+ sig-type
- _
- (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]]
+ _
+ (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]]
(return (@list& (` (;_lux_def (~ def-name) (~ sig+)))
sig-decl
(if export?
@@ -2556,13 +2548,12 @@
#None))]
(case ?parts
(#Some name args type defs)
- (let [defs' (: AST
- (case args
- #Nil
- (` (struct (~@ defs)))
+ (let [defs' (case args
+ #Nil
+ (` (struct (~@ defs)))
- _
- (` (lambda (~ name) [(~@ args)] (;struct (~@ defs))))))]
+ _
+ (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))]
(return (@list& (` (def (~ name) (~ type) (~ defs')))
(if export?
(@list (` (;_lux_export (~ name))))
@@ -3036,7 +3027,7 @@
(-> Text Ident AST Type (Lux (List AST)))
(do Lux/Monad
[output (resolve-type-tags type)
- #let [source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))]]
+ #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]]
(case output
(#Some [tags members])
(do Lux/Monad
@@ -3087,7 +3078,7 @@
[m-name m-alias m-referrals m-openings]
(do Lux/Monad
[m-name (clean-module m-name)]
- (wrap (: Importation [m-name m-alias m-referrals m-openings]))))))
+ (wrap [m-name m-alias m-referrals m-openings])))))
imports)
unknowns' (map% Lux/Monad
(: (-> Importation (Lux (List Text)))
@@ -3178,11 +3169,11 @@
(lambda [so-far part]
(case part
[_ (#SymbolS slot)]
- (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far)))))
+ (return (` (get@ (~ (tag$ slot)) (~ so-far))))
(\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))])
- (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far))
- (~@ args)))))
+ (return (` ((get@ (~ (tag$ slot)) (~ so-far))
+ (~@ args))))
_
(fail "Wrong syntax for ::"))))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
index 0da0b3ecb..a6ca4e0f7 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -233,7 +233,7 @@
(defmacro #export (@list xs state)
(#;Right state (#;Cons (foldL (: (-> AST AST AST)
(lambda [tail head] (` (#;Cons (~ head) (~ tail)))))
- (: AST (` #;Nil))
+ (` #;Nil)
(reverse xs))
#;Nil)))
@@ -301,7 +301,7 @@
## [(~@ tokens)]))]
## (#;Right state (@list code))))
## (#;Left "Can't zip-with no lists."))
-
+
## _
## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]]
## (#;Right state (@list (` (let [(~ g!temp) (~ _f)]
diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux
index c71fd70b0..edf3a8667 100644
--- a/source/lux/meta/lux.lux
+++ b/source/lux/meta/lux.lux
@@ -110,7 +110,7 @@
["" name]
(do Lux/Monad
[module-name get-module-name]
- (wrap (: Ident [module-name name])))
+ (wrap [module-name name]))
_
(:: Lux/Monad (M;wrap ident))))
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
index 01acefd36..ee5a37d53 100644
--- a/source/lux/meta/syntax.lux
+++ b/source/lux/meta/syntax.lux
@@ -248,9 +248,8 @@
(l;fail (~ error-msg)))))))
body
(: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers))))
- macro-def (: AST
- (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
- (~ body'))))]]
+ macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
+ (~ body')))]]
(wrap (@list& macro-def
(if exported?
(@list (` (;_lux_export (~ (symbol$ ["" name])))))
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 414d005f1..7f7980e76 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -139,6 +139,14 @@
_
(fail "[Analyser Error] Can't expand to other than 1 element."))))
+(defn analyse-1+ [analyse ?token]
+ (&type/with-var
+ (fn [$var]
+ (|do [=expr (analyse-1 analyse $var ?token)
+ :let [[?item ?type] =expr]
+ =type (&type/clean $var ?type)]
+ (return (&/T ?item =type))))))
+
(defn resolved-ident [ident]
(|let [[?module ?name] ident]
(|do [module* (if (.equals "" ?module)
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index f302088d9..3b12270c2 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -184,11 +184,7 @@
(&/$RecordS pairs)
(|do [?members (&&record/order-record pairs)
- ;; :let [_ (prn 'PRE (&type/show-type value-type))]
- value-type* (adjust-type value-type)
- ;; :let [_ (prn 'POST (&type/show-type value-type*))]
- ;; value-type* (resolve-type value-type)
- ]
+ value-type* (adjust-type value-type)]
(|case value-type*
(&/$TupleT ?member-types)
(if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
@@ -333,6 +329,15 @@
(return (&/V $VariantTotal (&/T total? structs))))
))))
+(defn check-totality+ [check-totality]
+ (fn [?token]
+ (&type/with-var
+ (fn [$var]
+ (|do [=output (check-totality $var ?token)
+ ?type (&type/deref+ $var)
+ =type (&type/clean $var ?type)]
+ (return (&/T =output =type)))))))
+
(defn ^:private check-totality [value-type struct]
;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct))
(|case struct
@@ -340,34 +345,45 @@
(return ?total)
($BoolTotal ?total ?values)
- (return (or ?total
- (= #{true false} (set (&/->seq ?values)))))
+ (|do [_ (&type/check value-type &type/Bool)]
+ (return (or ?total
+ (= #{true false} (set (&/->seq ?values))))))
($IntTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Int)]
+ (return ?total))
($RealTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Real)]
+ (return ?total))
($CharTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Char)]
+ (return ?total))
($TextTotal ?total _)
- (return ?total)
+ (|do [_ (&type/check value-type &type/Text)]
+ (return ?total))
($TupleTotal ?total ?structs)
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
- (&/$TupleT ?members)
- (|do [totals (&/map2% (fn [sub-struct ?member]
- (check-totality ?member sub-struct))
- ?structs ?members)]
- (return (&/fold #(and %1 %2) true totals)))
+ (|do [unknown? (&type/unknown? value-type)]
+ (if unknown?
+ (|do [=structs (&/map% (check-totality+ check-totality) ?structs)
+ _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))]
+ (return (or ?total
+ (&/fold #(and %1 %2) true (&/|map &/|first =structs)))))
+ (if ?total
+ (return true)
+ (|do [value-type* (resolve-type value-type)]
+ (|case value-type*
+ (&/$TupleT ?members)
+ (|do [totals (&/map2% (fn [sub-struct ?member]
+ (check-totality ?member sub-struct))
+ ?structs ?members)]
+ (return (&/fold #(and %1 %2) true totals)))
- _
- (fail "[Pattern-maching Error] Tuple is not total."))))
+ _
+ (fail "[Pattern-maching Error] Tuple is not total."))))))
($VariantTotal ?total ?structs)
(if ?total
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 62202c1c9..3a9b822ca 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -18,19 +18,11 @@
[module :as &&module]
[record :as &&record])))
-(defn ^:private analyse-1+ [analyse ?token]
- (&type/with-var
- (fn [$var]
- (|do [=expr (&&/analyse-1 analyse $var ?token)
- :let [[?item ?type] =expr]
- =type (&type/clean $var ?type)]
- (return (&/T ?item =type))))))
-
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
(|do [unknown? (&type/unknown? exo-type)]
(if unknown?
- (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)]
+ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)]
(return =analysis))
?elems)
_ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))]
@@ -52,7 +44,7 @@
(analyse-tuple analyse exo-type** ?elems))))
_
- (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))))
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type))))))))
(defn ^:private analyse-variant-body [analyse exo-type ?values]
(|do [output (|case ?values
@@ -303,7 +295,7 @@
(|do [:let [num-branches (&/|length ?branches)]
_ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.")
_ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.")
- =value (analyse-1+ analyse ?value)
+ =value (&&/analyse-1+ analyse ?value)
=match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))]
(return (&/|list (&/T (&/V &&/$case (&/T =value =match))
exo-type)))))
@@ -382,7 +374,7 @@
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
(|do [=value (&/with-scope ?name
- (analyse-1+ analyse ?value))]
+ (&&/analyse-1+ analyse ?value))]
(|case =value
[(&&/$var (&/$Global ?r-module ?r-name)) _]
(|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))
@@ -452,6 +444,6 @@
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
_ (&type/check exo-type ==type)
- =value (analyse-1+ analyse ?value)]
+ =value (&&/analyse-1+ analyse ?value)]
(return (&/|list (&/T (&/V &&/$ann (&/T =value =type))
==type)))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index f067867d8..5fbc33de2 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -336,6 +336,14 @@
(fail* (str "[Type Error] Unbound type-var: " id)))
(fail* (str "[Type Error] <deref> Unknown type-var: " id)))))
+(defn deref+ [type]
+ (|case type
+ (&/$VarT id)
+ (deref id)
+
+ _
+ (fail (str "[Type Error] Type is not a variable: " (show-type type)))))
+
(defn set-var [id type]
(fn [state]
(if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))]
@@ -914,8 +922,9 @@
(|do [type* (apply-type ?all ?param)]
(actual-type type*))
- (&/$VarT ?id)
- (deref ?id)
+ (&/$VarT id)
+ (|do [=type (deref id)]
+ (actual-type =type))
(&/$NamedT ?name ?type)
(actual-type ?type)