From 1f4557bf0d904231b3b8d2b2bf73c35e9caead48 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 3 Sep 2022 14:31:47 -0400 Subject: Added support for context-oriented programming. --- stdlib/source/library/lux.lux | 9 +- .../lux/control/function/polymorphism/context.lux | 203 +++++++++++++++++++++ .../library/lux/control/function/predicate.lux | 10 +- stdlib/source/library/lux/test/unit.lux | 26 ++- 4 files changed, 231 insertions(+), 17 deletions(-) create mode 100644 stdlib/source/library/lux/control/function/polymorphism/context.lux (limited to 'stdlib/source/library') diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index d5c43cc7f..8a829ae10 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -3769,7 +3769,7 @@ {#None} (failure (..wrong_syntax_error (symbol ..def)))))) -(with_template [
] +(with_template [ ] [(def .public (macro (_ tokens) (when (list#reversed tokens) @@ -3780,10 +3780,11 @@ init))) _ - (failure ))))] + (meta#in (list (` ))))))] - [and (if (, pre) (, post) #0) "'and' requires >=1 clauses."] - [or (if (, pre) #1 (, post)) "'or' requires >=1 clauses."]) + [and #1 (if (, pre) (, post) #0)] + [or #0 (if (, pre) #1 (, post))] + ) (def (index part text) (-> Text Text (Maybe Nat)) diff --git a/stdlib/source/library/lux/control/function/polymorphism/context.lux b/stdlib/source/library/lux/control/function/polymorphism/context.lux new file mode 100644 index 000000000..ee47ece31 --- /dev/null +++ b/stdlib/source/library/lux/control/function/polymorphism/context.lux @@ -0,0 +1,203 @@ +(.require + [library + [lux (.except def with) + [abstract + [monad (.only do)] + ["[0]" hash]] + [control + [reader (.only Reader)] + ["?" parser (.use "[1]#[0]" monad)] + [function + ["[0]" predicate (.only Predicate)]]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence)] + [collection + ["[0]" set (.only Set)] + ["[0]" list (.use "[1]#[0]" functor)]]] + ["[0]" meta (.only) + ["[0]" symbol] + ["[0]" static] + ["[0]" code (.only) + ["?[1]" \\parser (.only Parser)]] + ["[0]" macro (.only with_symbols) + ["[0]" context] + [syntax (.only syntax) + ["[0]" export]]] + [type + [primitive (.except #name)]]]]] + [/// + ["//" mixin]]) + +(.def .public (altered alteration scope) + (All (_ context value) + (-> (-> context context) (Reader context value) + (Reader context value))) + (function (_ context) + (scope (alteration context)))) + +(with_expansions [ Symbol] + (primitive .public Layer + + + (.def .public layer + (syntax (_ [[export_policy name] (export.parser ?code.local)]) + (do meta.monad + [@ meta.current_module_name] + (in (list (` (.def (, export_policy) (, (code.local name)) + Layer + (<| (as Layer) + (is ) + [(, (code.text @)) + (, (code.text name))])))))))) + + (type .public Context + (Set Layer)) + + (.def .public empty + Context + (set.empty (at hash.functor each (|>> representation) symbol.hash))) + )) + +(with_template [ ] + [(.def .public ( layer scope) + (All (_ value) + (-> Layer (Reader Context value) + (Reader Context value))) + (function (_ context) + (scope ( layer context))))] + + [with set.has] + [without set.lacks] + ) + +(.def .public (active? layer) + (All (_ value) + (-> Layer (Predicate Context))) + (function (_ context) + (set.member? context layer))) + +(.def .public inactive? + (All (_ value) + (-> Layer (Predicate Context))) + (|>> active? predicate.complement)) + +(type Polymorphism + (Record + [#function Text + #quantifications (List Code) + #context 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] (export.parser ..signature) + quantifications (?code.tuple (?.some ?code.any)) + context ?code.any + inputs (?code.tuple (?.many ?code.any)) + output ?code.any + default ?code.any + methods (?.some ?code.any)]) + (<| (with_symbols [g!self g!_ g!scenarios g!scenario g!mixin]) + (..declaration [#function (the #name signature) + #quantifications quantifications + #context context + #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!_) (, 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) (Reader (, context) (, output))))))) + (let [(, (quoted g!mixin)) (is (, (quoted (` (<| (,* quantifications) + (-> [(,* inputs)] (Reader (, context) (, output))))))) + (//.fixed (all //.mixed + ((,' .,*) (, g!scenarios)) + (is (, (quoted (` (<| (,* quantifications) + (//.Mixin [(,* inputs)] (Reader (, context) (, output))))))) + (function ((, g!self) (, next) (, name) [(,* parameters)]) + (, (quoted default)))) + )))] + (, (when (the #parameters signature) + (list _) + (quoted g!mixin) + + _ + (` (function ((, name) (,* parameters)) + ((, (quoted g!mixin)) [(,* parameters)])))))))))))) + ))))) + +(.def .public method + (syntax (_ [signature ..signature + predicate ?code.any + body ?code.any]) + (do [! meta.monad] + [.let [criterion (is (Predicate Polymorphism) + (|>> (the #function) + (text#= (the #name signature))))] + it (context.search criterion ..stack)] + (with_symbols [g!self g!predicate g!parameters g!context g!_ g!next g!again] + (do ! + [_ (context.revised {.#Some criterion} + (revised #scenarios (|>> {.#Item (` (let [(, g!predicate) (is (<| (,* (the #quantifications it)) + (Predicate (, (the #context it)))) + (, predicate))] + (is (<| (,* (the #quantifications it)) + (//.Mixin [(,* (the #inputs it))] + (Reader (, (the #context it)) + (, (the #output it))))) + (function ((, g!_) (, g!next) (, g!again) (, g!parameters) (, g!context)) + (if ((, g!predicate) (, g!context)) + ((, g!self) (, g!next) (, g!again) (, g!parameters) (, g!context)) + ((, g!next) (, g!parameters) (, g!context)))))))})) + ..stack)] + (in (list (` (.def (, (the #export_policy it)) (, g!self) + (<| (,* (the #quantifications it)) + (//.Mixin [(,* (the #inputs it))] + (Reader (, (the #context 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/predicate.lux b/stdlib/source/library/lux/control/function/predicate.lux index 131a6520f..80703dbb6 100644 --- a/stdlib/source/library/lux/control/function/predicate.lux +++ b/stdlib/source/library/lux/control/function/predicate.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except all or and) + [lux (.except all or and not) [abstract [monoid (.only Monoid)] [functor @@ -38,13 +38,17 @@ (def .public (complement predicate) (All (_ a) (-> (Predicate a) (Predicate a))) - (|>> predicate not)) + (|>> predicate .not)) + +(def .public not + (All (_ a) (-> (Predicate a) (Predicate a))) + ..complement) (def .public (difference sub base) (All (_ a) (-> (Predicate a) (Predicate a) (Predicate a))) (function (_ value) (.and (base value) - (not (sub value))))) + (.not (sub value))))) (def .public (rec predicate) (All (_ a) diff --git a/stdlib/source/library/lux/test/unit.lux b/stdlib/source/library/lux/test/unit.lux index 62e075537..14b09f014 100644 --- a/stdlib/source/library/lux/test/unit.lux +++ b/stdlib/source/library/lux/test/unit.lux @@ -1,6 +1,7 @@ (.require [library [lux (.except and for) + ["[0]" debug] [abstract [monad (.only do)]] [control @@ -92,7 +93,7 @@ (%.Format Symbol) (|>> %.symbol (format ..clean_up_marker))) -(def .public (with_coverage coverage condition) +(def (with_coverage coverage condition) (-> (List Symbol) Bit Test) (let [message (|> coverage (list#each ..coverage_format) @@ -109,11 +110,12 @@ (let [coverage (list#each (function (_ definition) (` (coverage.of (, definition)))) coverage)] - (in (list (` (..with_coverage (is (.List .Symbol) - (.list (,* coverage))) - (, condition)))))))) + (in (list (` ((debug.private ..with_coverage) + (is (.List .Symbol) + (.list (,* coverage))) + (, condition)))))))) -(def .public (for' coverage test) +(def (for' coverage test) (-> (List Symbol) Test Test) (let [context (|> coverage (list#each ..coverage_format) @@ -130,11 +132,12 @@ (let [coverage (list#each (function (_ definition) (` (coverage.of (, definition)))) coverage)] - (in (list (` (..for' (is (.List .Symbol) - (.list (,* coverage))) - (, test)))))))) + (in (list (` ((debug.private ..for') + (is (.List .Symbol) + (.list (,* coverage))) + (, test)))))))) -(def .public (covering' module coverage test) +(def (covering' module coverage test) (-> Text Text Test Test) (let [coverage (coverage.decoded module coverage)] (|> (..context' module test) @@ -157,4 +160,7 @@ aggregate)) {.#End}) coverage.encoded)]] - (in (list (` (..covering' (, (code.text module)) (, (code.text coverage)) (, test)))))))) + (in (list (` ((debug.private ..covering') + (, (code.text module)) + (, (code.text coverage)) + (, test)))))))) -- cgit v1.2.3