From 3b571c140a3bee7ec715df9f9cf37645883b9397 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 31 Aug 2022 04:38:04 -0400 Subject: Added support for row polymorphism. --- stdlib/source/library/lux/meta.lux | 12 +- stdlib/source/library/lux/meta/type/row.lux | 217 ++++++++++++++++++++++++++++ 2 files changed, 226 insertions(+), 3 deletions(-) create mode 100644 stdlib/source/library/lux/meta/type/row.lux (limited to 'stdlib/source/library') 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))))) -- cgit v1.2.3