diff options
| -rw-r--r-- | stdlib/source/lux.lux | 63 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/dict.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/lux/data/error.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text/regex.lux | 1 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/lux/type.lux | 18 | ||||
| -rw-r--r-- | stdlib/source/lux/type/check.lux | 32 |
8 files changed, 98 insertions, 65 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 08ef10e51..8be7f8d26 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -143,7 +143,7 @@ TypeList (_lux_case (+4 Type Type) TypePair - (+11 (+9 (+0) + (+11 (+9 #Nil (+3 ## "lux;HostT" (+4 Text TypeList) (+3 ## "lux;VoidT" @@ -195,7 +195,7 @@ ## (Ex [a] a)) (_lux_def Top (#NamedT ["lux" "Top"] - (#ExQ (+0) (#BoundT +1))) + (#ExQ #Nil (#BoundT +1))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "doc"] (+6 "The type of things whose type does not matter. @@ -207,7 +207,7 @@ ## (All [a] a)) (_lux_def Bottom (#NamedT ["lux" "Bottom"] - (#UnivQ (+0) (#BoundT +1))) + (#UnivQ #Nil (#BoundT +1))) (#Cons [["lux" "type?"] (+0 true)] (#Cons [["lux" "export?"] (+0 true)] (#Cons [["lux" "doc"] (+6 "The type of things whose type is unknown or undefined. @@ -351,18 +351,11 @@ (#Cons [["lux" "type-args"] (#ListA (#Cons (#TextA "m") (#Cons (#TextA "v") #;Nil)))] default-def-meta-exported)))) -(_lux_def Analysis - (#NamedT ["lux" "Analysis"] - (#AppT (#AppT Meta - (#ProdT Type Cursor)) - Void)) - default-def-meta-exported) - ## (type: Scope ## {#name (List Text) ## #inner-closures Int -## #locals (Bindings Text Analysis) -## #closure (Bindings Text Analysis)}) +## #locals (Bindings Text Void) +## #closure (Bindings Text Void)}) (_lux_def Scope (#NamedT ["lux" "Scope"] (#ProdT ## "lux;name" @@ -370,9 +363,9 @@ (#ProdT ## "lux;inner-closures" Int (#ProdT ## "lux;locals" - (#AppT (#AppT Bindings Text) Analysis) + (#AppT (#AppT Bindings Text) Void) ## "lux;closure" - (#AppT (#AppT Bindings Text) Analysis))))) + (#AppT (#AppT Bindings Text) Void))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "name") (#Cons (#TextA "inner-closures") (#Cons (#TextA "locals") @@ -400,7 +393,7 @@ (#BoundT +1))) AST (_lux_case (#AppT [List AST]) - ASTList + AST-List (#UnivQ #Nil (#SumT ## "lux;BoolS" Bool @@ -421,9 +414,9 @@ (#SumT ## "lux;TagS" Ident (#SumT ## "lux;FormS" - ASTList + AST-List (#SumT ## "lux;TupleS" - ASTList + AST-List ## "lux;RecordS" (#AppT List (#ProdT AST AST)) ))))))))))) @@ -454,7 +447,7 @@ (#Cons [["lux" "doc"] (#TextA "The type of AST nodes for Lux syntax.")] default-def-meta-exported)) -(_lux_def ASTList +(_lux_def AST-List (#AppT List AST) default-def-meta-unexported) @@ -663,7 +656,7 @@ ## (-> (List AST) (Lux (List AST)))) (_lux_def Macro (#NamedT ["lux" "Macro"] - (#FunctionT ASTList (#AppT Lux ASTList))) + (#FunctionT AST-List (#AppT Lux AST-List))) (#Cons [["lux" "doc"] (#TextA "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")] default-def-meta-exported)) @@ -3737,7 +3730,7 @@ (if rec? (if (empty? args) (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (Text/append name "'")]) + prime-name (symbol$ ["" name]) type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) Void)))) @@ -4118,11 +4111,13 @@ (function [env] (case env {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (find (: (-> [Text Analysis] (Maybe Type)) - (function [[bname [[type _] _]]] - (if (Text/= name bname) - (#Some type) - #None)))) + (try-both (find (: (-> [Text Void] (Maybe Type)) + (function [[bname analysis]] + (let [[[type _] _] (:! (Meta [Type Cursor] Void) + analysis)] + (if (Text/= name bname) + (#Some type) + #None))))) locals closure)))) scopes))) @@ -4461,16 +4456,28 @@ (macro: #export (|>. tokens) {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. - (|> (map Int/encode) (interpose \" \") (fold Text/append \"\")) + (|>. (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => - (function [<something>] + (function [<arg>] (fold Text/append \"\" (interpose \" \" - (map Int/encode <something>))))"} + (map Int/encode <arg>))))"} (do Monad<Lux> [g!arg (gensym "arg")] (return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) +(macro: #export (<|. tokens) + {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. + (<|. (fold Text/append \"\") (interpose \" \") (map Int/encode)) + ## => + (function [<arg>] + (fold Text/append \"\" + (interpose \" \" + (map Int/encode <arg>))))"} + (do Monad<Lux> + [g!arg (gensym "arg")] + (return (list (` (function [(~ g!arg)] (<| (~@ tokens) (~ g!arg)))))))) + (def: (imported-by? import-name module-name) (-> Text Text (Lux Bool)) (do Monad<Lux> diff --git a/stdlib/source/lux/data/coll/dict.lux b/stdlib/source/lux/data/coll/dict.lux index 6a11dcc77..47929c72f 100644 --- a/stdlib/source/lux/data/coll/dict.lux +++ b/stdlib/source/lux/data/coll/dict.lux @@ -572,28 +572,28 @@ (let [[Hash<K> node] dict] (get' root-level (:: Hash<K> hash key) key Hash<K> node))) -(def: #export (contains? key table) +(def: #export (contains? key dict) (All [K V] (-> K (Dict K V) Bool)) - (case (get key table) + (case (get key dict) #;None false (#;Some _) true)) -(def: #export (put~ key val table) +(def: #export (put~ key val dict) {#;doc "Only puts the KV-pair if the key is not already present."} (All [K V] (-> K V (Dict K V) (Dict K V))) - (if (contains? key table) - table - (put key val table))) + (if (contains? key dict) + dict + (put key val dict))) -(def: #export (update key f table) +(def: #export (update key f dict) {#;doc "Transforms the value located at key (if available), using the given function."} (All [K V] (-> K (-> V V) (Dict K V) (Dict K V))) - (case (get key table) + (case (get key dict) #;None - table + dict (#;Some val) - (put key (f val) table))) + (put key (f val) dict))) (def: #export size (All [K V] (-> (Dict K V) Nat)) diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux index 65a0733ff..f614305e0 100644 --- a/stdlib/source/lux/data/error.lux +++ b/stdlib/source/lux/data/error.lux @@ -61,6 +61,10 @@ (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) (liftM Monad<M> (:: Monad<Error> wrap))) +(def: #export (succeed value) + (All [a] (-> a (Error a))) + (#Success value)) + (def: #export (fail message) (All [a] (-> Text (Error a))) (#Error message)) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index b7101a48a..231dfaddf 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -174,7 +174,6 @@ (&;after (&;text "\\S") (wrap (` (->Text (&;not &;space))))) (&;after (&;text "\\w") (wrap (` (->Text word^)))) (&;after (&;text "\\W") (wrap (` (->Text (&;not word^))))) - (&;after (&;text "\\d") (wrap (` (->Text &;digit)))) (&;after (&;text "\\p{Lower}") (wrap (` (->Text &;lower)))) (&;after (&;text "\\p{Upper}") (wrap (` (->Text &;upper)))) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 9bdaeac54..0552df165 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -1621,10 +1621,10 @@ [return-type (let [g!temp (ast;symbol ["" "Ω"])] (` (let [(~ g!temp) (~ return-term)] - (if (null? (:! (host (~' java.lang.Object)) - (~ g!temp))) - (error! "Cannot produce null references from method calls.") - (~ g!temp)))))]) + (if (not (null? (:! (host (~' java.lang.Object)) + (~ g!temp)))) + (~ g!temp) + (error! "Cannot produce null references from method calls.")))))]) _ [return-type return-term])) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 4569eeac6..5a3d3829d 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -10,7 +10,7 @@ [product] [ident "Ident/" Codec<Text,Ident>] maybe - [error #- fail]))) + ["E" error #- fail]))) ## (type: (Lux a) ## (-> Compiler (Error [Compiler a]))) @@ -424,16 +424,20 @@ {#;doc "Looks-up the type of a local variable somewhere in the environment."} (-> Text (Lux Type)) (function [state] - (let [test (: (-> [Text Analysis] Bool) + (let [test (: (-> [Text (Meta [Type Cursor] Void)] Bool) (|>. product;left (Text/= name)))] (case (do Monad<Maybe> [scope (find (function [env] - (or (any? test (get@ [#;locals #;mappings] env)) - (any? test (get@ [#;closure #;mappings] env)))) + (or (any? test (:! (List [Text (Meta [Type Cursor] Void)]) + (get@ [#;locals #;mappings] env))) + (any? test (:! (List [Text (Meta [Type Cursor] Void)]) + (get@ [#;closure #;mappings] env))))) (get@ #;scopes state)) [_ [[type _] _]] (try-both (find test) - (get@ [#;locals #;mappings] scope) - (get@ [#;closure #;mappings] scope))] + (:! (List [Text (Meta [Type Cursor] Void)]) + (get@ [#;locals #;mappings] scope)) + (:! (List [Text (Meta [Type Cursor] Void)]) + (get@ [#;closure #;mappings] scope)))] (wrap type)) (#;Some var-type) (#;Right [state var-type]) @@ -586,6 +590,7 @@ (#;Some scopes) (#;Right [state (List/map (|>. (get@ [#;locals #;mappings]) + (:! (List [Text (Meta [Type Cursor] Void)])) (List/map (function [[name [[type cursor] analysis]]] [name type]))) scopes)])))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index be6f282e1..d125b8b98 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -323,3 +323,21 @@ [univq #;UnivQ] [exq #;ExQ] ) + +(def: #export (quantified? type) + (-> Type Bool) + (case type + (#;NamedT [module name] _type) + (quantified? _type) + + (#;AppT F A) + (default false + (do Monad<Maybe> + [applied (apply-type F A)] + (wrap (quantified? applied)))) + + (^or (#;UnivQ _) (#;ExQ _)) + true + + _ + false)) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index 73092a308..4d93c9024 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -18,13 +18,13 @@ (type: #export Id Nat) -(type: #export Fixpoints (List [[Type Type] Bool])) +(type: #export Fixed (List [[Type Type] Bool])) (type: #export Context {#var-counter Id #ex-counter Id #bindings (dict;Dict Id (Maybe Type)) - #fixpoints Fixpoints + #fixed Fixed }) (type: #export (Check a) @@ -113,7 +113,7 @@ (#;Right [(update@ #ex-counter n.inc context) [id (#;ExT id)]])))) -(def: (bound? id) +(def: #export (bound? id) (-> Id (Check Bool)) (function [context] (case (|> context (get@ #bindings) (dict;get id)) @@ -175,7 +175,7 @@ #;None (#;Left (format "Unknown type-var: " (%n id)))))) -(def: (clean t-id type) +(def: #export (clean t-id type) (-> Id Type (Check Type)) (case type (#;VarT id) @@ -259,7 +259,7 @@ []])))] [get-bindings set-bindings #bindings (dict;Dict Id (Maybe Type))] - [get-fixpoints set-fixpoints #fixpoints Fixpoints] + [get-fixed set-fixed #fixed Fixed] ) (def: #export (delete-var id) @@ -308,7 +308,7 @@ {#var-counter +0 #ex-counter +0 #bindings (dict;new number;Hash<Nat>) - #fixpoints (list) + #fixed (list) }) (def: (attempt op) @@ -343,17 +343,17 @@ (#;Left _) (right context)))) -(def: (fp-get [e a] fixpoints) - (-> [Type Type] Fixpoints (Maybe Bool)) +(def: (fx-get [e a] fixed) + (-> [Type Type] Fixed (Maybe Bool)) (:: Monad<Maybe> map product;right (list;find (function [[[fe fa] status]] (and (Type/= e fe) (Type/= a fa))) - fixpoints))) + fixed))) -(def: (fp-put ea status fixpoints) - (-> [Type Type] Bool Fixpoints Fixpoints) - (#;Cons [ea status] fixpoints)) +(def: (fx-put ea status fixed) + (-> [Type Type] Bool Fixed Fixed) + (#;Cons [ea status] fixed)) (def: #export (check expected actual) {#;doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} @@ -419,9 +419,9 @@ [(#;AppT F A) _] (do Monad<Check> - [#let [fp-pair [expected actual]] - fixpoints get-fixpoints] - (case (fp-get fp-pair fixpoints) + [#let [fx-pair [expected actual]] + fixed get-fixed] + (case (fx-get fx-pair fixed) (#;Some ?) (if ? success @@ -430,7 +430,7 @@ #;None (do Monad<Check> [expected' (apply-type! F A) - _ (set-fixpoints (fp-put fp-pair true fixpoints))] + _ (set-fixed (fx-put fx-pair true fixed))] (check expected' actual)))) [_ (#;AppT F A)] |