aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/library/lux/control/function/polymorphism/predicate.lux130
-rw-r--r--stdlib/source/library/lux/control/function/polymorphism/type.lux7
-rw-r--r--stdlib/source/library/lux/meta/macro/context.lux183
-rw-r--r--stdlib/source/library/lux/test/coverage.lux2
-rw-r--r--stdlib/source/test/lux.lux4
-rw-r--r--stdlib/source/test/lux/control/function.lux4
-rw-r--r--stdlib/source/test/lux/control/function/polymorphism/predicate.lux41
-rw-r--r--stdlib/source/test/lux/test.lux15
-rw-r--r--stdlib/source/test/lux/test/coverage.lux65
9 files changed, 400 insertions, 51 deletions
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 [<name> <type> <format>]
+ [(exception.def .public (<name> it)
+ (Exception <type>)
+ (exception.report
+ (list ["Definition" (<format> 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 <code>.symbol])
+ (syntax (_ [name <code>.global])
(do meta.monad
[_ (meta.export name)]
(in (list (symbol name)))))))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index fb2df3a0c..f970099ec 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -52,7 +52,7 @@
["[1][0]" meta]
["[1][0]" program]
- ["[1][0]" test/property]
+ ["[1][0]" test]
["[1][0]" world]
@@ -1254,7 +1254,7 @@
/meta.test
/program.test
- /test/property.test
+ /test.test
/world.test
diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux
index d87f6f3cd..f4333d520 100644
--- a/stdlib/source/test/lux/control/function.lux
+++ b/stdlib/source/test/lux/control/function.lux
@@ -25,7 +25,8 @@
["[1][0]" named]
["[1][0]" trampoline]
["[1][0]" polymorphism
- ["[1]/[0]" type]]])
+ ["[1]/[0]" type]
+ ["[1]/[0]" predicate]]])
(def .public test
Test
@@ -76,4 +77,5 @@
/named.test
/trampoline.test
/polymorphism/type.test
+ /polymorphism/predicate.test
))))
diff --git a/stdlib/source/test/lux/control/function/polymorphism/predicate.lux b/stdlib/source/test/lux/control/function/polymorphism/predicate.lux
new file mode 100644
index 000000000..10f608094
--- /dev/null
+++ b/stdlib/source/test/lux/control/function/polymorphism/predicate.lux
@@ -0,0 +1,41 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [math
+ ["[0]" random (.only Random)]
+ [number
+ ["i" int]]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]])
+
+(/.def .public (any _ choice positive negative zero)
+ [(All (_ value))] [Int value value value] value
+ zero
+
+ (/.method (any next choice positive negative zero)
+ (i.> +0 choice)
+ positive)
+
+ (/.method (any next choice positive negative zero)
+ (i.< +0 choice)
+ negative)
+ )
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [positive random.nat
+ negative random.nat
+ zero random.nat])
+ (all _.and
+ (_.coverage [/.def]
+ (same? zero (any +0 positive negative zero)))
+ (_.coverage [/.method]
+ (and (same? positive (any +1 positive negative zero))
+ (same? negative (any -1 positive negative zero))))
+ )))
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
new file mode 100644
index 000000000..2ba71ac51
--- /dev/null
+++ b/stdlib/source/test/lux/test.lux
@@ -0,0 +1,15 @@
+(.require
+ [library
+ [lux (.except)
+ [test
+ ["_" property (.only Test)]]]]
+ ["[0]" /
+ ["[1][0]" coverage]
+ ["[1][0]" property]])
+
+(def .public test
+ Test
+ (all _.and
+ /coverage.test
+ /property.test
+ ))
diff --git a/stdlib/source/test/lux/test/coverage.lux b/stdlib/source/test/lux/test/coverage.lux
new file mode 100644
index 000000000..a7407ee6c
--- /dev/null
+++ b/stdlib/source/test/lux/test/coverage.lux
@@ -0,0 +1,65 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [control
+ ["[0]" try]]
+ [data
+ [collection
+ ["[0]" set]]]
+ [math
+ ["[0]" random (.only Random)]]
+ [meta
+ ["[0]" symbol (.use "[1]#[0]" equivalence)]
+ ["[0]" static]
+ ["[0]" code (.only)
+ ["<[1]>" \\parser]]
+ [macro
+ [syntax (.only syntax)]
+ ["[0]" template]
+ ["[0]" expansion]]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]])
+
+(def macro_error
+ (syntax (_ [macro <code>.any])
+ (function (_ compiler)
+ (when ((expansion.complete macro) compiler)
+ {try.#Failure error}
+ {try.#Success [compiler (list (code.text error))]}
+
+ {try.#Success _}
+ {try.#Failure "OOPS!"}))))
+
+(template.with_locals [g!defined g!un_defined]
+ (these (def .public g!defined
+ Nat
+ (static.random_nat))
+
+ (def .public test
+ Test
+ (<| (_.covering /._)
+ (_.for [/.Coverage])
+ (do [! random.monad]
+ [module (random.upper_case 1)
+ first (random.lower_case 2)
+ second (random.lower_case 3)
+ dummy (random.lower_case 4)])
+ (all _.and
+ (`` (_.coverage [/.of]
+ (and (let [[module _] (symbol .._)
+ [_ short] (symbol g!defined)]
+ (symbol#= [module short]
+ (/.of (,, (template.symbol [.._] [g!defined])))))
+ (exec
+ (macro_error (/.of (,, (template.symbol [.._] [g!un_defined]))))
+ true))))
+ (_.coverage [/.encoded /.decoded]
+ (let [it (/.decoded module (/.encoded (list first second)))]
+ (and (set.member? it [module first])
+ (set.member? it [module second])
+ (not (set.member? it [module dummy])))))
+ )))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 00:30:42 +0000