From a384e0c9426d6110fa4c104a1327808a0aff91b0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Jun 2022 22:38:07 -0400 Subject: Generalized machinery for context-aware macros. --- stdlib/source/library/lux/macro/context.lux | 159 ++++++++++++++++++ stdlib/source/library/lux/meta.lux | 56 +++---- stdlib/source/library/lux/type/primitive.lux | 235 ++++----------------------- stdlib/source/test/lux/macro.lux | 4 +- stdlib/source/test/lux/macro/context.lux | 12 ++ stdlib/source/test/lux/type/primitive.lux | 118 ++++++-------- 6 files changed, 289 insertions(+), 295 deletions(-) create mode 100644 stdlib/source/library/lux/macro/context.lux create mode 100644 stdlib/source/test/lux/macro/context.lux (limited to 'stdlib') diff --git a/stdlib/source/library/lux/macro/context.lux b/stdlib/source/library/lux/macro/context.lux new file mode 100644 index 000000000..4fe898ee4 --- /dev/null +++ b/stdlib/source/library/lux/macro/context.lux @@ -0,0 +1,159 @@ +(.require + [library + [lux (.except def global) + [abstract + [monad (.only do)] + ["[0]" predicate (.only Predicate)]] + [control + ["[0]" exception (.only exception:)] + ["[0]" maybe] + ["?" parser (.only) + ["?[0]" code]]] + [data + ["[0]" text (.use "[1]#[0]" equivalence monoid)] + [collection + ["[0]" list] + [dictionary + ["[0]" plist (.only PList)]]]] + ["[0]" meta (.only) + ["[0]" symbol (.use "[1]#[0]" codec)]]]] + ["[0]" // (.only) + [syntax (.only syntax)] + ["^" pattern] + ["[0]" code]]) + +(type: .public Stack + List) + +(exception: .public (no_definition [it Symbol]) + (exception.report + "Definition" (symbol#encoded it))) + +(.def (global it) + (-> Symbol (Meta Any)) + (do meta.monad + [.let [[@ expected_name] it] + defs (meta.definitions @)] + (case (list.one (function (_ [actual_name [exported? type value]]) + (if (text#= expected_name actual_name) + {.#Some value} + {.#None})) + defs) + {.#Some it} + (in it) + + {.#None} + (meta.failure (exception.error ..no_definition [it]))))) + +(exception: .public no_active_context) + +(.def (peek' _ context) + (All (_ a) (-> (Stack a) Symbol (Meta a))) + (do meta.monad + [stack (..global context)] + (case (|> stack + (as (Stack Any)) + list.head) + {.#Some top} + (in (as_expected top)) + + {.#None} + (meta.failure (exception.error ..no_active_context []))))) + +(.def .public peek + (syntax (_ [g!it (at ?.monad each code.symbol ?code.global)]) + (in (list (` ((~! ..peek') (~ g!it) (.symbol (~ g!it)))))))) + +(exception: .public no_example) + +(.def (search' _ ? context) + (All (_ a) (-> (Stack a) (Predicate a) Symbol (Meta a))) + (do meta.monad + [stack (..global context)] + (case (|> stack + (as (Stack Any)) + (list.example (as (Predicate Any) ?))) + {.#Some it} + (in (as_expected it)) + + {.#None} + (meta.failure (exception.error ..no_example []))))) + +(.def .public search + (syntax (_ [g!context (at ?.monad each code.symbol ?code.global) + g!? ?code.any]) + (in (list (` ((~! ..search') (~ g!context) (~ g!?) (.symbol (~ g!context)))))))) + +(.def (alter on_definition [@ context]) + (-> (-> Definition Definition) Symbol (Meta Any)) + (function (_ lux) + (let [on_global (is (-> Global Global) + (function (_ it) + (case it + {.#Definition it} + {.#Definition (on_definition it)} + + _ + it))) + on_globals (is (-> (PList Global) (PList Global)) + (plist.revised context on_global)) + on_module (is (-> Module Module) + (revised .#definitions on_globals))] + {.#Right [(revised .#modules (plist.revised @ on_module) lux) + []]}))) + +(.def (push' _ top) + (All (_ a) (-> (Stack a) a Symbol (Meta Any))) + (alter (function (_ [exported? type stack]) + (|> stack + (as (Stack Any)) + {.#Item top} + (is (Stack Any)) + [exported? type])))) + +(.def .public push + (syntax (_ [g!context (at ?.monad each code.symbol ?code.global) + g!it ?code.any]) + (in (list (` ((~! ..push') (~ g!context) (~ g!it) (.symbol (~ g!context)))))))) + +(.def pop' + (-> Symbol (Meta Any)) + (alter (function (_ [exported? type value]) + [exported? type (let [value (as (Stack Any) value)] + (maybe.else value (list.tail value)))]))) + +(.def .public pop + (syntax (_ [expression? ?code.bit + context ?code.global]) + (do meta.monad + [_ (..pop' context)] + (in (if expression? + (list (' [])) + (list)))))) + +(.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)) + 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 $)) + (..Stack (~ context_type)) + (list))) + (` (.def ((~ g!expression) (~ g!it) (~ g!body)) + (-> (~ context_type) Code (Meta Code)) + ((~! do) (~! meta.monad) + [(~ g!_) ((~! ..push) (~ g!context) (~ g!it))] + ((~' in) (` (let [((~' ~') (~ g!body)) ((~' ~) (~ g!body)) + ((~' ~') (~ g!_)) ((~! ..pop) #1 (~ g!context))] + ((~' ~') (~ g!body)))))))) + (` (.def ((~ g!declaration) (~ g!it) (~ g!body)) + (-> (~ context_type) Code (Meta (List Code))) + ((~! do) (~! meta.monad) + [(~ g!_) ((~! ..push) (~ g!context) (~ g!it))] + ((~' in) (list (~ g!body) + (` ((~! ..pop) #0 (~ g!context)))))))) + )))))) diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index 6987ae558..cc3aa9036 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -36,11 +36,11 @@ (def (each f fa) (function (_ lux) (case (fa lux) - {try.#Failure msg} - {try.#Failure msg} - {try.#Success [lux' a]} - {try.#Success [lux' (f a)]}))))) + {try.#Success [lux' (f a)]} + + {try.#Failure msg} + {try.#Failure msg}))))) (def .public apply (Apply Meta) @@ -73,11 +73,11 @@ (def (conjoint mma) (function (_ lux) (case (mma lux) - {try.#Failure msg} - {try.#Failure msg} - {try.#Success [lux' ma]} - (ma lux')))))) + (ma lux') + + {try.#Failure msg} + {try.#Failure msg}))))) (def .public (result' lux action) (All (_ a) (-> Lux (Meta a) (Try [Lux a]))) @@ -86,21 +86,21 @@ (def .public (result lux action) (All (_ a) (-> Lux (Meta a) (Try a))) (case (action lux) - {try.#Failure error} - {try.#Failure error} - {try.#Success [_ output]} - {try.#Success output})) + {try.#Success output} + + {try.#Failure error} + {try.#Failure error})) (def .public (either left right) (All (_ a) (-> (Meta a) (Meta a) (Meta a))) (function (_ lux) (case (left lux) - {try.#Failure error} - (right lux) - {try.#Success [lux' output]} - {try.#Success [lux' output]}))) + {try.#Success [lux' output]} + + {try.#Failure error} + (right lux)))) (def .public (assertion message test) (-> Text Bit (Meta Any)) @@ -170,9 +170,6 @@ (function (_ lux) {try.#Success [lux (case (..current_module_name lux) - {try.#Failure error} - {.#None} - {try.#Success [_ this_module]} (let [modules (the .#modules lux)] (loop (again [module module @@ -200,7 +197,10 @@ {.#None} {.#Slot _} - {.#None})))))]})))) + {.#None})))) + + {try.#Failure error} + {.#None})]})))) (def .public seed (Meta Nat) @@ -456,11 +456,11 @@ (-> Text (Meta (List [Text Global]))) (function (_ lux) (case (plist.value module (the .#modules lux)) - {.#None} - {try.#Failure (all text#composite "Unknown module: " module)} - {.#Some module} - {try.#Success [lux (the .#definitions module)]}))) + {try.#Success [lux (the .#definitions module)]} + + {.#None} + {try.#Failure (all text#composite "Unknown module: " module)}))) (def .public (definitions module) (-> Text (Meta (List [Text Definition]))) @@ -600,15 +600,15 @@ (Meta (List (List [Text Type]))) (function (_ lux) (case (list.inits (the .#scopes lux)) - {.#None} - {try.#Failure "No local environment"} - {.#Some scopes} {try.#Success [lux (list#each (|>> (the [.#locals .#mappings]) (list#each (function (_ [name [type _]]) [name type]))) - scopes)]}))) + scopes)]} + + {.#None} + {try.#Failure "No local environment"}))) (def .public (de_aliased def_name) (-> Symbol (Meta Symbol)) diff --git a/stdlib/source/library/lux/type/primitive.lux b/stdlib/source/library/lux/type/primitive.lux index 52655b950..0bddb9c84 100644 --- a/stdlib/source/library/lux/type/primitive.lux +++ b/stdlib/source/library/lux/type/primitive.lux @@ -3,39 +3,25 @@ [lux (.except) ["[0]" meta] [abstract - [monad (.only Monad do)]] + [monad (.only do)]] [control ["[0]" exception (.only exception:)] ["<>" parser (.use "[1]#[0]" monad) ["<[0]>" code (.only Parser)]]] [data - ["[0]" text (.use "[1]#[0]" equivalence monoid)] + ["[0]" text (.use "[1]#[0]" equivalence)] [collection - ["[0]" list (.use "[1]#[0]" functor monoid)]]] - [macro + ["[0]" list (.use "[1]#[0]" functor)]]] + ["[0]" macro (.only) ["^" pattern] ["[0]" code] + ["[0]" context] [syntax (.only syntax) ["|[0]|" export]]] [meta ["[0]" symbol (.use "[1]#[0]" codec)]]]] ["[0]" //]) -(type: Stack - List) - -(def peek - (All (_ a) (-> (Stack a) (Maybe a))) - list.head) - -(def (push value stack) - (All (_ a) (-> a (Stack a) (Stack a))) - {.#Item value stack}) - -(def pop - (All (_ a) (-> (Stack a) (Maybe (Stack a)))) - list.tail) - (type: .public Frame (Record [#name Text @@ -43,144 +29,15 @@ #abstraction Code #representation Code])) -(def frames - (Stack Frame) - {.#End}) - -(def !peek - (template (_ ) - [(loop (again [entries ]) - (case entries - {.#Item [head_name head] tail} - (if (text#= head_name) - - (again tail)) - - {.#End} - (undefined)))])) - -(def (peek_frames_definition reference source) - (-> Text (List [Text Global]) (Stack Frame)) - (!peek source reference - (case head - {.#Definition [exported? frame_type frame_value]} - (as (Stack Frame) frame_value) +(context.def [frames expression declaration] Frame) - (^.or {.#Type _} - {.#Alias _} - {.#Tag _} - {.#Slot _}) - (undefined)))) - -(def (peek_frames reference definition_reference source) - (-> Text Text (List [Text Module]) (Stack Frame)) - (!peek source reference - (peek_frames_definition definition_reference (the .#definitions head)))) - -(exception: .public no_active_frames) - -(def (peek! frame) - (-> (Maybe Text) (Meta Frame)) - (function (_ compiler) - (let [[reference definition_reference] (symbol ..frames) - current_frames (peek_frames reference definition_reference (the .#modules compiler))] - (case (case frame - {.#Some frame} - (list.example (function (_ [actual _]) - (text#= frame actual)) - current_frames) - - {.#None} - (..peek current_frames)) - {.#Some frame} - {.#Right [compiler frame]} - - {.#None} - (exception.except ..no_active_frames []))))) - -(def .public current +(.def .public current (Meta Frame) - (..peek! {.#None})) + (context.peek ..frames)) -(def .public (specific name) +(.def .public (specific name) (-> Text (Meta Frame)) - (..peek! {.#Some name})) - -(def !push - (template (_ ) - [(loop (again [entries ]) - (case entries - {.#Item [head_name head] tail} - (if (text#= head_name) - {.#Item [head_name ] - tail} - {.#Item [head_name head] - (again tail)}) - - {.#End} - (undefined)))])) - -(def (push_frame_definition reference frame source) - (-> Text Frame (List [Text Global]) (List [Text Global])) - (!push source reference - (case head - {.#Definition [exported? frames_type frames_value]} - {.#Definition [exported? - frames_type - (..push frame (as (Stack Frame) frames_value))]} - - (^.or {.#Type _} - {.#Alias _} - {.#Tag _} - {.#Slot _}) - (undefined)))) - -(def (push_frame [module_reference definition_reference] frame source) - (-> Symbol Frame (List [Text Module]) (List [Text Module])) - (!push source module_reference - (revised .#definitions (push_frame_definition definition_reference frame) head))) - -(def (push! frame) - (-> Frame (Meta Any)) - (function (_ compiler) - {.#Right [(revised .#modules - (..push_frame (symbol ..frames) frame) - compiler) - []]})) - -(def (pop_frame_definition reference source) - (-> Text (List [Text Global]) (List [Text Global])) - (!push source reference - (case head - {.#Definition [exported? frames_type frames_value]} - {.#Definition [exported? - frames_type - (let [current_frames (as (Stack Frame) frames_value)] - (case (..pop current_frames) - {.#Some current_frames'} - current_frames' - - {.#None} - current_frames))]} - - (^.or {.#Type _} - {.#Alias _} - {.#Tag _} - {.#Slot _}) - (undefined)))) - -(def (pop_frame [module_reference definition_reference] source) - (-> Symbol (List [Text Module]) (List [Text Module])) - (!push source module_reference - (|> head (revised .#definitions (pop_frame_definition definition_reference))))) - -(def pop! - (syntax (_ []) - (function (_ compiler) - {.#Right [(revised .#modules - (..pop_frame (symbol ..frames)) - compiler) - (list)]}))) + (context.search ..frames (|>> (the #name) (text#= name)))) (def cast (Parser [(Maybe Text) Code]) @@ -191,7 +48,12 @@ [(def .public (syntax (_ [[frame value] ..cast]) (do meta.monad - [[name type_vars abstraction representation] (peek! frame)] + [[name type_vars abstraction representation] (case frame + {.#Some frame} + (..specific frame) + + {.#None} + ..current)] (in (list (` ((~! //.as) [(~+ type_vars)] (~ ) (~ ) (~ value))))))))] @@ -199,17 +61,7 @@ [representation abstraction representation] ) -(def abstraction_type_name - (-> Symbol Text) - symbol#encoded) - -(def representation_definition_name - (-> Text Text) - (|>> (all text#composite - (symbol#encoded (symbol ..#Representation)) - " "))) - -(def declaration +(def declarationP (Parser [Text (List Text)]) (<>.either (.form (<>.and .local (<>.some .local))) (<>.and .local (at <>.monad in (list))))) @@ -218,7 +70,7 @@ (Parser [Code [Text (List Text)] Code (List Code)]) (|export|.parser (all <>.and - ..declaration + ..declarationP .any (<>.some .any) ))) @@ -230,40 +82,25 @@ ..abstract]) (do meta.monad [current_module meta.current_module_name + g!Representation (macro.symbol "Representation") .let [type_varsC (list#each code.local type_vars) abstraction_declaration (` ((~ (code.local name)) (~+ type_varsC))) - representation_declaration (` ((~ (code.local (representation_definition_name name))) - (~+ type_varsC)))] - _ (..push! [name - type_varsC - abstraction_declaration - representation_declaration])] - (in (list.partial (` (type: (~ export_policy) (~ abstraction_declaration) - (Primitive (~ (code.text (abstraction_type_name [current_module name]))) - [(~+ type_varsC)]))) - (` (type: (~ representation_declaration) - (~ representation_type))) - (all list#composite - primitives - (list (` ((~! ..pop!)))))))))) - -(type: (Selection a) - (Variant - {#Specific Code a} - {#Current a})) - -(def (selection parser) - (All (_ a) (-> (Parser a) (Parser (Selection a)))) - (<>.or (<>.and .any parser) - parser)) + representation_declaration (` ((~ g!Representation) (~+ type_varsC)))]] + (..declaration [name type_varsC abstraction_declaration representation_declaration] + (` (.these (type: (~ export_policy) (~ abstraction_declaration) + (Primitive (~ (code.text (symbol#encoded [current_module name]))) + [(~+ type_varsC)])) + (type: (~ representation_declaration) + (~ representation_type)) + (~+ primitives))))))) + +(def selection + (Parser [(List Code) Code]) + (<>.either (<>.and (<>#each (|>> list) .any) .any) + (<>.and (<>#in (list)) .any))) (def .public transmutation - (syntax (_ [selection (..selection .any)]) - (case selection - {#Specific specific value} - (in (list (` (.|> (~ value) - (..representation (~ specific)) - (..abstraction (~ specific)))))) - - {#Current value} - (in (list (` (.|> (~ value) ..representation ..abstraction))))))) + (syntax (_ [[specific value] ..selection]) + (in (list (` (.|> (~ value) + (..representation (~+ specific)) + (..abstraction (~+ specific)))))))) diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux index 445792fb6..9368e2a0f 100644 --- a/stdlib/source/test/lux/macro.lux +++ b/stdlib/source/test/lux/macro.lux @@ -34,7 +34,8 @@ ["[1][0]" local] ["[1][0]" syntax] ["[1][0]" template] - ["[1][0]" pattern]]) + ["[1][0]" pattern] + ["[1][0]" context]]) (def !expect (template (_ ) @@ -248,4 +249,5 @@ /syntax.test /template.test /pattern.test + /context.test ))) diff --git a/stdlib/source/test/lux/macro/context.lux b/stdlib/source/test/lux/macro/context.lux new file mode 100644 index 000000000..52df97710 --- /dev/null +++ b/stdlib/source/test/lux/macro/context.lux @@ -0,0 +1,12 @@ +(.require + [library + [lux (.except) + ["_" test (.only Test)]]] + [\\library + ["[0]" /]]) + +(def .public test + Test + (<| (_.covering /._) + (_.property "TBD" false) + )) diff --git a/stdlib/source/test/lux/type/primitive.lux b/stdlib/source/test/lux/type/primitive.lux index dfd3aa939..619b2b3f9 100644 --- a/stdlib/source/test/lux/type/primitive.lux +++ b/stdlib/source/test/lux/type/primitive.lux @@ -35,72 +35,56 @@ [specific (/.specific (template.text [g!Foo]))] ) - (def with_no_active_frames - (syntax (_ [macro .any]) - (function (_ compiler) - (let [verdict (case ((macro.expansion macro) compiler) - {try.#Failure error} - (exception.match? /.no_active_frames error) - - {try.#Success _} - false)] - {try.#Success [compiler (list (code.bit verdict))]})))) + (/.primitive (g!Foo a) + Text - (with_expansions [no_current! (..with_no_active_frames (..current)) - no_specific! (..with_no_active_frames (..specific))] - (/.primitive (g!Foo a) - Text + (/.primitive (g!Bar a) + Nat - (/.primitive (g!Bar a) - Nat - - (def .public test - Test - (<| (_.covering /._) - (_.for [/.primitive]) - (do random.monad - [expected_foo (random.lower_case 5) - expected_bar random.nat] - (all _.and - (_.coverage [/.abstraction] - (and (exec (is (g!Foo Text) - (/.abstraction g!Foo expected_foo)) - true) - (exec (is (g!Bar Text) - (/.abstraction expected_bar)) - true))) - (_.coverage [/.representation] - (and (|> expected_foo - (/.abstraction g!Foo) - (is (g!Foo Bit)) - (/.representation g!Foo) - (text#= expected_foo)) - (|> (/.abstraction expected_bar) - (is (g!Bar Bit)) - /.representation - (n.= expected_bar)))) - (_.coverage [/.transmutation] - (and (exec (|> expected_foo - (/.abstraction g!Foo) - (is (g!Foo .Macro)) - (/.transmutation g!Foo) - (is (g!Foo .Lux))) - true) - (exec (|> (/.abstraction expected_bar) - (is (g!Bar .Macro)) - /.transmutation - (is (g!Bar .Lux))) - true))) - (_.for [/.Frame] - (all _.and - (_.coverage [/.current] - (text#= (template.text [g!Bar]) - (..current))) - (_.coverage [/.specific] - (text#= (template.text [g!Foo]) - (..specific))) - (_.coverage [/.no_active_frames] - (and no_current! - no_specific!)) - )) - ))))))))) + (def .public test + Test + (<| (_.covering /._) + (_.for [/.primitive]) + (do random.monad + [expected_foo (random.lower_case 5) + expected_bar random.nat] + (all _.and + (_.coverage [/.abstraction] + (and (exec (is (g!Foo Text) + (/.abstraction g!Foo expected_foo)) + true) + (exec (is (g!Bar Text) + (/.abstraction expected_bar)) + true))) + (_.coverage [/.representation] + (and (|> expected_foo + (/.abstraction g!Foo) + (is (g!Foo Bit)) + (/.representation g!Foo) + (text#= expected_foo)) + (|> (/.abstraction expected_bar) + (is (g!Bar Bit)) + /.representation + (n.= expected_bar)))) + (_.coverage [/.transmutation] + (and (exec (|> expected_foo + (/.abstraction g!Foo) + (is (g!Foo .Macro)) + (/.transmutation g!Foo) + (is (g!Foo .Lux))) + true) + (exec (|> (/.abstraction expected_bar) + (is (g!Bar .Macro)) + /.transmutation + (is (g!Bar .Lux))) + true))) + (_.for [/.Frame] + (all _.and + (_.coverage [/.current] + (text#= (template.text [g!Bar]) + (..current))) + (_.coverage [/.specific] + (text#= (template.text [g!Foo]) + (..specific))) + )) + )))))))) -- cgit v1.2.3