From b135e487e8f705a5fea7b9ef785310572642063a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 30 Aug 2022 13:33:55 -0400 Subject: Added support for predicate-based polymorphism. --- .../control/function/polymorphism/predicate.lux | 130 +++++++++++++++ .../lux/control/function/polymorphism/type.lux | 7 +- stdlib/source/library/lux/meta/macro/context.lux | 183 ++++++++++++++++----- stdlib/source/library/lux/test/coverage.lux | 2 +- 4 files changed, 274 insertions(+), 48 deletions(-) create mode 100644 stdlib/source/library/lux/control/function/polymorphism/predicate.lux (limited to 'stdlib/source/library') diff --git a/stdlib/source/library/lux/control/function/polymorphism/predicate.lux b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux new file mode 100644 index 000000000..4ae4ca483 --- /dev/null +++ b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux @@ -0,0 +1,130 @@ +... https://en.wikipedia.org/wiki/Predicate_dispatch +(.require + [library + [lux (.except def) + [abstract + [monad (.only do)]] + [control + ["?" parser (.use "[1]#[0]" monad)]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence)] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + ["[0]" meta (.only) + ["[0]" static] + ["[0]" code (.only) + ["?[1]" \\parser (.only Parser)]] + ["[0]" macro (.only with_symbols) + ["[0]" context] + [syntax (.only syntax) + ["[0]" export]]]]]] + [/// + ["//" mixin]]) + +(type Polymorphism + (Record + [#function Text + #quantifications (List Code) + #inputs (List Code) + #output Code + #default Code + #export_policy Code + #scenarios (List Code)])) + +(context.def [stack expression declaration] Polymorphism) + +(type Signature + (Record + [#name Text + #next Text + #parameters (List Code)])) + +(.def signature + (Parser Signature) + (?code.form + (all ?.and + ?code.local + ?code.local + (?.many ?code.any)))) + +(.def (quoted it) + (-> Code Code) + (` ((,' .,') (, it)))) + +(.def .public def + (syntax (_ [[export_policy signature quantifications inputs output default methods] + (export.parser + (all ?.and + ..signature + (?code.tuple (?.some ?code.any)) + (?code.tuple (?.many ?code.any)) + ?code.any + ?code.any + (?.some ?code.any)))]) + (<| (with_symbols [g!self g!_ g!scenarios g!scenario g!mixin]) + (..declaration [#function (the #name signature) + #quantifications quantifications + #inputs inputs + #output output + #default default + #export_policy export_policy + #scenarios (list)]) + (let [name (quoted (code.local (the #name signature))) + next (quoted (code.local (the #next signature))) + parameters (list#each quoted (the #parameters signature)) + [@ _] (symbol .._) + + g!self (quoted g!self)]) + (` (these (,* methods) + + (static.expansion + (do meta.monad + [[(, g!_) (, g!_) (, g!_) (, g!_) (, g!_) (, g!_) (, g!scenarios)] + (context.search' (|>> product.left + (at text.equivalence (,' =) (, (code.text (the #name signature))))) + [("lux in-module" (, (code.text @)) ..stack) + (symbol ..stack)])] + (at meta.monad (,' in) + (list (` (.def (, export_policy) (, name) + (, (quoted (` (<| (,* quantifications) + (-> (,* inputs) (, output)))))) + (let [(, (quoted g!mixin)) (is (, (quoted (` (<| (,* quantifications) + (-> [(,* inputs)] (, output)))))) + (//.fixed (all //.mixed + ((,' .,*) (, g!scenarios)) + (is (, (quoted (` (<| (,* quantifications) + (//.Mixin [(,* inputs)] (, output)))))) + (function ((, g!self) (, next) (, name) [(,* parameters)]) + (, (quoted default)))) + )))] + (function ((, name) (,* parameters)) + ((, (quoted g!mixin)) [(,* parameters)]))))))))) + ))))) + +(.def .public method + (syntax (_ [[signature predicate body] + (all ?.and + ..signature + ?code.any + ?code.any)]) + (do [! meta.monad] + [.let [criterion (is (-> Polymorphism Bit) + (|>> (the #function) + (text#= (the #name signature))))] + it (context.search criterion ..stack)] + (with_symbols [g!self] + (do ! + [_ (context.revised {.#Some criterion} + (revised #scenarios (|>> {.#Item (` (//.advice (function ((, g!self) [(,* (the #parameters signature))]) + (, predicate)) + (, g!self)))})) + ..stack)] + (in (list (` (.def (, (the #export_policy it)) (, g!self) + (<| (,* (the #quantifications it)) + (//.Mixin [(,* (the #inputs it))] (, (the #output it)))) + (function ((, g!self) + (, (code.local (the #next signature))) + (, (code.local (the #name signature))) + [(,* (the #parameters signature))]) + (, body))))))))))) diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux index ffa657330..ed17649db 100644 --- a/stdlib/source/library/lux/control/function/polymorphism/type.lux +++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux @@ -6,8 +6,7 @@ [control ["?" parser (.use "[1]#[0]" monad)]] [data - ["[0]" text (.use "[1]#[0]" equivalence) - ["%" \\format]] + ["[0]" text (.use "[1]#[0]" equivalence)] [collection ["[0]" list (.use "[1]#[0]" functor)]]] ["[0]" meta (.only) @@ -39,8 +38,8 @@ (?.many ?code.any)))]) (<| (do meta.monad [@ meta.current_module_name - g!interface (macro.symbol (%.symbol [@ name])) - g!method (macro.symbol (%.symbol [@ name]))]) + g!interface (macro.symbol name) + g!method (macro.symbol name)]) (with_symbols [g!_ g!inputs]) (..declaration [#name name #export_policy export_policy #interface g!interface #method g!method]) (let [name (code.local name) diff --git a/stdlib/source/library/lux/meta/macro/context.lux b/stdlib/source/library/lux/meta/macro/context.lux index 9db9ef978..55faa9ef0 100644 --- a/stdlib/source/library/lux/meta/macro/context.lux +++ b/stdlib/source/library/lux/meta/macro/context.lux @@ -1,10 +1,11 @@ (.require [library - [lux (.except def global) + [lux (.except def global revised) [abstract [monad (.only do)]] [control ["?" parser] + ["[0]" try (.only Try) (.use "[1]#[0]" functor)] ["[0]" exception (.only Exception)] ["[0]" maybe] [function @@ -15,19 +16,32 @@ ["[0]" list (.only) ["[0]" property]]]] ["[0]" meta (.only) + [type (.only sharing by_example)] ["[0]" symbol (.use "[1]#[0]" codec)] ["[0]" code (.only) ["?[1]" \\parser]]]]] ["[0]" // (.only) - [syntax (.only syntax)]]) + [syntax (.only syntax) + ["[0]" export]]]) (type .public Stack List) -(exception.def (no_definition it) - (Exception Symbol) - (exception.report - (list ["Definition" (symbol#encoded it)]))) +(.def Stack' + (template (_ value) + [[(Stack value) Symbol]])) + +(with_template [ ] + [(exception.def .public ( it) + (Exception ) + (exception.report + (list ["Definition" ( it)])))] + + [not_a_definition Symbol symbol#encoded] + [not_a_global Symbol symbol#encoded] + [not_a_module Text text.format] + [no_example Symbol symbol#encoded] + ) (.def (global it) (-> Symbol (Meta Any)) @@ -43,12 +57,12 @@ (in it) {.#None} - (meta.failure (exception.error ..no_definition [it]))))) + (meta.failure (exception.error ..not_a_definition [it]))))) (exception.def .public no_active_context) -(.def .public (peek' _ context) - (All (_ a) (-> (Stack a) Symbol (Meta a))) +(.def .public (peek' [_ context]) + (All (_ a) (-> (Stack' a) (Meta a))) (do meta.monad [stack (..global context)] (when (|> stack @@ -62,12 +76,10 @@ (.def .public peek (syntax (_ [g!it (at ?.monad each code.symbol ?code.global)]) - (in (list (` (..peek' (, g!it) (.symbol (, g!it)))))))) - -(exception.def .public no_example) + (in (list (` (..peek' [(, g!it) (.symbol (, g!it))])))))) -(.def .public (search' ? _ context) - (All (_ a) (-> (Predicate a) (Stack a) Symbol (Meta a))) +(.def .public (search' ? [_ context]) + (All (_ a) (-> (Predicate a) (Stack' a) (Meta a))) (do meta.monad [stack (..global context)] (when (|> stack @@ -77,84 +89,169 @@ (in (as_expected it)) {.#None} - (meta.failure (exception.error ..no_example []))))) + (meta.failure (exception.error ..no_example [context]))))) (.def .public search (syntax (_ [g!? ?code.any g!context (at ?.monad each code.symbol ?code.global)]) - (in (list (` (..search' (, g!?) (, g!context) (.symbol (, g!context)))))))) + (in (list (` (..search' (, g!?) [(, g!context) (.symbol (, g!context))])))))) -(.def (alter on_definition [@ context]) - (-> (-> Definition Definition) Symbol (Meta Any)) +(.def (alter on_definition [_ definition]) + (All (_ value) + (-> (-> Symbol Definition (Try Definition)) (Stack' value) + (Meta Any))) (function (_ lux) - (let [on_global (is (-> Global Global) + (let [[@ context] definition + on_global (is (-> Global (Try Global)) (function (_ it) (when it {.#Definition it} - {.#Definition (on_definition it)} + (try#each (|>> {.#Definition}) (on_definition definition it)) _ - it))) - on_globals (is (-> (property.List Global) (property.List Global)) - (property.revised context on_global)) - on_module (is (-> Module Module) - (revised .#definitions on_globals))] - {.#Right [(revised .#modules (property.revised @ on_module) lux) - []]}))) - -(.def .public (push' top _) - (All (_ a) (-> a (Stack a) Symbol (Meta Any))) - (alter (function (_ [exported? type stack]) + (exception.except ..not_a_definition [definition])))) + on_globals (is (-> (property.List Global) (Try (property.List Global))) + (function (_ globals) + (when (property.value context globals) + {.#Some global} + (try#each (function (_ global) + (property.has context global globals)) + (on_global global)) + + {.#None} + (exception.except ..not_a_global [definition])))) + on_module (is (-> Module (Try Module)) + (function (_ module) + (try#each (function (_ globals) + (has .#definitions globals module)) + (on_globals (the .#definitions module))))) + on_lux (is (-> Lux (Try Lux)) + (function (_ lux) + (when (property.value @ (the .#modules lux)) + {.#Some module} + (try#each (function (_ module) + (.revised .#modules (property.has @ module) lux)) + (on_module module)) + + {.#None} + (exception.except ..not_a_module [@]))))] + (when (on_lux lux) + {try.#Success it} + {try.#Success [it []]} + + {try.#Failure error} + ((meta.failure error) lux))))) + +(.def .public (push' top) + (All (_ value) + (-> value (Stack' value) + (Meta Any))) + (alter (function (_ _ [exported? type stack]) (|> stack (as (Stack Any)) {.#Item top} (is (Stack Any)) - [exported? type])))) + [exported? type] + {try.#Success})))) (.def .public push (syntax (_ [g!it ?code.any g!context (at ?.monad each code.symbol ?code.global)]) - (in (list (` (..push' (, g!it) (, g!context) (.symbol (, g!context)))))))) + (in (list (` (..push' (, g!it) [(, g!context) (.symbol (, g!context))])))))) + +(.def .public (revised' ? !) + (All (_ value) + (-> (Maybe (Predicate value)) (-> value value) (Stack' value) + (Meta Any))) + (alter (function (_ @ [exported? type stack]) + (let [stack (sharing [value] + (is (-> value value) + !) + (is (Stack value) + (as_expected stack)))] + (when ? + {.#Some ?} + (do try.monad + [stack (loop (again [stack stack]) + (when stack + (list.partial top stack') + (if (? top) + (in (list.partial (! top) stack')) + (do try.monad + [stack' (again stack')] + (in (list.partial top stack')))) + + _ + (exception.except ..no_example [@])))] + (in [exported? type stack])) + + {.#None} + (when stack + (list.partial top stack') + (|> stack' + (list.partial (! top)) + (is (Stack Any)) + [exported? type] + {try.#Success}) + + _ + (exception.except ..no_example [@]))))))) + +(.def .public revised + (syntax (_ [g!predicate ?code.any + g!revision ?code.any + g!context (at ?.monad each code.symbol ?code.global)]) + (in (list (` (..revised' (, g!predicate) + (, g!revision) + [(, g!context) (.symbol (, g!context))])))))) (.def .public pop'' - (-> Symbol (Meta Any)) - (alter (function (_ [exported? type value]) - [exported? type (let [value (as (Stack Any) value)] - (maybe.else value (list.tail value)))]))) + (All (_ value) (-> (Stack' value) (Meta Any))) + (alter (function (_ _ [exported? type value]) + (|> (let [value (as (Stack Any) value)] + (maybe.else value (list.tail value))) + [exported? type] + {try.#Success})))) (.def .public pop' (syntax (_ [expression? ?code.bit context ?code.global]) (do meta.monad - [_ (..pop'' context)] + [_ (..pop'' [(list) context])] (in (if expression? (list (' [])) (list)))))) (.def .public pop (syntax (_ [g!context (at ?.monad each code.symbol ?code.global)]) - (in (list (` (..pop'' (.symbol (, g!context)))))))) + (in (list (` (..pop'' [(, g!context) (.symbol (, g!context))])))))) (.def .public def (syntax (_ [.let [! ?.monad ?local (at ! each code.local ?code.local)] - [$ g!expression g!declaration] (?code.tuple (all ?.and ?code.local ?local ?local)) + + [[export_$? $] [export_expression? g!expression] [export_declaration? g!declaration]] + (?code.tuple (all ?.and + (export.parser ?code.local) + (export.parser ?local) + (export.parser ?local))) + context_type ?code.any]) (do [! meta.monad] [@ meta.current_module_name .let [g!context (code.symbol [@ $])]] (//.with_symbols [g!it g!body g!_] - (in (list (` (.def (, (code.local $)) + (in (list (` (.def (, export_$?) (, (code.local $)) (..Stack (, context_type)) (list))) - (` (.def ((, g!expression) (, g!it) (, g!body)) + (` (.def (, export_expression?) ((, g!expression) (, g!it) (, g!body)) (-> (, context_type) Code (Meta Code)) (do meta.monad [(, g!_) (..push (, g!it) (, g!context))] ((,' in) (` (let [((,' ,') (, g!body)) ((,' ,) (, g!body)) ((,' ,') (, g!_)) (..pop' #1 (, g!context))] ((,' ,') (, g!body)))))))) - (` (.def ((, g!declaration) (, g!it) (, g!body)) + (` (.def (, export_declaration?) ((, g!declaration) (, g!it) (, g!body)) (-> (, context_type) Code (Meta (List Code))) (do meta.monad [(, g!_) (..push (, g!it) (, g!context))] diff --git a/stdlib/source/library/lux/test/coverage.lux b/stdlib/source/library/lux/test/coverage.lux index efc2644a6..86b1314cc 100644 --- a/stdlib/source/library/lux/test/coverage.lux +++ b/stdlib/source/library/lux/test/coverage.lux @@ -25,7 +25,7 @@ (` (is Symbol [(, (code.text (symbol.module symbol))) (, (code.text (symbol.short symbol)))]))))] - (syntax (_ [name .symbol]) + (syntax (_ [name .global]) (do meta.monad [_ (meta.export name)] (in (list (symbol name))))))) -- cgit v1.2.3