aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/library/lux/meta.lux12
-rw-r--r--stdlib/source/library/lux/meta/type/row.lux217
-rw-r--r--stdlib/source/test/lux/meta/type.lux4
-rw-r--r--stdlib/source/test/lux/meta/type/row.lux146
-rw-r--r--stdlib/source/test/lux/test.lux2
-rw-r--r--stdlib/source/test/lux/test/property.lux2
-rw-r--r--stdlib/source/test/lux/test/tally.lux72
7 files changed, 450 insertions, 5 deletions
diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux
index 5cb1d3894..2b68b7e89 100644
--- a/stdlib/source/library/lux/meta.lux
+++ b/stdlib/source/library/lux/meta.lux
@@ -368,14 +368,20 @@
(def .public (export name)
(-> Symbol (Meta Definition))
- (do ..monad
- [definition (..definition name)]
+ (do [! ..monad]
+ [name (..normal name)
+ definition (..definition name)]
(when definition
{.#Definition definition}
(let [[exported? def_type def_value] definition]
(if exported?
(in definition)
- (failure (all text#composite "Definition is not an export: " (symbol#encoded name)))))
+ (do !
+ [.let [[expected _] name]
+ actual ..current_module_name]
+ (if (text#= expected actual)
+ (in definition)
+ (failure (all text#composite "Definition is not an export: " (symbol#encoded name)))))))
{.#Type [exported? type labels]}
(if exported?
diff --git a/stdlib/source/library/lux/meta/type/row.lux b/stdlib/source/library/lux/meta/type/row.lux
new file mode 100644
index 000000000..1966a4768
--- /dev/null
+++ b/stdlib/source/library/lux/meta/type/row.lux
@@ -0,0 +1,217 @@
+... https://en.wikipedia.org/wiki/Row_polymorphism
+(.require
+ [library
+ [lux (.except macro type the has revised)
+ [abstract
+ ["[0]" monad (.only do)]]
+ [control
+ ["?" parser (.use "[1]#[0]" monad)]
+ ["[0]" maybe (.use "[1]#[0]" monad)]
+ ["[0]" exception (.only Exception)]]
+ [data
+ ["[0]" product]
+ ["[0]" text (.only)
+ ["%" \\format]]
+ [collection
+ ["[0]" list (.use "[1]#[0]" monad mix)]
+ ["[0]" dictionary (.only Dictionary)]
+ ["[0]" set]]]
+ [math
+ [number
+ ["n" nat]]]
+ ["[0]" meta (.only)
+ ["[0]" symbol]
+ ["[0]" type]
+ ["[0]" code (.only)
+ ["?[1]" \\parser (.only Parser)]]
+ ["[0]" macro (.only with_symbols)
+ [vocabulary (.only vocabulary)]
+ [syntax (.only syntax)
+ ["[0]" export]]]]]])
+
+(vocabulary [.public Slot]
+ [.public slot]
+ [.private macro]
+ [.private by_name])
+
+(.type .public (Row content extra)
+ (Record
+ [#content content
+ #extra extra]))
+
+(def declaration
+ (Parser [Text (List Text)])
+ (all ?.either
+ (?.and ?code.local (?#in (list)))
+ (?code.form (?.and ?code.local (?.some ?code.local)))
+ ))
+
+(def un_paired
+ (All (_ value)
+ (-> (List [value value])
+ (List value)))
+ (|>> (list#each (function (_ [left right])
+ (list left right)))
+ list#conjoint))
+
+(def record
+ (Parser (List [Text Code]))
+ (?code.tuple (?.many (?.and ?code.local ?code.any))))
+
+(def super
+ (Parser Code)
+ ?code.any)
+
+(def definition
+ (Parser [(Maybe Code) (List [Text Code])])
+ (all ?.either
+ (?.and (?#in {.#None}) ..record)
+ (?.and (?#each maybe#in ..super) ..record)
+ ))
+
+(def row_module (symbol.module (symbol ..Row)))
+(def row_short (symbol.short (symbol ..Row)))
+
+(def (nesting it)
+ (-> Type Nat)
+ (when it
+ {.#Named _ it}
+ (nesting it)
+
+ {.#ExQ (list) un_quantified}
+ (when (type.flat_application un_quantified)
+ [{.#Named [..row_module ..row_short] _} _]
+ 1
+
+ [super _]
+ (++ (nesting super)))
+
+ _
+ 0))
+
+(exception.def .public (cannot_repeat_slot_names slots)
+ (Exception (List Text))
+ (exception.report
+ (list ["Slots" (exception.listing %.text slots)])))
+
+(def (unique_slots? it)
+ (-> (List Text) Bit)
+ (|> it
+ (set.of_list text.hash)
+ set.size
+ (n.= (list.size it))))
+
+(def .public type
+ (syntax (_ [[export_policy [name parameters]] (export.parser ..declaration)
+ [super slots] ..definition])
+ (let [slot_names (list#each product.left slots)]
+ (if (unique_slots? slot_names)
+ (do [! meta.monad]
+ [.let [parameters (list#each code.local parameters)]
+ name' (macro.symbol name)
+ slots' (monad.each ! (function (_ [slot type])
+ (do !
+ [slot' (macro.symbol slot)]
+ (in [slot' type])))
+ slots)
+ :super: (when super
+ {.#Some super}
+ (do !
+ [super (meta.eval Type
+ (` (type_literal (, super))))]
+ (in {.#Some (as Type super)}))
+
+ _
+ (in {.#None}))]
+ (with_symbols [g!_ g!&]
+ (let [self (` (Row ((, name') (,* parameters))
+ (, g!&)))]
+ (in (list.partial (` (.type (, export_policy) ((, name') (,* parameters))
+ (Record
+ [(,* (un_paired slots'))])))
+ (` (.type (, export_policy) ((, (code.local name)) (,* parameters))
+ (Ex ((, g!_) (, g!&))
+ (, (when super
+ {.#Some super}
+ (` ((, super) (, self)))
+
+ _
+ self)))))
+ (list#each (function (_ [[row_slot _] [record_slot _]])
+ (` (def (, export_policy) (, (code.local row_slot))
+ (..slot
+ (syntax ((, g!_) [])
+ (at meta.monad (,' in)
+ (list (,* (list.repeated (|> :super:
+ (maybe#each nesting)
+ (maybe.else 0))
+ (` (` ..#extra))))
+ (` ..#content)
+ (` (, record_slot)))))))))
+ (list.zipped_2 slots slots'))
+ )))))
+ (meta.lifted (exception.except ..cannot_repeat_slot_names [slot_names]))))))
+
+(def .public the
+ (syntax (_ [slot ?code.symbol
+ row ?code.any])
+ (do meta.monad
+ [slot (by_name slot)
+ path ((macro.function slot) (list))]
+ (in (list (` (.the [(,* path)] (, row))))))))
+
+(def .public has
+ (syntax (_ [slot ?code.symbol
+ value ?code.any
+ row ?code.any])
+ (do meta.monad
+ [slot (by_name slot)
+ path ((macro.function slot) (list))]
+ (in (list (` (.has [(,* path)] (, value) (, row))))))))
+
+(def .public revised
+ (syntax (_ [slot ?code.symbol
+ revision ?code.any
+ row ?code.any])
+ (do meta.monad
+ [slot (by_name slot)
+ path ((macro.function slot) (list))]
+ (in (list (` (.revised [(,* path)] (, revision) (, row))))))))
+
+(exception.def .public (missing_level it)
+ (Exception Nat)
+ (exception.report
+ (list ["Level" (%.nat it)])))
+
+(def .public row
+ (syntax (_ [slots (?code.tuple (?.many (?.and ?code.symbol ?code.any)))])
+ (do [! meta.monad]
+ [record (monad.each ! (function (_ [slot value])
+ (do !
+ [slot (by_name slot)
+ path ((macro.function slot) (list))
+ .let [nesting (n.- 2 (list.size path))
+ slot (maybe.trusted (list.last path))]]
+ (in [nesting [slot value]])))
+ slots)
+ .let [levels (list#mix (function (_ [nesting slot,value] levels)
+ (dictionary.revised' nesting
+ (list)
+ (|>> (list.partial slot,value))
+ levels))
+ (is (Dictionary Nat (List [Code Code]))
+ (dictionary.empty n.hash))
+ record)]
+ row (monad.mix ! (function (_ level extra)
+ (when (dictionary.value level levels)
+ {.#Some record}
+ (in (` [..#content [(,* (un_paired record))]
+ ..#extra (, extra)]))
+
+ {.#None}
+ (meta.lifted (exception.except ..missing_level [level]))))
+ (` [])
+ (|> (dictionary.size levels)
+ list.indices
+ list.reversed))]
+ (in (list row)))))
diff --git a/stdlib/source/test/lux/meta/type.lux b/stdlib/source/test/lux/meta/type.lux
index 67119dd60..e4c8ad2ea 100644
--- a/stdlib/source/test/lux/meta/type.lux
+++ b/stdlib/source/test/lux/meta/type.lux
@@ -42,7 +42,8 @@
["[1][0]" resource]
["[1][0]" unit]
["[1][0]" variance]
- ["[1][0]" poly]])
+ ["[1][0]" poly]
+ ["[1][0]" row]])
(def !expect
(template (_ <pattern> <value>)
@@ -572,4 +573,5 @@
/unit.test
/variance.test
/poly.test
+ /row.test
)))
diff --git a/stdlib/source/test/lux/meta/type/row.lux b/stdlib/source/test/lux/meta/type/row.lux
new file mode 100644
index 000000000..49988cc33
--- /dev/null
+++ b/stdlib/source/test/lux/meta/type/row.lux
@@ -0,0 +1,146 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [control
+ ["[0]" try]
+ ["[0]" exception]]
+ [data
+ ["[0]" text]]
+ [math
+ ["[0]" random (.only Random)]
+ [number
+ ["n" nat]]]
+ [meta
+ ["[0]" code (.only)
+ ["<[1]>" \\parser]]
+ [macro
+ [syntax (.only syntax)]
+ ["[0]" expansion]
+ ["[0]" template]]]
+ [test
+ ["_" property (.only Test)]]
+ [world
+ [time
+ ["[0]" instant (.only Instant)]
+ ["[0]" duration (.only Duration)]]]]]
+ [\\library
+ ["[0]" /]])
+
+(/.type .public Mortal
+ [@birth Instant
+ @life_span (Maybe Duration)])
+
+(/.type Human
+ Mortal
+ [@name Text])
+
+(/.type (TransHuman id)
+ Human
+ [@id id])
+
+(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 [<slot>]
+ (def repeat_slot_error
+ (macro_error
+ (/.type Bad_Row
+ [<slot> Bit
+ <slot> Nat]))))
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (_.for [/.Row])
+ (do [! random.monad]
+ [dummy_birth random.instant
+ expected_birth (random.only (|>> (same? dummy_birth) not)
+ random.instant)
+ expected_life_span (random.maybe random.duration)
+
+ dummy_name (random.upper_case 1)
+ expected_name (random.upper_case 2)
+
+ dummy_id random.nat
+ expected_id (random.only (|>> (n.= dummy_id) not) random.nat)])
+ (all _.and
+ (_.coverage [/.type /.row]
+ (exec
+ (is Mortal
+ (/.row [@birth expected_birth
+ @life_span expected_life_span]))
+ (is Human
+ (/.row [@name expected_name
+ @birth expected_birth
+ @life_span expected_life_span]))
+ (is (TransHuman Nat)
+ (/.row [@id expected_id
+ @name expected_name
+ @birth expected_birth
+ @life_span expected_life_span]))
+ true))
+ (_.coverage [/.cannot_repeat_slot_names]
+ (text.contains? (the exception.#label /.cannot_repeat_slot_names)
+ repeat_slot_error))
+ (_.coverage [/.missing_level]
+ (and (|> (/.row [@name expected_name])
+ macro_error
+ (text.contains? (the exception.#label /.missing_level)))
+ (|> (/.row [@id expected_id])
+ macro_error
+ (text.contains? (the exception.#label /.missing_level)))
+ (|> (/.row [@id expected_id
+ @name expected_name])
+ macro_error
+ (text.contains? (the exception.#label /.missing_level)))
+ (|> (/.row [@id expected_id
+ @birth expected_birth
+ @life_span expected_life_span])
+ macro_error
+ (text.contains? (the exception.#label /.missing_level)))))
+ (_.for [/.Slot /.slot]
+ (all _.and
+ (_.coverage [/.the]
+ (and (|> (/.row [@birth expected_birth
+ @life_span expected_life_span])
+ (is Mortal)
+ (/.the @birth)
+ (same? expected_birth))
+ (|> (/.row [@name expected_name
+ @birth expected_birth
+ @life_span expected_life_span])
+ (is Human)
+ (/.the @name)
+ (same? expected_name))
+ (|> (/.row [@id expected_id
+ @name expected_name
+ @birth expected_birth
+ @life_span expected_life_span])
+ (is (TransHuman Nat))
+ (/.the @id)
+ (same? expected_id))))
+ (_.coverage [/.has]
+ (|> (/.row [@birth dummy_birth
+ @life_span expected_life_span])
+ (is Mortal)
+ (/.has @birth expected_birth)
+ (/.the @birth)
+ (same? expected_birth)))
+ (_.coverage [/.revised]
+ (|> (/.row [@birth dummy_birth
+ @life_span expected_life_span])
+ (is Mortal)
+ (/.revised @birth (function (_ _) expected_birth))
+ (/.the @birth)
+ (same? expected_birth)))
+ ))
+ )))
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
index 2ba71ac51..6400db17f 100644
--- a/stdlib/source/test/lux/test.lux
+++ b/stdlib/source/test/lux/test.lux
@@ -5,11 +5,13 @@
["_" property (.only Test)]]]]
["[0]" /
["[1][0]" coverage]
+ ["[1][0]" tally]
["[1][0]" property]])
(def .public test
Test
(all _.and
/coverage.test
+ /tally.test
/property.test
))
diff --git a/stdlib/source/test/lux/test/property.lux b/stdlib/source/test/lux/test/property.lux
index 67dd9c7e1..8a1fa2f0d 100644
--- a/stdlib/source/test/lux/test/property.lux
+++ b/stdlib/source/test/lux/test/property.lux
@@ -42,7 +42,7 @@
(in (do async.monad
[[success_tally success_message] (unit.test expected_message/0 true)
[failure_tally failure_message] (unit.test expected_message/0 false)]
- (unit.coverage [unit.test tally.Tally]
+ (unit.coverage [unit.test]
(and (text.ends_with? (%.text expected_message/0) success_message)
(text.ends_with? (%.text expected_message/0) failure_message)
(and (n.= 1 (the tally.#successes success_tally))
diff --git a/stdlib/source/test/lux/test/tally.lux b/stdlib/source/test/lux/test/tally.lux
new file mode 100644
index 000000000..c1d43ad79
--- /dev/null
+++ b/stdlib/source/test/lux/test/tally.lux
@@ -0,0 +1,72 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]]
+ [data
+ [collection
+ ["[0]" set (.use "[1]#[0]" equivalence)]]]
+ [math
+ ["[0]" random]
+ [number
+ ["n" nat]]]
+ [meta
+ ["[0]" symbol]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]]
+ [///
+ [meta
+ ["[0]T" symbol]]])
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (_.for [/.Tally])
+ (do [! random.monad]
+ [left (symbolT.random 1 1)
+ right (symbolT.random 2 2)
+ expected_successes random.nat
+ expected_failures random.nat])
+ (all _.and
+ (_.coverage [/.empty]
+ (and (n.= 0 (the /.#successes /.empty))
+ (n.= 0 (the /.#failures /.empty))
+ (n.= 0 (set.size (the /.#expected /.empty)))
+ (n.= 0 (set.size (the /.#actual /.empty)))))
+ (_.coverage [/.success]
+ (and (n.= 1 (the /.#successes /.success))
+ (n.= 0 (the /.#failures /.success))
+ (n.= 0 (set.size (the /.#expected /.success)))
+ (n.= 0 (set.size (the /.#actual /.success)))))
+ (_.coverage [/.failure]
+ (and (n.= 0 (the /.#successes /.failure))
+ (n.= 1 (the /.#failures /.failure))
+ (n.= 0 (set.size (the /.#expected /.failure)))
+ (n.= 0 (set.size (the /.#actual /.failure)))))
+ (_.coverage [/.and]
+ (and (let [it (/.and /.success /.success)]
+ (and (n.= 2 (the /.#successes it))
+ (n.= 0 (the /.#failures it))))
+ (let [it (/.and /.failure /.failure)]
+ (and (n.= 0 (the /.#successes it))
+ (n.= 2 (the /.#failures it))))
+ (let [it (/.and /.success /.failure)]
+ (and (n.= 1 (the /.#successes it))
+ (n.= 1 (the /.#failures it))))
+ (let [custom [/.#successes expected_successes
+ /.#failures expected_failures
+ /.#expected (set.of_list symbol.hash (list left))
+ /.#actual (set.of_list symbol.hash (list right))]]
+ (and (let [it (/.and /.success custom)]
+ (and (n.= (++ expected_successes) (the /.#successes it))
+ (n.= expected_failures (the /.#failures it))
+ (set#= (the /.#expected custom) (the /.#expected it))
+ (set#= (the /.#actual custom) (the /.#actual it))))
+ (let [it (/.and custom /.failure)]
+ (and (n.= expected_successes (the /.#successes it))
+ (n.= (++ expected_failures) (the /.#failures it))
+ (set#= (the /.#expected custom) (the /.#expected it))
+ (set#= (the /.#actual custom) (the /.#actual it))))))))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 23:52:46 +0000