diff options
Diffstat (limited to 'stdlib/source')
19 files changed, 836 insertions, 246 deletions
diff --git a/stdlib/source/library/lux/control/aspect.lux b/stdlib/source/library/lux/control/aspect.lux new file mode 100644 index 000000000..ae08932e3 --- /dev/null +++ b/stdlib/source/library/lux/control/aspect.lux @@ -0,0 +1,324 @@ +(.require + [library + [lux (.except Global #Local #location with local global) + [abstract + [monad (.only do)]] + [control + ["?" parser] + ["[0]" maybe] + [function + [predicate (.only Predicate)]]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" mix) + ["[0]" property]]]] + ["[0]" meta (.only) + [extension (.only analysis declaration)] + ["[0]" code (.only) + ["?[1]" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)] + ["^" pattern]] + [type + ["[0]" check]] + [compiler + ["[0]" phase] + [language + [lux + ["[0]" declaration] + ["[0]" analysis (.only) + ["[0]" module] + ["[0]" type]]]]]]]]) + +(type .public (Advice value) + (-> value value)) + +(type .public After + Advice) + +(type .public (Around input output) + (Advice (-> input output))) + +(def .public (before pre) + (All (_ input output) + (-> (-> input input) + (Around input output))) + (function (_ it input) + (it (pre input)))) + +(type .public (Reference name) + (Record + [#name name + #type Type])) + +(type .public Local + (Reference Text)) + +(type .public Global + (Reference Symbol)) + +(type .public Scenario + (Variant + {#Local Local} + {#Global Global})) + +(type .public Join_Point + (Record + [#location Location + #scenario Scenario])) + +(type .public Point_Cut + (Predicate Join_Point)) + +(def .public (when_module ?) + (-> (Predicate Text) + Point_Cut) + (|>> (the [#location .#module]) + ?)) + +(with_template [<type> <tag> <name>] + [(def .public (<name> ?) + (-> (Predicate <type>) + Point_Cut) + (function (_ it) + (when (the #scenario it) + {<tag> it} + (? it) + + _ + false)))] + + [Local #Local when_local] + [Global #Global when_global] + ) + +(def .public (typed? expected) + (-> Type + Point_Cut) + (function (_ it) + (when (the #scenario it) + (^.or {#Local [_ it]} + {#Global [_ it]}) + (check.subsumes? expected it)))) + +(type .public Aspect + (List [Point_Cut Symbol])) + +(def (without_global [module short]) + (-> Symbol (analysis.Operation Any)) + (function (_ lux) + (let [without_global (is (-> (property.List .Global) (property.List .Global)) + (property.lacks short)) + without_global (is (-> .Module .Module) + (revised .#definitions without_global)) + without_global (is (-> (property.List .Module) (property.List .Module)) + (property.revised module without_global)) + without_global (is (-> Lux Lux) + (revised .#modules without_global))] + {.#Right [(without_global lux) + []]}))) + +(def (global_reference name) + (-> Symbol (Meta .Global)) + (do meta.monad + [name (meta.normal name) + current_module_name meta.current_module_name + lux meta.compiler_state] + (loop (again [[normal_module normal_short] name]) + (when (is (Maybe .Global) + (do maybe.monad + [(open "/[0]") (|> lux + (the .#modules) + (property.value normal_module))] + (property.value normal_short /#definitions))) + {.#Some it} + (when it + {.#Definition [exported? type value]} + (if (or exported? + (text#= current_module_name normal_module)) + (in it) + (meta.failure (%.format "Global is not an export: " (%.symbol name)))) + + {.#Default [exported? type value]} + (if (or exported? + (text#= current_module_name normal_module)) + (in it) + (meta.failure (%.format "Global is not an export: " (%.symbol name)))) + + {.#Alias de_aliased} + (again de_aliased)) + + {.#None it} + (meta.failure (%.format "Unknown global: " (%.symbol name))))))) + +(def (with_cached_analysis name then) + (All (_ of) + (-> Symbol (-> [Code .Global] (analysis.Operation of)) + (analysis.Operation of))) + (do phase.monad + [g!cache (macro.symbol "g!cache") + global (global_reference name) + .let [cache_name (%.code g!cache)] + _ (module.define cache_name global) + it (then [g!cache global]) + current_module_name meta.current_module_name + _ (without_global [current_module_name cache_name])] + (in it))) + +(def (with_cached_analysis' name then) + (All (_ anchor expression declaration of) + (-> Symbol (-> [Code .Global] (declaration.Operation anchor expression declaration of)) + (declaration.Operation anchor expression declaration of))) + (do phase.monad + [g!cache (declaration.lifted_analysis + (macro.symbol "g!cache")) + global (declaration.lifted_analysis + (global_reference name)) + .let [cache_name (%.code g!cache)] + _ (declaration.lifted_analysis + (module.define cache_name global)) + it (then [g!cache global]) + current_module_name (declaration.lifted_analysis + meta.current_module_name) + _ (declaration.lifted_analysis + (without_global [current_module_name cache_name]))] + (in it))) + +(def (with_temporary_global [name new] then) + (All (_ of) + (-> [Symbol .Global] (analysis.Operation of) + (analysis.Operation of))) + (do phase.monad + [old (global_reference name) + _ (module.override_definition name new) + it then + _ (module.override_definition name old)] + (in it))) + +(def (with_temporary_global' [name new] then) + (All (_ anchor expression declaration of) + (-> [Symbol .Global] (declaration.Operation anchor expression declaration of) + (declaration.Operation anchor expression declaration of))) + (do phase.monad + [old (declaration.lifted_analysis + (global_reference name)) + _ (declaration.lifted_analysis + (module.override_definition name new)) + it then + _ (declaration.lifted_analysis + (module.override_definition name old))] + (in it))) + +(def (expression type term) + (-> Type analysis.Analysis Analysis) + (analysis (_ phase archive []) + (do phase.monad + [_ (type.inference type)] + (in term)))) + +(def (with_cached_expression [type term] then) + (All (_ of) + (-> [Type analysis.Analysis] + (-> (-> Code (analysis.Operation of)) + (analysis.Operation of)))) + (do phase.monad + [g!cache (macro.symbol "g!cache") + .let [cache_name (%.code g!cache)] + _ (module.define cache_name {.#Definition [false Analysis (expression type term)]}) + it (then g!cache) + current_module_name meta.current_module_name + _ (without_global [current_module_name cache_name])] + (in it))) + +(with_template [<name> <parameters> <term> <scenario> <advised>] + [(def (<name> original aspect) + (-> Code Aspect Analysis) + (analysis (_ phase archive <parameters>) + (do [! phase.monad] + [[type term] (type.inferring + (phase archive <term>)) + _ (type.inference type) + location meta.location + .let [join_point [#location location + #scenario {<scenario> [it type]}]]] + (when (list.one (function (_ [point_cut advice]) + (if (point_cut join_point) + {.#Some advice} + {.#None})) + aspect) + {.#Some advice} + (<| (with_cached_expression [type term]) + (function (_ analysis)) + (phase archive <advised>)) + + {.#None} + (in term)))))] + + [local [it ?code.local] + (` ((, original) (, (code.local it)))) + #Local + (` ((, (code.symbol advice)) ((, analysis))))] + [global [quoted_module ?code.any + it ?code.global] + (` ((, original) (, quoted_module) (, (code.symbol it)))) + #Global + (let [[advice_module _] advice] + (` (((, original) (, (code.text advice_module)) (, (code.symbol advice))) + ((, analysis)))))] + ) + +(def with|analysis + Analysis + (analysis (_ phase archive [aspect ?code.any + body ?code.any]) + (do [! phase.monad] + [aspect (meta.eval Aspect aspect) + .let [aspect (as Aspect aspect)]] + (list#mix (function (_ [original value] then) + (<| (with_cached_analysis original) + (function (_ [g!original original_global])) + (with_temporary_global [original {.#Definition [true Analysis (value g!original aspect)]}]) + then)) + (phase archive body) + (list [(symbol .local#) ..local] + [(symbol .global#) ..global]))))) + +(def with|declaration + Declaration + (declaration (_ phase archive [aspect ?code.any + body ?code.any]) + (do [! phase.monad] + [aspect (declaration.lifted_analysis + (meta.eval Aspect aspect)) + .let [aspect (as Aspect aspect)]] + (list#mix (function (_ [original value] then) + (<| (with_cached_analysis' original) + (function (_ [g!original original_global])) + (with_temporary_global' [original {.#Definition [true Analysis (value g!original aspect)]}]) + then)) + (phase archive body) + (list [(symbol .local#) ..local] + [(symbol .global#) ..global]))))) + +(def expression? + (Meta Bit) + (function (_ lux) + {.#Right [lux + (when (the .#expected lux) + {.#Some _} true + {.#None _} false)]})) + +(def .public with + (syntax (_ [aspect ?code.any + body ?code.any]) + (do meta.monad + [? ..expression? + .let [[@ _] (symbol .._) + <with> (if ? + (` ..with|analysis) + (` ..with|declaration))]] + (in (list (` ((.in_module# (, (code.text @)) (, <with>)) + (, aspect) + (, body)))))))) diff --git a/stdlib/source/library/lux/control/function/mixin.lux b/stdlib/source/library/lux/control/function/mixin.lux index 36610827b..57405979d 100644 --- a/stdlib/source/library/lux/control/function/mixin.lux +++ b/stdlib/source/library/lux/control/function/mixin.lux @@ -11,56 +11,71 @@ [function [predicate (.only Predicate)]]]]]) -(type .public (Mixin i o) - (-> (-> i o) (-> i o) (-> i o))) +(type .public (Mixin input output) + (-> (-> input output) (-> input output) + (-> input output))) (def .public (fixed f) - (All (_ i o) (-> (Mixin i o) (-> i o))) + (All (_ input output) + (-> (Mixin input output) + (-> input output))) (function (mix input) ((f mix mix) input))) (def .public nothing Mixin - (function (_ delegate recur) - delegate)) + (function (_ next again) + next)) (def .public (mixed parent child) - (All (_ i o) (-> (Mixin i o) (Mixin i o) (Mixin i o))) - (function (_ delegate recur) - (parent (child delegate recur) recur))) + (All (_ input output) + (-> (Mixin input output) (Mixin input output) + (Mixin input output))) + (function (_ next again) + (parent (child next again) again))) (def .public monoid - (All (_ i o) (Monoid (Mixin i o))) + (All (_ input output) + (Monoid (Mixin input output))) (implementation (def identity ..nothing) (def composite ..mixed))) (def .public (advice when then) - (All (_ i o) (-> (Predicate i) (Mixin i o) (Mixin i o))) - (function (_ delegate recur input) + (All (_ input output) + (-> (Predicate input) (Mixin input output) + (Mixin input output))) + (function (_ next again input) (if (when input) - ((then delegate recur) input) - (delegate input)))) + ((then next again) input) + (next input)))) -(def .public (before monad action) - (All (_ ! i o) (-> (Monad !) (-> i (! Any)) (Mixin i (! o)))) - (function (_ delegate recur input) - (do monad +(def .public (before ! action) + (All (_ ! input output) + (-> (Monad !) (-> input (! Any)) + (Mixin input (! output)))) + (function (_ next again input) + (do ! [_ (action input)] - (delegate input)))) + (next input)))) -(def .public (after monad action) - (All (_ ! i o) (-> (Monad !) (-> i o (! Any)) (Mixin i (! o)))) - (function (_ delegate recur input) - (do monad - [output (delegate input) +(def .public (after ! action) + (All (_ ! input output) + (-> (Monad !) (-> input output (! Any)) + (Mixin input (! output)))) + (function (_ next again input) + (do ! + [output (next input) _ (action input output)] (in output)))) -(type .public (Recursive i o) - (-> (-> i o) (-> i o))) +(type .public (Recursive input output) + (-> (-> input output) + (-> input output))) (def .public (of_recursive recursive) - (All (_ i o) (-> (Recursive i o) (Mixin i o))) - (function (_ delegate recur) - (recursive recur))) + (All (_ input output) + (-> (Recursive input output) + (Mixin input output))) + (function (_ next again) + (recursive again))) diff --git a/stdlib/source/library/lux/control/parser.lux b/stdlib/source/library/lux/control/parser.lux index 2330b8606..0d7fd1217 100644 --- a/stdlib/source/library/lux/control/parser.lux +++ b/stdlib/source/library/lux/control/parser.lux @@ -119,8 +119,8 @@ {try.#Failure _} (that tokens) - output - output))) + success + success))) (def .public (some parser) (All (_ s a) @@ -224,11 +224,11 @@ (All (_ s a) (-> a (Parser s a) (Parser s a))) (function (_ input) (when (parser input) - {try.#Success [input' output]} - {try.#Success [input' output]} - {try.#Failure error} - {try.#Success [input value]}))) + {try.#Success [input value]} + + success + success))) (def .public remaining (All (_ s) (Parser s s)) diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index f1dcddff0..131e88b0d 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -427,39 +427,6 @@ [configuration [.#info .#configuration] (List [Text Text])] ) -(def .public (local name) - (-> Symbol (Meta Global)) - (do ..monad - [name (..normal name) - current_module_name ..current_module_name - lux ..compiler_state] - (loop (again [[normal_module normal_short] name]) - (when (is (Maybe Global) - (do maybe.monad - [(open "/[0]") (|> lux - (the .#modules) - (property.value normal_module))] - (property.value normal_short /#definitions))) - {.#Some it} - (when it - {.#Definition [exported? type value]} - (if (or exported? - (text#= current_module_name normal_module)) - (in it) - (failure (all text#composite "Global is not an export: " (symbol#encoded name)))) - - {.#Default [exported? type value]} - (if (or exported? - (text#= current_module_name normal_module)) - (in it) - (failure (all text#composite "Global is not an export: " (symbol#encoded name)))) - - {.#Alias de_aliased} - (again de_aliased)) - - {.#None it} - (failure (all text#composite "Unknown global: " (symbol#encoded name))))))) - (def .public (definition_type name) (-> Symbol (Meta Type)) (do ..monad diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux index 0145f2162..cc976b37e 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux @@ -42,7 +42,9 @@ ["[0]" version (.only Version)] ["[0]" phase] ["[0]" reference (.only Reference) - ["[0]" variable (.only Register Variable)]]]]]) + ["[0]" variable (.only Register Variable)]] + [meta + [archive (.only Archive)]]]]]) (type .public (Branch' e) (Record @@ -390,3 +392,13 @@ .#extensions [] .#eval (as (-> Type Code (Meta Any)) []) .#host []]) + +(def .public (delegated extender analysis archive extension parameters) + (-> Extender Phase Archive Symbol (List Code) (Operation Analysis)) + (do phase.monad + [lux phase.state] + (extension.application extender + lux analysis archive + .Analysis false extension parameters + (|>>) + (function (_ _) {.#None})))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux index 4c50af1f4..2714a2a98 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux @@ -107,7 +107,7 @@ [lux meta.compiler_state] (extension.application extender lux analysis archive - .Analysis def_name argsC+ + .Analysis true def_name argsC+ (|>>) (function (_ _) {.#None})))) (/function.apply analysis argsC+ function_type function_analysis archive functionC))) @@ -135,7 +135,7 @@ [lux meta.compiler_state] (extension.application extender lux analysis archive - .Analysis global argsC+ + .Analysis false global argsC+ (|>>) (function (_ _) {.#Some (term_application extender expander analysis archive functionC argsC+)}))) @@ -162,7 +162,7 @@ [.#Rev /simple.rev]) [[quoted_module @line @row] {.#Symbol value}] - (/reference.reference quoted_module value) + (/reference.reference extender analysis archive quoted_module value) (^.` [(^.,* elems)]) (/complex.record analysis archive elems) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux index d9c88a463..733295658 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux @@ -3,97 +3,31 @@ [lux (.except Analysis) [abstract [monad (.only do)]] - [control - ["[0]" exception (.only Exception)]] - [data - ["[0]" text (.use "[1]#[0]" equivalence) - ["%" \\format (.only format)]]] ["[0]" meta (.only) - [macro - ["^" pattern]]]]] - ["[0]" // - ["/[1]" // - [// - ["/" analysis (.only Analysis Operation) - ["[1][0]" type] - ["[1][0]" scope]] - [/// - ["[1][0]" reference] - ["[1]" phase]]]]]) - -(exception.def .public (foreign_module_has_not_been_imported [current foreign quoted definition]) - (Exception [Text Text Text Symbol]) - (exception.report - (list ["Current" current] - ["Foreign" foreign] - ["Quoted" quoted] - ["Definition" (%.symbol definition)]))) - -(exception.def .public (definition_has_not_been_exported definition) - (Exception Symbol) - (exception.report - (list ["Definition" (%.symbol definition)]))) - -(exception.def .public (defaults_are_not_definitions global) - (Exception Symbol) - (exception.report - (list ["Default" (%.symbol global)]))) - -(def (definition quoted_module def_name) - (-> Text Symbol (Operation Analysis)) - (with_expansions [<return> (in (|> def_name ///reference.constant {/.#Reference}))] - (do [! ///.monad] - [constant (meta.definition def_name)] - (when constant - {.#Alias real_def_name} - (definition quoted_module real_def_name) - - {.#Definition [exported? actualT _]} - (do ! - [_ (/type.inference actualT) - (^.let def_name [::module ::name]) (meta.normal def_name) - current meta.current_module_name] - (if (text#= current ::module) - <return> - (if exported? - (do ! - [imported! (meta.imported_by? ::module current)] - (if (or imported! - (text#= quoted_module ::module)) - <return> - (/.except ..foreign_module_has_not_been_imported [current ::module quoted_module def_name]))) - (/.except ..definition_has_not_been_exported [def_name])))) - - {.#Default _} - (/.except ..defaults_are_not_definitions [def_name]))))) - -(def (variable var_name) - (-> Text (Operation (Maybe Analysis))) - (do [! ///.monad] - [?var (/scope.variable var_name)] - (when ?var - {.#Some [actualT ref]} - (do ! - [_ (/type.inference actualT)] - (in {.#Some (|> ref ///reference.variable {/.#Reference})})) - - {.#None} - (in {.#None})))) - -(def .public (reference quoted_module it) - (-> Text Symbol (Operation Analysis)) + ["[0]" code]]]] + ["[0]" /// + [// + ["/" analysis (.only Analysis Operation Phase Extender) + ["[0]" scope]] + [/// + ["[0]" phase] + [meta + [archive (.only Archive)]]]]]) + +(def .public (reference extender analysis archive quoted_module it) + (-> Extender Phase Archive Text Symbol (Operation Analysis)) (when it ["" short] - (do [! ///.monad] - [?var (variable short)] + (do [! phase.monad] + [?var (scope.variable short)] (when ?var - {.#Some varA} - (in varA) + {.#Some _} + (/.delegated extender analysis archive (symbol .local#) (list (code.symbol it))) {.#None} (do ! [this_module meta.current_module_name] - (definition quoted_module [this_module short])))) + (/.delegated extender analysis archive (symbol .global#) (list (code.text quoted_module) (code.symbol [this_module short])))))) _ - (definition quoted_module it))) + (/.delegated extender analysis archive (symbol .global#) (list (code.text quoted_module) (code.symbol it))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux index dfadd0040..18e067716 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux @@ -63,10 +63,10 @@ (def (macro_or_extension analysis archive whole_term function_term) (All (_ anchor expression declaration) - (-> analysis.Phase Archive Code Code (Operation anchor expression declaration Symbol))) + (-> analysis.Phase Archive Code Code (Operation anchor expression declaration [Bit Symbol]))) (when function_term [_ {.#Symbol it}] - (phase#in it) + (phase#in [false it]) function_term (do phase.monad @@ -77,7 +77,7 @@ (analysis.constant definition) (if (or (check.subsumes? .Macro type) (check.subsumes? .Declaration type)) - (in definition) + (in [true definition]) (phase.except ..not_a_declaration [whole_term])) _ @@ -102,10 +102,10 @@ (when code [_ {.#Form (list.partial term inputs)}] (do ! - [macro|extension (macro_or_extension analysis archive code term) + [[validated? macro|extension] (macro_or_extension analysis archive code term) expansion|requirements (extension.application extender (the [/.#analysis /.#state] state) again archive - .Declaration macro|extension inputs + .Declaration validated? macro|extension inputs (|>> {#Done}) (function (_ _) {.#Some (do ! diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux index 7de2dbea9..c0ad23cb1 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux @@ -1,19 +1,21 @@ (.require [library - [lux (.except) + [lux (.except global) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)] [monad (.only do)]] [control + ["[0]" maybe] ["[0]" try] ["[0]" exception (.only Exception)]] [data ["[0]" product] - ["[0]" text (.only) + ["[0]" text (.use "[1]#[0]" equivalence) ["%" \\format (.only Format)]] [collection - ["[0]" list] + ["[0]" list (.only) + ["[0]" property]] ["[0]" dictionary (.only Dictionary)]]] ["[0]" meta (.only) ["[0]" symbol] @@ -74,10 +76,45 @@ {#Normal Any} {#Special Any})) -(def (global_value name) - (-> Symbol (Meta [Type Value])) +(def (global validated_global? name) + (-> Bit Symbol (Meta Global)) (do meta.monad - [global (meta.local name)] + [name (meta.normal name) + current_module_name meta.current_module_name + lux meta.compiler_state] + (loop (again [[normal_module normal_short] name]) + (when (is (Maybe Global) + (do maybe.monad + [(open "/[0]") (|> lux + (the .#modules) + (property.value normal_module))] + (property.value normal_short /#definitions))) + {.#Some it} + (when it + {.#Definition [exported? type value]} + (if (or validated_global? + exported? + (text#= current_module_name normal_module)) + (in it) + (meta.failure (%.format "Global is not an export: " (%.symbol name)))) + + {.#Default [exported? type value]} + (if (or validated_global? + exported? + (text#= current_module_name normal_module)) + (in it) + (meta.failure (%.format "Global is not an export: " (%.symbol name)))) + + {.#Alias de_aliased} + (again de_aliased)) + + {.#None it} + (meta.failure (%.format "Unknown global: " (%.symbol name))))))) + +(def (global_value validated_global? name) + (-> Bit Symbol (Meta [Type Value])) + (do meta.monad + [global (..global validated_global? name)] (when global {.#Definition [exported? type value]} (in [type {#Normal value}]) @@ -88,28 +125,28 @@ {.#Alias _} (undefined)))) -(def (global_extension expected_type name) - (-> Type Symbol (Meta Value)) +(def (global_extension expected_type validated_global? name) + (-> Type Bit Symbol (Meta Value)) (do meta.monad - [[actual_type value] (global_value name)] + [[actual_type value] (global_value validated_global? name)] (if (check.subsumes? expected_type actual_type) (in value) (meta.failure (exception.error ..invalid [name expected_type actual_type]))))) (def .public (application extender lux phase archive - expected_type global parameters + expected_type validated_global? global parameters when_valid when_invalid) (All (_ state input raw_output processed_output) (-> (Extender state input raw_output) Lux (Phase state input raw_output) Archive - Type Symbol (List input) + Type Bit Symbol (List input) (-> raw_output processed_output) (-> Text (Maybe (Operation state processed_output))) (Operation state processed_output))) (when (|> (do [! meta.monad] - [value (global_extension expected_type global)] + [value (global_extension expected_type validated_global? global)] (in ((when value {#Normal definition} (extender definition) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux index 501ca50ad..114928b77 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Analysis) + [lux (.except Analysis global local) [abstract ["[0]" monad (.only do)]] [control @@ -9,7 +9,7 @@ ["[0]" try] ["[0]" exception (.only Exception)]] [data - ["[0]" text (.only) + ["[0]" text (.use "[1]#[0]" equivalence) [char (.only Char)] ["%" \\format (.only format)]] [collection @@ -30,11 +30,13 @@ [// ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) [evaluation (.only Eval)] - ["[0]A" type]] + ["[0]A" type] + ["[0]" scope]] ["[0]" synthesis] ["[0]" generation] ["[0]" declaration] [/// + ["[0]" reference] ["[0]" phase] [meta [archive (.only Archive)]]]]]]) @@ -206,13 +208,85 @@ (<| (typeA.expecting input) (phase archive valueC))))])) +(exception.def .public (foreign_module_has_not_been_imported [current foreign quoted global]) + (Exception [Text Text Text Symbol]) + (exception.report + (list ["Current" current] + ["Foreign" foreign] + ["Quoted" quoted] + ["Global" (%.symbol global)]))) + +(exception.def .public (global_has_not_been_exported global) + (Exception Symbol) + (exception.report + (list ["Global" (%.symbol global)]))) + +(exception.def .public (defaults_cannot_be_referenced global) + (Exception Symbol) + (exception.report + (list ["Default" (%.symbol global)]))) + +(def global + (-> Text Handler) + (..custom + [(<>.and <code>.text <code>.global) + (function (again extension_name phase archive [quoted_module def_name]) + (with_expansions [<return> (in (|> def_name reference.constant {analysis.#Reference}))] + (do [! phase.monad] + [constant (meta.definition def_name)] + (when constant + {.#Alias real_def_name} + (again extension_name phase archive [quoted_module real_def_name]) + + {.#Definition [exported? actualT _]} + (do ! + [_ (typeA.inference actualT) + (^.let def_name [::module ::name]) (meta.normal def_name) + current meta.current_module_name] + (if (text#= current ::module) + <return> + (if exported? + (do ! + [imported! (meta.imported_by? ::module current)] + (if (or imported! + (text#= quoted_module ::module)) + <return> + (analysis.except ..foreign_module_has_not_been_imported [current ::module quoted_module def_name]))) + (analysis.except ..global_has_not_been_exported [def_name])))) + + {.#Default _} + (analysis.except ..defaults_cannot_be_referenced [def_name])))))])) + +(exception.def .public (unknown_local name) + (Exception Text) + (exception.report + (list ["Name" (%.text name)]))) + +(def local + (-> Text Handler) + (..custom + [<code>.local + (function (_ extension_name phase archive [it]) + (do [! phase.monad] + [?var (scope.variable it)] + (when ?var + {.#Some [local_type local_reference]} + (do ! + [_ (typeA.inference local_type)] + (in (|> local_reference reference.variable {analysis.#Reference}))) + + {.#None} + (analysis.except ..unknown_local [it]))))])) + (def with_basic_extensions (-> Bundle Bundle) (|>> (install "is_type#" (..caster .Type .Type)) (install "is?#" lux::is?) (install "try#" lux::try) (install "in_module#" lux::in_module) - (install "when_char#" lux::syntax_char_case!))) + (install "when_char#" lux::syntax_char_case!) + (install "local#" ..local) + (install "global#" ..global))) (def with_io_extensions (-> Bundle Bundle) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux index d8c4eb180..c293cb44c 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux @@ -93,7 +93,7 @@ (/function.apply phase archive application) {synthesis.#Extension [name parameters]} - (extension.application extender lux phase archive .Generation name parameters + (extension.application extender lux phase archive .Generation false name parameters (|>>) (function (_ _) {.#None})) ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux index 9e632c9a1..83605d36c 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux @@ -94,7 +94,7 @@ (/function.abstraction phase environmentA archive bodyA) {///analysis.#Extension name parameters} - (extension.application extender lux phase archive .Synthesis name parameters + (extension.application extender lux phase archive .Synthesis false name parameters (|>>) (function (_ _) {.#Some (|> parameters diff --git a/stdlib/source/library/lux/world/net/http/query.lux b/stdlib/source/library/lux/world/net/http/query.lux deleted file mode 100644 index 2541a9c6d..000000000 --- a/stdlib/source/library/lux/world/net/http/query.lux +++ /dev/null @@ -1,65 +0,0 @@ -(.require - [library - [lux (.except) - [control - pipe - [monad (.only do)] - ["[0]" try (.only Try)] - ["p" parser - ["l" text (.only Parser)]]] - [data - [number - ["[0]" nat]] - ["[0]" text - ["%" \\format (.only format)]] - [format - ["[0]" context (.only Context)]] - [collection - ["[0]" dictionary]]]]]) - -(def component - (Parser Text) - (p.rec - (function (_ component) - (do [! p.monad] - [head (l.some (l.none_of "+%&;"))] - (all p.either - (p.after (p.either l.end - (l.this "&")) - (in head)) - (do ! - [_ (l.this "+") - tail component] - (in (format head " " tail))) - (do ! - [_ (l.this "%") - code (|> (l.exactly 2 l.hexadecimal) - (p.codec nat.hex) - (at ! each text.from_code)) - tail component] - (in (format head code tail)))))))) - -(def (form context) - (-> Context (Parser Context)) - (all p.either - (do p.monad - [_ l.end] - (in context)) - (do [! p.monad] - [key (l.some (l.none_of "=&;")) - key (l.local key ..component)] - (p.either (do ! - [_ (l.this "=") - value ..component] - (form (dictionary.has key value context))) - (do ! - [_ (all p.or - (l.one_of "&;") - l.end)] - (form (dictionary.has key "" context))))) - ... if invalid form data, just stop parsing... - (at p.monad in context))) - -(def .public (parameters raw) - (-> Text (Try Context)) - (l.result raw (..form context.empty))) diff --git a/stdlib/source/library/lux/world/net/uri/query.lux b/stdlib/source/library/lux/world/net/uri/query.lux new file mode 100644 index 000000000..24b03512b --- /dev/null +++ b/stdlib/source/library/lux/world/net/uri/query.lux @@ -0,0 +1,106 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + [codec (.only Codec)] + [equivalence (.only Equivalence)]] + [control + ["?" parser] + ["[0]" try (.only Try)]] + [data + ["[0]" text (.only) + ["%" \\format] + ["?[1]" \\parser (.only Parser)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["[0]" nat]]] + [world + [net + ["[0]" uri + ["[1]" encoding]]]]]]) + +(type .public Query + (Dictionary Text Text)) + +(def .public empty + Query + (dictionary.empty text.hash)) + +(def .public equivalence + (Equivalence Query) + (dictionary.equivalence text.equivalence)) + +(def component + (Parser Text) + (?.rec + (function (_ component) + (do [! ?.monad] + [head (?text.some (?text.none_of "+%&;"))] + (all ?.either + (?.after (?.either ?text.end + (?text.this "&")) + (in head)) + (do ! + [_ (?text.this "+") + tail component] + (in (%.format head " " tail))) + (do ! + [_ (?text.this "%") + code (|> (?text.exactly 2 ?text.hexadecimal) + (?.codec nat.hex) + (at ! each text.of_char)) + tail component] + (in (%.format head code tail)))))))) + +(def separators + "&;") + +(def assignment + "=") + +(def invalid + (%.format "=" "&;")) + +(def (form query) + (-> Query (Parser Query)) + (all ?.either + (do ?.monad + [_ ?text.end] + (in query)) + (do [! ?.monad] + [key (?text.some (?text.none_of ..invalid)) + key (?text.local key ..component) + key (?.lifted (uri.decoded key))] + (?.either (do ! + [_ (?text.this ..assignment) + value ..component + value (?.lifted (uri.decoded value))] + (form (dictionary.has key value query))) + (do ! + [_ (all ?.or + (?text.one_of ..separators) + ?text.end)] + (form (dictionary.has key "" query))))) + ... if invalid form data, just stop parsing... + (at ?.monad in query))) + +(def format + (%.Format Query) + (|>> dictionary.entries + (list#each (function (_ [key value]) + (%.format (uri.encoded key) "=" (uri.encoded value)))) + (text.interposed "&"))) + +(def query + (-> Text (Try Query)) + (?text.result (..form ..empty))) + +(def .public codec + (Codec Text Query) + (implementation + (def encoded ..format) + (def decoded ..query))) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 5a57ac13d..67903a051 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -4,6 +4,7 @@ [test ["_" property (.only Test)]]]] ["[0]" / + ["[1][0]" aspect] ["[1][0]" concatenative] ["[1][0]" concurrency ["[1]/[0]" actor] @@ -66,6 +67,7 @@ (def .public test Test (all _.and + /aspect.test /concatenative.test ..concurrency /continuation.test diff --git a/stdlib/source/test/lux/control/aspect.lux b/stdlib/source/test/lux/control/aspect.lux new file mode 100644 index 000000000..a98d83918 --- /dev/null +++ b/stdlib/source/test/lux/control/aspect.lux @@ -0,0 +1,139 @@ +(.require + [library + [lux (.except global) + [abstract + [monad (.only do)]] + [control + [function + ["?" predicate]]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format]]] + [math + ["[0]" random (.only Random)] + [number + ["n" nat]]] + [meta + ["[0]" symbol (.use "[1]#[0]" equivalence)] + ["[0]" static] + ["[0]" code]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def (double it) + (/.After Nat) + (n.+ it it)) + +(def can_double + (Random Nat) + (random.only (function (_ it) + (not (n.= it (double it)))) + random.nat)) + +(def global + Nat + (static.random code.nat ..can_double)) + +(def (triple it) + (-> Nat Nat) + (all n.+ it it it)) + +(def pre_double + (/.Around Nat Nat) + (/.before ..double)) + +(def after_aspect + /.Aspect + (list [(all ?.or + (/.when_global (|>> (the /.#name) + (symbol#= (symbol ..global)))) + (/.when_local ?.all)) + (symbol ..double)])) + +(def before_aspect + /.Aspect + (list [(/.when_global (|>> (the /.#name) + (symbol#= (symbol ..triple)))) + (symbol ..pre_double)])) + +(def this_module + Text + (let [[module _] (symbol .._)] + module)) + +(def another_module + Text + (let [[module _] (symbol /._)] + module)) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + [local ..can_double]) + (_.for [/.Aspect]) + (all _.and + (_.for [/.with] + (all _.and + (_.for [/.Advice /.After] + (_.for [/.Reference /.#name /.#type + /.Scenario /.#Global /.#Local] + (all _.and + (_.coverage [/.Local] + (n.= (double local) + (/.with ..after_aspect + local))) + (_.coverage [/.Global] + (n.= (double ..global) + (/.with ..after_aspect + ..global)))))) + (_.coverage [/.Around /.before] + (n.= (triple (double local)) + (/.with ..before_aspect + (triple local)))) + )) + (_.for [/.Join_Point /.#location /.#scenario + /.Point_Cut] + (all _.and + (_.coverage [/.when_local] + (and (n.= (triple (double local)) + (/.with (list [(/.when_local ?.all) + (symbol ..double)]) + (triple local))) + (n.= (triple local) + (/.with (list [(/.when_local ?.none) + (symbol ..double)]) + (triple local))))) + (_.coverage [/.when_global] + (and (n.= (triple (double local)) + (/.with (list [(/.when_global ?.all) + (symbol ..pre_double)]) + (triple local))) + (n.= (triple local) + (/.with (list [(/.when_global ?.none) + (symbol ..pre_double)]) + (triple local))))) + (_.coverage [/.when_module] + (and (n.= (triple (double local)) + (/.with (list [(?.and (/.when_module (text#= this_module)) + (/.when_local ?.all)) + (symbol ..double)]) + (triple local))) + (n.= (triple local) + (/.with (list [(?.and (/.when_module (text#= another_module)) + (/.when_local ?.all)) + (symbol ..double)]) + (triple local))))) + (_.coverage [/.typed?] + (and (n.= (triple (double local)) + (/.with (list [(/.typed? Nat) + (symbol ..double)]) + (triple local))) + (n.= ((pre_double triple) local) + (/.with (list [(/.typed? (-> Nat Nat)) + (symbol ..pre_double)]) + (triple local))))) + )) + ))) diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux index 691f4d357..caabbe222 100644 --- a/stdlib/source/test/lux/data/format/json.lux +++ b/stdlib/source/test/lux/data/format/json.lux @@ -357,7 +357,7 @@ (do random.monad [sample ..random] - (_.coverage [/.Null /.null?] + (_.coverage [/.Null /.#Null /.null?] (at bit.equivalence = (/.null? sample) (when sample @@ -422,7 +422,7 @@ [(do random.monad [key (random.alphabetic 1) value <random>] - (_.coverage [<type> <field>] + (_.coverage [<type> <tag> <field>] (|> (/.object (list [key {<tag> value}])) (<field> key) (try#each (at <equivalence> = value)) diff --git a/stdlib/source/test/lux/world/net.lux b/stdlib/source/test/lux/world/net.lux index 9856b8a00..b2c286fc0 100644 --- a/stdlib/source/test/lux/world/net.lux +++ b/stdlib/source/test/lux/world/net.lux @@ -20,7 +20,8 @@ ["[1][0]" uri ["[1]/[0]" encoding] ["[1]/[0]" scheme] - ["[1]/[0]" path]]]) + ["[1]/[0]" path] + ["[1]/[0]" query]]]) (def .public test Test @@ -48,4 +49,5 @@ /uri/encoding.test /uri/scheme.test /uri/path.test + /uri/query.test ))) diff --git a/stdlib/source/test/lux/world/net/uri/query.lux b/stdlib/source/test/lux/world/net/uri/query.lux new file mode 100644 index 000000000..ecdd3c2c4 --- /dev/null +++ b/stdlib/source/test/lux/world/net/uri/query.lux @@ -0,0 +1,43 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)] + [\\specification + ["[0]S" equivalence] + ["[0]S" codec]]] + [data + [collection + ["[0]" dictionary]]] + [math + ["[0]" random (.only Random) (.use "[1]#[0]" monad)]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def .public (random size) + (-> Nat (Random /.Query)) + (when size + 0 (random#in /.empty) + _ (do random.monad + [key (random.alphabetic size) + value (random.unicode size) + query (random (-- size))] + (in (dictionary.has key value query))))) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + []) + (_.for [/.Query]) + (all _.and + (_.for [/.equivalence] + (equivalenceS.spec /.equivalence (..random 2))) + (_.for [/.codec] + (codecS.spec /.equivalence /.codec (..random 3))) + + (_.coverage [/.empty] + (dictionary.empty? /.empty)) + ))) |