diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 143 | ||||
| -rw-r--r-- | source/lux/data/list.lux | 4 | ||||
| -rw-r--r-- | source/lux/meta/lux.lux | 2 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 5 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 8 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 60 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 18 | ||||
| -rw-r--r-- | src/lux/type.clj | 13 |
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) |