diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/library/lux/meta.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/library/lux/meta/type/row.lux | 217 | ||||
| -rw-r--r-- | stdlib/source/test/lux/meta/type.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/meta/type/row.lux | 146 | ||||
| -rw-r--r-- | stdlib/source/test/lux/test.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/test/property.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/test/tally.lux | 72 |
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)))))))) + ))) |