From bb16d7e4a3307cc9540f368cf5c354a72af8ec61 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Jun 2022 03:34:49 -0400 Subject: Made the `` macro extensible. --- stdlib/source/library/lux.lux | 535 ++++++++++++++++++++++++------------------ 1 file changed, 301 insertions(+), 234 deletions(-) (limited to 'stdlib/source/library/lux.lux') diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index e14e1a7e3..ee78bcc4b 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -1449,7 +1449,7 @@ ["#in" "#then"] #0) -(def:''' .private maybe_monad +(def:''' .private maybe#monad ($' Monad Maybe) [#in (function' [x] {#Some x}) @@ -1460,7 +1460,7 @@ {#Some a} (f a)} ma))]) -(def:''' .private meta_monad +(def:''' .private meta#monad ($' Monad Meta) [#in (function' [x] @@ -1630,16 +1630,16 @@ (meta#in |#End|) {#Item lastI inits} - (do meta_monad + (do meta#monad [lastO ({[_ {#Form {#Item [[_ {#Symbol ["" "~+"]}] {#Item [spliced {#End}]}]}}] (in (:List spliced)) _ - (do meta_monad + (do meta#monad [lastO (untemplated lastI)] (in (:List (|#Item| lastO |#End|))))} lastI)] - (monad#mix meta_monad + (monad#mix meta#monad (function' [leftI rightO] ({[_ {#Form {#Item [[_ {#Symbol ["" "~+"]}] {#Item [spliced {#End}]}]}}] (let' [g!in-module (form$ (list (text$ "lux in-module") @@ -1648,15 +1648,15 @@ (in (form$ (list g!in-module (:List spliced) rightO)))) _ - (do meta_monad + (do meta#monad [leftO (untemplated leftI)] (in (|#Item| leftO rightO)))} leftI)) lastO inits))} (list#reversed elems)) - [#0] (do meta_monad - [=elems (monad#each meta_monad untemplated elems)] + [#0] (do meta#monad + [=elems (monad#each meta#monad untemplated elems)] (in (untemplated_list =elems)))} replace?)) @@ -1685,7 +1685,7 @@ (meta#in (untemplated_text value)) [#1 [_ {#Symbol [module name]}]] - (do meta_monad + (do meta#monad [real_name ({"" (if (text#= "" subst) (in [module name]) @@ -1706,7 +1706,7 @@ unquoted))) [#1 [_ {#Form {#Item [[_ {#Symbol ["" "~!"]}] {#Item [dependent {#End}]}]}}]] - (do meta_monad + (do meta#monad [independent (untemplated replace? subst dependent)] (in (with_location (variant$ (list (symbol$ [..prelude "#Form"]) (untemplated_list (list (untemplated_text "lux in-module") @@ -1717,19 +1717,19 @@ (untemplated #0 subst keep_quoted) [_ [meta {#Form elems}]] - (do meta_monad + (do meta#monad [output (spliced replace? (untemplated replace? subst) elems) .let' [[_ output'] (with_location (variant$ (list (symbol$ [..prelude "#Form"]) output)))]] (in [meta output'])) [_ [meta {#Variant elems}]] - (do meta_monad + (do meta#monad [output (spliced replace? (untemplated replace? subst) elems) .let' [[_ output'] (with_location (variant$ (list (symbol$ [..prelude "#Variant"]) output)))]] (in [meta output'])) [_ [meta {#Tuple elems}]] - (do meta_monad + (do meta#monad [output (spliced replace? (untemplated replace? subst) elems) .let' [[_ output'] (with_location (variant$ (list (symbol$ [..prelude "#Tuple"]) output)))]] (in [meta output']))} @@ -1766,7 +1766,7 @@ Macro (macro (_ tokens) ({{#Item template {#End}} - (do meta_monad + (do meta#monad [current_module current_module_name =template (untemplated #1 current_module template)] (in (list (form$ (list (text$ "lux type check") @@ -1781,7 +1781,7 @@ Macro (macro (_ tokens) ({{#Item template {#End}} - (do meta_monad + (do meta#monad [=template (untemplated #1 "" template)] (in (list (form$ (list (text$ "lux type check") (symbol$ [..prelude "Code"]) =template))))) @@ -1793,7 +1793,7 @@ Macro (macro (_ tokens) ({{#Item template {#End}} - (do meta_monad + (do meta#monad [=template (untemplated #0 "" template)] (in (list (form$ (list (text$ "lux type check") (symbol$ [..prelude "Code"]) =template))))) @@ -1958,8 +1958,8 @@ _ (failure (..wrong_syntax_error [..prelude "with_template"]))} - [(monad#each maybe_monad symbol_short bindings) - (monad#each maybe_monad tuple_list data)]) + [(monad#each maybe#monad symbol_short bindings) + (monad#each maybe#monad tuple_list data)]) _ (failure (..wrong_syntax_error [..prelude "with_template"]))} @@ -2066,7 +2066,7 @@ (-> ($' List (Tuple Text Module)) Text Text Text ($' Maybe Macro)) - (do maybe_monad + (do maybe#monad [$module (plist#value module modules) gdef (let' [[..#module_hash _ ..#module_aliases _ ..#definitions bindings ..#imports _ ..#module_state _] ("lux type check" Module $module)] (plist#value name bindings))] @@ -2095,7 +2095,7 @@ (def:''' .private (normal name) (-> Symbol ($' Meta Symbol)) ({["" name] - (do meta_monad + (do meta#monad [module_name ..current_module_name] (in [module_name name])) @@ -2105,7 +2105,7 @@ (def:''' .private (named_macro full_name) (-> Symbol ($' Meta ($' Maybe Macro))) - (do meta_monad + (do meta#monad [current_module current_module_name] (let' [[module name] full_name] (function' [state] @@ -2119,7 +2119,7 @@ (def:''' .private (macro? name) (-> Symbol ($' Meta Bit)) - (do meta_monad + (do meta#monad [name (normal name) output (named_macro name)] (in ({{#Some _} #1 @@ -2142,7 +2142,7 @@ (def:''' .private (single_expansion token) (-> Code ($' Meta ($' List Code))) ({[_ {#Form {#Item [_ {#Symbol name}] args}}] - (do meta_monad + (do meta#monad [name' (normal name) ?macro (named_macro name')] ({{#Some macro} @@ -2159,13 +2159,13 @@ (def:''' .private (expansion token) (-> Code ($' Meta ($' List Code))) ({[_ {#Form {#Item [_ {#Symbol name}] args}}] - (do meta_monad + (do meta#monad [name' (normal name) ?macro (named_macro name')] ({{#Some macro} - (do meta_monad + (do meta#monad [top_level_expansion (("lux type as" Macro' macro) args) - recursive_expansion (monad#each meta_monad expansion top_level_expansion)] + recursive_expansion (monad#each meta#monad expansion top_level_expansion)] (in (list#conjoint recursive_expansion))) {#None} @@ -2178,18 +2178,18 @@ (def:''' .private (full_expansion' full_expansion name args) (-> (-> Code ($' Meta ($' List Code))) Symbol ($' List Code) ($' Meta ($' List Code))) - (do meta_monad + (do meta#monad [name' (normal name) ?macro (named_macro name')] ({{#Some macro} - (do meta_monad + (do meta#monad [expansion (("lux type as" Macro' macro) args) - expansion' (monad#each meta_monad full_expansion expansion)] + expansion' (monad#each meta#monad full_expansion expansion)] (in (list#conjoint expansion'))) {#None} - (do meta_monad - [args' (monad#each meta_monad full_expansion args)] + (do meta#monad + [args' (monad#each meta#monad full_expansion args)] (in (list (form$ {#Item (symbol$ name) (list#conjoint args')}))))} ?macro))) @@ -2242,27 +2242,27 @@ {#End}}}}}] (if expand_in_module? (..in_module module (..full_expansion' again name tail)) - (do meta_monad - [members' (monad#each meta_monad again {#Item head tail})] + (do meta#monad + [members' (monad#each meta#monad again {#Item head tail})] (in (list (form$ (list#conjoint members')))))) [_ {#Symbol name}] (..full_expansion' again name tail) _ - (do meta_monad - [members' (monad#each meta_monad again {#Item head tail})] + (do meta#monad + [members' (monad#each meta#monad again {#Item head tail})] (in (list (form$ (list#conjoint members')))))} head) [_ {#Variant members}] - (do meta_monad - [members' (monad#each meta_monad again members)] + (do meta#monad + [members' (monad#each meta#monad again members)] (in (list (variant$ (list#conjoint members'))))) [_ {#Tuple members}] - (do meta_monad - [members' (monad#each meta_monad again members)] + (do meta#monad + [members' (monad#each meta#monad again members)] (in (list (tuple$ (list#conjoint members'))))) _ @@ -2367,10 +2367,10 @@ Macro (macro (_ tokens) ({{#Item type {#End}} - (do meta_monad + (do meta#monad [initialized_quantification? (function' [lux] {#Right [lux (initialized_quantification? lux)]})] (if initialized_quantification? - (do meta_monad + (do meta#monad [type+ (full_expansion #0 type)] ({{#Item type' {#End}} (in (list (normal_type type'))) @@ -2495,30 +2495,30 @@ (failure "Wrong syntax for def'")} parts)))) -(def:' .private (expander branches) +(def:' .private (case_expansion branches) (-> (List Code) (Meta (List Code))) ({{#Item [_ {#Form {#Item [_ {#Symbol name}] args}}] {#Item body branches'}} - (do meta_monad + (do meta#monad [??? (macro? name)] (if ??? - (do meta_monad + (do meta#monad [init_expansion (single_expansion (form$ (partial_list (symbol$ name) (form$ args) body branches')))] - (expander init_expansion)) - (do meta_monad - [sub_expansion (expander branches')] + (case_expansion init_expansion)) + (do meta#monad + [sub_expansion (case_expansion branches')] (in (partial_list (form$ (partial_list (symbol$ name) args)) body sub_expansion))))) {#Item pattern {#Item body branches'}} - (do meta_monad - [sub_expansion (expander branches')] + (do meta#monad + [sub_expansion (case_expansion branches')] (in (partial_list pattern body sub_expansion))) {#End} - (do meta_monad [] (in (list))) + (do meta#monad [] (in (list))) _ (failure (all text#composite "'lux.case' expects an even number of tokens: " (|> branches @@ -2532,8 +2532,8 @@ Macro (macro (_ tokens) ({{#Item value branches} - (do meta_monad - [expansion (expander branches)] + (do meta#monad + [expansion (case_expansion branches)] (in (list (` ((~ (variant$ expansion)) (~ value)))))) _ @@ -2545,7 +2545,7 @@ (macro (_ tokens) (case tokens {#Item [_ {#Form {#Item pattern {#End}}}] {#Item body branches}} - (do meta_monad + (do meta#monad [pattern+ (full_expansion #1 pattern)] (case pattern+ {#Item pattern' {#End}} @@ -2574,6 +2574,16 @@ _ (failure "Wrong syntax for pattern#or")))) +(def:'' .public symbol + Macro + (macro (_ tokens) + (case tokens + (pattern (list [_ {#Symbol [module name]}])) + (meta#in (list (` [(~ (text$ module)) (~ (text$ name))]))) + + _ + (failure (..wrong_syntax_error [..prelude "symbol"]))))) + (def:' .private (symbol? code) (-> Code Bit) (case code @@ -2606,7 +2616,7 @@ (failure "let requires an even number of parts")) _ - (failure "Wrong syntax for let")))) + (failure (..wrong_syntax_error (symbol ..let)))))) (def:'' .public function Macro @@ -2631,7 +2641,7 @@ (list#mix (nest g!blank) body (list#reversed tail)))))) {#None} - (failure "Wrong syntax for function")))) + (failure (..wrong_syntax_error (symbol ..function)))))) (def:' .private Parser Type @@ -2687,7 +2697,7 @@ (-> (Parser l) (Parser r) (Parser [l r]))) - (do maybe_monad + (do maybe#monad [left (leftP tokens) .let [[tokens left] left] right (rightP tokens) @@ -2699,7 +2709,7 @@ (-> (Parser l) (Parser r) (Parser r))) - (do maybe_monad + (do maybe#monad [left (leftP tokens) .let [[tokens left] left]] (rightP tokens))) @@ -2710,7 +2720,7 @@ (Parser (List a)))) (case (itP tokens) {#Some [tokens head]} - (do maybe_monad + (do maybe#monad [it (someP itP tokens) .let [[tokens tail] it]] (in [tokens (partial_list head tail)])) @@ -2722,7 +2732,7 @@ (All (_ a) (-> (Parser a) (Parser (List a)))) - (do maybe_monad + (do maybe#monad [it (itP tokens) .let [[tokens head] it] it (someP itP tokens) @@ -2745,7 +2755,7 @@ (-> (Parser a) (Parser a))) (case tokens (pattern (partial_list [_ {#Tuple input}] tokens')) - (do maybe_monad + (do maybe#monad [it (parsed itP input)] (in [tokens' it])) @@ -2757,7 +2767,7 @@ (-> (Parser a) (Parser a))) (case tokens (pattern (partial_list [_ {#Form input}] tokens')) - (do maybe_monad + (do maybe#monad [it (parsed itP input)] (in [tokens' it])) @@ -2817,7 +2827,7 @@ {#Some {#End}} _ - (do maybe_monad + (do maybe#monad [% ( tokens) .let' [[tokens head] %] tail ( tokens)] @@ -2832,14 +2842,14 @@ (Parser [Text (List )]) (case tokens (pattern (partial_list [_ {#Form local_declaration}] tokens')) - (do maybe_monad + (do maybe#monad [% (localP local_declaration) .let' [[local_declaration name] %] parameters ( local_declaration)] (in [tokens' [name parameters]])) _ - (do maybe_monad + (do maybe#monad [% (localP tokens) .let' [[tokens' name] %]] (in [tokens' [name {#End}]]))))] @@ -2871,7 +2881,7 @@ (with_template [ ] [(def:' .private ( tokens) (-> (List Code) (Maybe [(List Code) [Code Text (List )]])) - (do maybe_monad + (do maybe#monad [.let' [[tokens export_policy] (export_policyP tokens)] % ( tokens) .let' [[tokens [name parameters]] %]] @@ -2897,7 +2907,7 @@ (def:' .private (definitionP tokens) (-> (List Code) (Maybe [Code Text (List Code) (Maybe Code) Code])) - (do maybe_monad + (do maybe#monad [% (enhanced_declarationP tokens) .let' [[tokens [export_policy name parameters]] %] % (bodyP tokens) @@ -2929,17 +2939,7 @@ (~ export_policy)))))) {#None} - (failure "Wrong syntax for def:")))) - -(def:'' .public symbol - Macro - (macro (_ tokens) - (case tokens - (pattern (list [_ {#Symbol [module name]}])) - (meta#in (list (` [(~ (text$ module)) (~ (text$ name))]))) - - _ - (failure (..wrong_syntax_error [..prelude "symbol"]))))) + (failure (..wrong_syntax_error (symbol ..def:)))))) (def: (list#one f xs) (All (_ a b) @@ -2994,7 +2994,7 @@ {#Right [state (list code)]}) _ - {#Left "Wrong syntax for maybe#else"}))) + {#Left (..wrong_syntax_error (symbol ..maybe#else))}))) (def: (text#all_split_by splitter input) (-> Text Text (List Text)) @@ -3080,7 +3080,7 @@ {#Some (reduced (partial_list type_fn param env) body)} {#Apply A F} - (do maybe_monad + (do maybe#monad [type_fn* (applied_type A F)] (applied_type param type_fn*)) @@ -3122,7 +3122,7 @@ {#Some (flat_tuple type)} {#Apply arg func} - (do maybe_monad + (do maybe#monad [output (applied_type arg func)] (interface_methods output)) @@ -3157,7 +3157,7 @@ (def: (type_slot [module name]) (-> Symbol (Meta [Nat (List Symbol) Bit Type])) - (do meta_monad + (do meta#monad [=module (..module module) .let [[..#module_hash _ ..#module_aliases _ @@ -3189,7 +3189,7 @@ (record_slots body) {#Named [module name] unnamed} - (do meta_monad + (do meta#monad [=module (..module module) .let [[..#module_hash _ ..#module_aliases _ @@ -3275,8 +3275,8 @@ (def: .public implementation (macro (_ tokens) - (do meta_monad - [tokens' (monad#each meta_monad expansion tokens) + (do meta#monad + [tokens' (monad#each meta#monad expansion tokens) struct_type ..expected_type tags+type (record_slots struct_type) tags (is (Meta (List Symbol)) @@ -3293,7 +3293,7 @@ [(product#right tag) (symbol$ tag)]) tags))] - members (monad#each meta_monad + members (monad#each meta#monad (is (-> Code (Meta (List Code))) (function (_ token) (case token @@ -3333,7 +3333,7 @@ (-> (List Code) (Maybe (List a))))) (case tokens {#Item _} - (do maybe_monad + (do maybe#monad [% (itP tokens) .let [[tokens' head] %] tail (case tokens' @@ -3369,7 +3369,7 @@ cases)))) {#None} - (failure "Wrong syntax for Variant")))) + (failure (..wrong_syntax_error (symbol ..Variant)))))) (def: (slotP tokens) (-> (List Code) (Maybe [(List Code) [Text Code]])) @@ -3392,14 +3392,14 @@ slots)))) {#None} - (failure "Wrong syntax for Record")) + (failure (..wrong_syntax_error (symbol ..Record)))) _ - (failure "Wrong syntax for Record")))) + (failure (..wrong_syntax_error (symbol ..Record)))))) (def: (typeP tokens) (-> (List Code) (Maybe [Code Text (List Text) Code])) - (do maybe_monad + (do maybe#monad [% (declarationP tokens) .let' [[tokens [export_policy name parameters]] %] % (anyP tokens) @@ -3419,7 +3419,7 @@ (def: (type_declaration it) (-> Code (Meta (Tuple Code (Maybe (Either (List Text) (List Text)))))) ({[_ {#Form {#Item [_ {#Symbol declarer}] parameters}}] - (do meta_monad + (do meta#monad [declaration (single_expansion (form$ (partial_list (symbol$ declarer) parameters)))] (case declaration (pattern (list type [_ {#Variant tags}])) @@ -3452,7 +3452,7 @@ (macro (_ tokens) (case (typeP tokens) {#Some [export_policy name args type_codes]} - (do meta_monad + (do meta#monad [type+labels?? (..type_declaration type_codes) module_name current_module_name .let' [type_name (local$ name) @@ -3489,10 +3489,10 @@ (~ export_policy))))))) {#None} - (failure "Wrong syntax for type:"))) + (failure (..wrong_syntax_error (symbol ..type:))))) {#None} - (failure "Wrong syntax for type:")))) + (failure (..wrong_syntax_error (symbol ..type:)))))) (type: Referral [Symbol (List Code)]) @@ -3524,7 +3524,7 @@ (def: (text#split_by token sample) (-> Text Text (Maybe [Text Text])) - (do ..maybe_monad + (do ..maybe#monad [index (..index token sample) .let [[pre post'] (text#split_at' index sample) [_ post] (text#split_at' ("lux text size" token) post')]] @@ -3632,14 +3632,14 @@ (def: (imports_parser nested? relative_root context imports) (-> Bit Text (List Text) (List Code) (Meta (List Importation))) - (do meta_monad - [imports' (monad#each meta_monad + (do meta#monad + [imports' (monad#each meta#monad (is (-> Code (Meta (List Importation))) (function (_ token) (case token ... Nested (pattern [_ {#Tuple (partial_list [_ {#Symbol ["" module_name]}] extra)}]) - (do meta_monad + (do meta#monad [absolute_module_name (case (normal_parallel_path relative_root module_name) {#Some parallel_path} (in parallel_path) @@ -3665,7 +3665,7 @@ sub_imports)))) (pattern [_ {#Tuple (partial_list [_ {#Text alias}] [_ {#Symbol ["" module_name]}] extra)}]) - (do meta_monad + (do meta#monad [absolute_module_name (case (normal_parallel_path relative_root module_name) {#Some parallel_path} (in parallel_path) @@ -3693,7 +3693,7 @@ ... Unrecognized syntax. _ - (do meta_monad + (do meta#monad [current_module current_module_name] (failure (all text#composite "Wrong syntax for import @ " current_module @@ -3776,7 +3776,7 @@ (def: (test_referrals current_module imported_module all_defs referred_defs) (-> Text Text (List Text) (List Text) (Meta (List Any))) - (monad#each meta_monad + (monad#each meta#monad (is (-> Text (Meta Any)) (function (_ _def) (if (is_member? all_defs _def) @@ -3797,7 +3797,7 @@ (..someP ..localP)) tokens) {.#Some [current_module imported_module import_alias actual]} - (do meta_monad + (do meta#monad [expected (exported_definitions imported_module) _ (test_referrals current_module imported_module expected actual)] (in (list#each (..alias_definition imported_module) actual))) @@ -3807,14 +3807,14 @@ (def: .public |>> (macro (_ tokens) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!arg (..generated_symbol "arg")] (meta#in (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens))))))))) (def: .public <<| (macro (_ tokens) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!arg (..generated_symbol "arg")] (meta#in (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg))))))))) @@ -3828,7 +3828,7 @@ (..someP ..localP)) tokens) {.#Some [current_module imported_module import_alias actual]} - (do meta_monad + (do meta#monad [expected (exported_definitions imported_module) _ (test_referrals current_module imported_module expected actual)] (in (|> expected @@ -3947,7 +3947,7 @@ (def: (type_definition full_name) (-> Symbol (Meta Type)) - (do meta_monad + (do meta#monad [.let [[module name] full_name] current_module current_module_name] (function (_ compiler) @@ -4007,12 +4007,12 @@ (macro (_ tokens) (case tokens (pattern (partial_list [_ {#Form (list [_ {#Text alias}])}] body branches)) - (do meta_monad + (do meta#monad [g!temp (..generated_symbol "temp")] (in (partial_list g!temp (` (..open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) (pattern (list [_ {#Symbol name}] [_ {#Text alias}] body)) - (do meta_monad + (do meta#monad [init_type (type_definition name) struct_evidence (record_slots init_type)] (case struct_evidence @@ -4020,7 +4020,7 @@ (failure (text#composite "Can only 'open' structs: " (type#encoded init_type))) {#Some tags&members} - (do meta_monad + (do meta#monad [full_body ((is (-> Symbol [(List Symbol) (List Type)] Code (Meta Code)) (function (again source [tags members] target) (let [locals (list#each (function (_ [t_module t_name]) @@ -4038,10 +4038,10 @@ (symbol$ binding)))) list#conjoint tuple$))] - (do meta_monad - [enhanced_target (monad#mix meta_monad + (do meta#monad + [enhanced_target (monad#mix meta#monad (function (_ [[_ m_local] m_type] enhanced_target) - (do meta_monad + (do meta#monad [m_implementation (record_slots m_type)] (case m_implementation {#Some m_tags&members} @@ -4058,7 +4058,7 @@ (in (list full_body))))) _ - (failure "Wrong syntax for open")))) + (failure (..wrong_syntax_error (symbol ..open)))))) (def: .public cond (macro (_ tokens) @@ -4077,7 +4077,7 @@ (failure "cond requires an uneven number of arguments.")) _ - (failure "Wrong syntax for cond")))) + (failure (..wrong_syntax_error (symbol ..cond)))))) (def: (enumeration' idx xs) (All (_ a) @@ -4098,7 +4098,7 @@ (macro (_ tokens) (case tokens (pattern (list [_ {#Symbol slot'}] record)) - (do meta_monad + (do meta#monad [slot (normal slot') output (..type_slot slot) .let [[idx tags exported? type] output] @@ -4128,17 +4128,17 @@ slots))) (pattern (list selector)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!record (..generated_symbol "record")] (in (list (` (function ((~ g!_) (~ g!record)) (..the (~ selector) (~ g!record))))))) _ - (failure "Wrong syntax for the")))) + (failure (..wrong_syntax_error (symbol ..the)))))) (def: (open_declaration imported_module alias tags my_tag_index [module short] source type) (-> Text Text (List Symbol) Nat Symbol Code Type (Meta (List Code))) - (do meta_monad + (do meta#monad [output (record_slots type) g!_ (..generated_symbol "g!_") .let [g!output (local$ short) @@ -4152,8 +4152,8 @@ source+ (` ({(~ pattern) (~ g!output)} (~ source)))]] (case output {#Some [tags' members']} - (do meta_monad - [decls' (monad#each meta_monad + (do meta#monad + [decls' (monad#each meta#monad (is (-> [Nat Symbol Type] (Meta (List Code))) (function (_ [sub_tag_index sname stype]) (open_declaration imported_module alias tags' sub_tag_index sname source+ stype))) @@ -4167,14 +4167,14 @@ (def: (implementation_declarations imported_module alias implementation) (-> Text Text Symbol (Meta (List Code))) - (do meta_monad + (do meta#monad [interface (type_definition implementation) output (record_slots interface)] (case output {#Some [slots terms]} - (do meta_monad + (do meta#monad [.let [g!implementation (symbol$ implementation)] - declarations (monad#each meta_monad (is (-> [Nat Symbol Type] (Meta (List Code))) + declarations (monad#each meta#monad (is (-> [Nat Symbol Type] (Meta (List Code))) (function (_ [index slot_label slot_type]) (open_declaration imported_module alias slots index slot_label g!implementation slot_type))) (enumeration (zipped_2 slots terms)))] @@ -4215,16 +4215,16 @@ ["" "" ""])] (case implementations {#Left implementations} - (do meta_monad + (do meta#monad [declarations (|> implementations (list#each (localized imported_module)) - (monad#each meta_monad (implementation_declarations import_alias alias)))] + (monad#each meta#monad (implementation_declarations import_alias alias)))] (in (list#conjoint declarations))) {#Right implementations} - (do meta_monad + (do meta#monad [pre_defs,implementations (is (Meta [(List Code) (List Code)]) - (monad#mix meta_monad + (monad#mix meta#monad (function (_ it [pre_defs implementations]) (case it [_ {#Symbol _}] @@ -4232,7 +4232,7 @@ {#Item it implementations}]) _ - (do meta_monad + (do meta#monad [g!implementation (..generated_symbol "implementation")] (in [{#Item (` ("lux def" (~ g!implementation) (~ it) #0)) pre_defs} {#Item g!implementation implementations}])))) @@ -4254,14 +4254,14 @@ (def: (imported_by? import_name module_name) (-> Text Text (Meta Bit)) - (do meta_monad + (do meta#monad [module (module module_name) .let [[..#module_hash _ ..#module_aliases _ ..#definitions _ ..#imports imports ..#module_state _] module]] (in (is_member? imports import_name)))) (def: (referrals module_name extra) (-> Text (List Code) (Meta (List Referral))) - (do meta_monad + (do meta#monad [extra,referral (case (referrals_parser #0 extra) {#Some extra,referral} (in extra,referral) @@ -4285,7 +4285,7 @@ (macro (_ tokens) (case tokens (pattern (partial_list [_ {#Text imported_module}] [_ {#Text alias}] options)) - (do meta_monad + (do meta#monad [referrals (..referrals imported_module options) current_module ..current_module_name] (in (list#each (function (_ [macro parameters]) @@ -4326,17 +4326,17 @@ (macro (_ tokens) (case tokens (pattern (list [_ {#Symbol slot'}] value record)) - (do meta_monad + (do meta#monad [slot (normal slot') output (..type_slot slot) .let [[idx tags exported? type] output]] (case (interface_methods type) {#Some members} - (do meta_monad - [pattern' (monad#each meta_monad + (do meta#monad + [pattern' (monad#each meta#monad (is (-> [Symbol [Nat Type]] (Meta [Symbol Nat Code])) (function (_ [r_slot_name [r_idx r_type]]) - (do meta_monad + (do meta#monad [g!slot (..generated_symbol "")] (meta#in [r_slot_name r_idx g!slot])))) (zipped_2 tags (enumeration members)))] @@ -4364,11 +4364,11 @@ (pattern (list [_ {#Tuple slots}] value record)) (case slots {#End} - (failure "Wrong syntax for has") + (failure (..wrong_syntax_error (symbol ..has))) _ - (do meta_monad - [bindings (monad#each meta_monad + (do meta#monad + [bindings (monad#each meta#monad (is (-> Code (Meta Code)) (function (_ _) (..generated_symbol "temp"))) slots) @@ -4389,14 +4389,14 @@ (~ update_expr))))))) (pattern (list selector value)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!record (..generated_symbol "record")] (in (list (` (function ((~ g!_) (~ g!record)) (..has (~ selector) (~ value) (~ g!record))))))) (pattern (list selector)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!value (..generated_symbol "value") g!record (..generated_symbol "record")] @@ -4404,23 +4404,23 @@ (..has (~ selector) (~ g!value) (~ g!record))))))) _ - (failure "Wrong syntax for has")))) + (failure (..wrong_syntax_error (symbol ..has)))))) (def: .public revised (macro (_ tokens) (case tokens (pattern (list [_ {#Symbol slot'}] fun record)) - (do meta_monad + (do meta#monad [slot (normal slot') output (..type_slot slot) .let [[idx tags exported? type] output]] (case (interface_methods type) {#Some members} - (do meta_monad - [pattern' (monad#each meta_monad + (do meta#monad + [pattern' (monad#each meta#monad (is (-> [Symbol [Nat Type]] (Meta [Symbol Nat Code])) (function (_ [r_slot_name [r_idx r_type]]) - (do meta_monad + (do meta#monad [g!slot (..generated_symbol "")] (meta#in [r_slot_name r_idx g!slot])))) (zipped_2 tags (enumeration members)))] @@ -4448,10 +4448,10 @@ (pattern (list [_ {#Tuple slots}] fun record)) (case slots {#End} - (failure "Wrong syntax for revised") + (failure (..wrong_syntax_error (symbol ..revised))) _ - (do meta_monad + (do meta#monad [g!record (..generated_symbol "record") g!temp (..generated_symbol "temp")] (in (list (` (let [(~ g!record) (~ record) @@ -4459,14 +4459,14 @@ (has [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) (pattern (list selector fun)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!record (..generated_symbol "record")] (in (list (` (function ((~ g!_) (~ g!record)) (..revised (~ selector) (~ fun) (~ g!record))))))) (pattern (list selector)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "_") g!fun (..generated_symbol "fun") g!record (..generated_symbol "record")] @@ -4474,9 +4474,9 @@ (..revised (~ selector) (~ g!fun) (~ g!record))))))) _ - (failure "Wrong syntax for revised")))) + (failure (..wrong_syntax_error (symbol ..revised)))))) -(def: .private pattern#template +(def: .private with_template#pattern (macro (_ tokens) (case tokens (pattern (partial_list [_ {#Form (list [_ {#Tuple bindings}] @@ -4484,9 +4484,9 @@ [_ {#Form data}] branches)) (case (is (Maybe (List Code)) - (do maybe_monad - [bindings' (monad#each maybe_monad symbol_short bindings) - data' (monad#each maybe_monad tuple_list data)] + (do maybe#monad + [bindings' (monad#each maybe#monad symbol_short bindings) + data' (monad#each maybe#monad tuple_list data)] (let [num_bindings (list#size bindings')] (if (every? (|>> ("lux i64 =" num_bindings)) (list#each list#size data')) @@ -4501,10 +4501,10 @@ (meta#in (list#composite output branches)) {#None} - (failure "Wrong syntax for pattern#template")) + (failure (..wrong_syntax_error (symbol ..with_template#pattern)))) _ - (failure "Wrong syntax for pattern#template")))) + (failure (..wrong_syntax_error (symbol ..with_template#pattern)))))) (with_template [ ] [(def: .public @@ -4537,22 +4537,22 @@ {#Primitive name params} (` {.#Primitive (~ (text$ name)) (~ (untemplated_list (list#each type_code params)))}) - (pattern#template [] - [{ left right} - (` { (~ (type_code left)) (~ (type_code right))})]) + (with_template#pattern [] + [{ left right} + (` { (~ (type_code left)) (~ (type_code right))})]) ([.#Sum] [.#Product] [.#Function] [.#Apply]) - (pattern#template [] - [{ id} - (` { (~ (nat$ id))})]) + (with_template#pattern [] + [{ id} + (` { (~ (nat$ id))})]) ([.#Parameter] [.#Var] [.#Ex]) - (pattern#template [] - [{ env type} - (let [env' (untemplated_list (list#each type_code env))] - (` { (~ env') (~ (type_code type))}))]) + (with_template#pattern [] + [{ env type} + (let [env' (untemplated_list (list#each type_code env))] + (` { (~ env') (~ (type_code type))}))]) ([.#UnivQ] [.#ExQ]) {#Named [module name] anonymous} @@ -4577,12 +4577,12 @@ (let [vars (list#each product#left pairs) inits (list#each product#right pairs)] (if (every? symbol? inits) - (do meta_monad + (do meta#monad [inits' (is (Meta (List Symbol)) - (case (monad#each maybe_monad symbol_name inits) + (case (monad#each maybe#monad symbol_name inits) {#Some inits'} (meta#in inits') - {#None} (failure "Wrong syntax for loop"))) - init_types (monad#each meta_monad type_definition inits') + {#None} (failure (..wrong_syntax_error (symbol ..loop))))) + init_types (monad#each meta#monad type_definition inits') expected ..expected_type] (meta#in (list (` (("lux type check" (-> (~+ (list#each type_code init_types)) @@ -4590,8 +4590,8 @@ (function ((~ name) (~+ vars)) (~ body))) (~+ inits)))))) - (do meta_monad - [aliases (monad#each meta_monad + (do meta#monad + [aliases (monad#each meta#monad (is (-> Code (Meta Code)) (function (_ _) (..generated_symbol ""))) inits)] @@ -4600,10 +4600,10 @@ (~ body))))))))) {#None} - (failure "Wrong syntax for loop")) + (failure (..wrong_syntax_error (symbol ..loop)))) {#None} - (failure "Wrong syntax for loop"))))) + (failure (..wrong_syntax_error (symbol ..loop))))))) (def: (with_expansions' label tokens target) (-> Text (List Code) Code (List Code)) @@ -4617,9 +4617,9 @@ tokens (list target)) - (pattern#template [] - [[location { elems}] - (list [location { (list#conjoint (list#each (with_expansions' label tokens) elems))}])]) + (with_template#pattern [] + [[location { elems}] + (list [location { (list#conjoint (list#each (with_expansions' label tokens) elems))}])]) ([#Form] [#Variant] [#Tuple]))) @@ -4639,7 +4639,7 @@ map)))] (case bindings {#Item [var_name expr] &rest} - (do meta_monad + (do meta#monad [expansion (case (normal expr) (pattern (list expr)) (single_expansion expr) @@ -4652,17 +4652,17 @@ (again &rest (plist#with var_name expansion map))) {#End} - (at meta_monad #in (list#conjoint (list#each normal bodies)))))) + (at meta#monad #in (list#conjoint (list#each normal bodies)))))) {#None} - (failure "Wrong syntax for with_expansions")))) + (failure (..wrong_syntax_error (symbol ..with_expansions)))))) (def: (flat_alias type) (-> Type Type) (case type - (pattern#template [] - [{#Named ["library/lux" ] _} - type]) + (with_template#pattern [] + [{#Named ["library/lux" ] _} + type]) (["Bit"] ["Nat"] ["Int"] @@ -4678,13 +4678,13 @@ (def: (static_simple_literal name) (-> Symbol (Meta Code)) - (do meta_monad + (do meta#monad [type+value (definition_value name) .let [[type value] type+value]] (case (flat_alias type) - (pattern#template [ ] - [{#Named ["library/lux" ] _} - (in ( (as value)))]) + (with_template#pattern [ ] + [{#Named ["library/lux" ] _} + (in ( (as value)))]) (["Bit" Bit bit$] ["Nat" Nat nat$] ["Int" Int int$] @@ -4700,16 +4700,16 @@ (case token [_ {#Symbol [def_module def_name]}] (if (text#= "" def_module) - (do meta_monad + (do meta#monad [current_module current_module_name] (static_simple_literal [current_module def_name])) (static_simple_literal [def_module def_name])) - (pattern#template [] - [[meta { parts}] - (do meta_monad - [=parts (monad#each meta_monad static_literal parts)] - (in [meta { =parts}]))]) + (with_template#pattern [] + [[meta { parts}] + (do meta#monad + [=parts (monad#each meta#monad static_literal parts)] + (in [meta { =parts}]))]) ([#Form] [#Variant] [#Tuple]) @@ -4717,19 +4717,19 @@ _ (meta#in token) ... TODO: Figure out why this doesn't work: - ... (at meta_monad in token) + ... (at meta#monad in token) )) (def: .public static (macro (_ tokens) (case tokens (pattern (list pattern)) - (do meta_monad + (do meta#monad [pattern' (static_literal pattern)] (in (list pattern'))) _ - (failure "Wrong syntax for 'static'.")))) + (failure (..wrong_syntax_error (symbol ..static)))))) (type: Multi_Level_Case [Code (List [Code Code])]) @@ -4751,8 +4751,8 @@ (failure "Multi-level patterns cannot be empty.") {#Item init extras} - (do meta_monad - [extras' (monad#each meta_monad case_level^ extras)] + (do meta#monad + [extras' (monad#each meta#monad case_level^ extras)] (in [init extras'])))) (def: (multi_level_case$ g!_ [[init_pattern levels] body]) @@ -4779,7 +4779,7 @@ (macro (_ tokens) (case tokens (pattern (partial_list [_meta {#Form levels}] body next_branches)) - (do meta_monad + (do meta#monad [mlc (multi_level_case^ levels) .let [initial_bind? (case mlc [[_ {#Symbol _}] _] @@ -4805,7 +4805,7 @@ (list g!temp (` {.#None}))))))))))) _ - (failure "Wrong syntax for pattern#multi")))) + (failure (..wrong_syntax_error (symbol ..pattern#multi)))))) (def: .public (same? reference sample) (All (_ a) @@ -4816,7 +4816,7 @@ (macro (_ tokens) (case tokens (pattern (list expr)) - (do meta_monad + (do meta#monad [type ..expected_type] (in (list (` ("lux type as" (~ (type_code type)) (~ expr)))))) @@ -4832,7 +4832,7 @@ (macro (_ tokens) (case tokens {#End} - (do meta_monad + (do meta#monad [location ..location .let [[module line column] location location (all "lux text concat" (text#encoded module) "," (nat#encoded line) "," (nat#encoded column)) @@ -4846,12 +4846,12 @@ (macro (_ tokens) (case tokens (pattern (list [_ {#Symbol var_name}])) - (do meta_monad + (do meta#monad [var_type (type_definition var_name)] (in (list (type_code var_type)))) (pattern (list expression)) - (do meta_monad + (do meta#monad [g!temp (..generated_symbol "g!temp")] (in (list (` (let [(~ g!temp) (~ expression)] (..type_of (~ g!temp))))))) @@ -4861,7 +4861,7 @@ (def: (templateP tokens) (-> (List Code) (Maybe [Text (List Text) (List Code)])) - (do maybe_monad + (do maybe#monad [% (local_declarationP tokens) .let' [[tokens [name parameters]] %] % (tupleP (someP anyP) tokens) @@ -4873,7 +4873,7 @@ (macro (_ tokens) (case (templateP tokens) {#Some [name args input_templates]} - (do meta_monad + (do meta#monad [g!tokens (..generated_symbol "tokens") g!compiler (..generated_symbol "compiler") g!_ (..generated_symbol "_") @@ -4935,7 +4935,7 @@ (..meta#in platform) [_ {#Symbol symbol}] - (do meta_monad + (do meta#monad [symbol (..global_symbol symbol) type+value (..definition_value symbol) .let [[type value] type+value]] @@ -4966,7 +4966,7 @@ (meta#in (list default))) {#Item [key pick] options'} - (do meta_monad + (do meta#monad [platform (..platform_name key)] (if (text#= target platform) (meta#in (list pick)) @@ -4978,7 +4978,7 @@ (..maybeP ..anyP)) tokens) {.#Some [options default]} - (do meta_monad + (do meta#monad [target ..target] (target_pick target options default)) @@ -4999,7 +4999,7 @@ (macro (_ tokens) (case tokens (pattern (list [_ {#Nat idx}])) - (do meta_monad + (do meta#monad [stvs ..scope_type_vars] (case (..item idx (list#reversed stvs)) {#Some var_id} @@ -5023,7 +5023,7 @@ (def: .public using (macro (_ _imports) - (do meta_monad + (do meta#monad [current_module ..current_module_name imports (imports_parser #0 current_module {#End} _imports) .let [=imports (|> imports @@ -5048,20 +5048,89 @@ =refers) =refers)})))) +(with_expansions [ "#Macro/Immediate_UnQuote"] + (these (type: .public Immediate_UnQuote + (Primitive )) + + (def: .private (immediate_unquote_type? it) + (-> Type Bit) + (case it + (pattern {#Named [(static ..prelude) "Immediate_UnQuote"] + {#Primitive {#End}}}) + #1 + + _ + #0)))) + +(def: .public immediate_unquote + (-> Macro Immediate_UnQuote) + (|>> (as Immediate_UnQuote))) + +(def: immediate_unquote_macro + (-> Immediate_UnQuote Macro') + (|>> (as Macro'))) + +(def: .public ~~ + (..immediate_unquote + (macro (_ it) + (case it + (pattern (list it)) + (meta#in (list it)) + + _ + (failure (wrong_syntax_error (symbol ..~~))))))) + +(def: aggregate_embedded_expansions + (template (_ embedded_expansions <@> <*>) + [(do meta#monad + [<*>' (monad#each meta#monad embedded_expansions <*>)] + (in [(|> <*>' + list#reversed + (list#each product#left) + (list#mix list#composite (list))) + [<@> { (list#each product#right <*>')}]]))])) + +(def: (meta#try it) + (All (_ a) (-> (Meta a) (Meta (Either Text a)))) + (function (_ state) + (case (it state) + {#Left error} + {#Right [state {#Left error}]} + + {#Right [state output]} + {#Right [state {#Right output}]}))) + (def: (embedded_expansions code) - (-> Code (Meta [(List [Code Code]) Code])) + (-> Code (Meta [(List Code) Code])) (case code - (pattern [ann {#Form (list [_ {#Symbol ["" "~~"]}] expansion)}]) - (do meta_monad - [g!expansion (..generated_symbol "g!expansion")] - (in [(list [g!expansion expansion]) g!expansion])) - - (pattern#template [] - [[ann { parts}] - (do meta_monad - [=parts (monad#each meta_monad embedded_expansions parts)] - (in [(list#mix list#composite (list) (list#each product#left =parts)) - [ann { (list#each product#right =parts)}]]))]) + (pattern [@ {#Form (partial_list [@symbol {#Symbol original_symbol}] parameters)}]) + (with_expansions [ (aggregate_embedded_expansions embedded_expansions @ #Form (partial_list [@symbol {#Symbol original_symbol}] parameters))] + (do meta#monad + [resolved_symbol (..normal original_symbol) + ?resolved_symbol (meta#try (..global_symbol resolved_symbol))] + (case ?resolved_symbol + {#Left _} + + + {#Right resolved_symbol} + (do meta#monad + [?type,value (meta#try (..definition_value resolved_symbol))] + (case ?type,value + {#Left _} + + + {#Right [type value]} + (if (immediate_unquote_type? type) + (do meta#monad + [bound ((immediate_unquote_macro (as Immediate_UnQuote value)) parameters) + g!expansion (..generated_symbol "g!expansion")] + (in [{#Item g!expansion bound} + g!expansion])) + )))))) + + (with_template#pattern [] + [[@ { parts}] + (aggregate_embedded_expansions embedded_expansions @ parts)]) ([#Form] [#Variant] [#Tuple]) @@ -5073,12 +5142,10 @@ (macro (_ tokens) (case tokens (pattern (list raw)) - (do meta_monad + (do meta#monad [=raw (..embedded_expansions raw) .let [[labels labelled] =raw]] - (in (list (` (with_expansions [(~+ (|> labels - (list#each (function (_ [label expansion]) (list label expansion))) - list#conjoint))] + (in (list (` (with_expansions [(~+ labels)] (~ labelled)))))) _ @@ -5096,7 +5163,7 @@ (macro (_ tokens) (case tokens (pattern (list expression)) - (do meta_monad + (do meta#monad [g!_ (..generated_symbol "g!_")] (in (list (` ("lux try" (.function ((~ g!_) (~ g!_)) @@ -5119,15 +5186,15 @@ (def: .public Interface (macro (_ tokens) - (do meta_monad - [methods' (monad#each meta_monad expansion tokens)] + (do meta#monad + [methods' (monad#each meta#monad expansion tokens)] (case (everyP methodP (list#conjoint methods')) {#Some methods} (in (list (` (..Tuple (~+ (list#each product#right methods)))) (tuple$ (list#each (|>> product#left text$) methods)))) {#None} - (failure "Wrong syntax for Interface"))))) + (failure (..wrong_syntax_error (symbol ..Interface))))))) (def: (recursive_type g!self g!dummy name body) (-> Code Code Text Code Code) @@ -5140,7 +5207,7 @@ (macro (_ tokens) (case tokens (pattern (list [_ {#Symbol "" name}] body)) - (do meta_monad + (do meta#monad [body' (expansion body) g!self (generated_symbol "g!self") g!dummy (generated_symbol "g!dummy")] @@ -5152,7 +5219,7 @@ (in (list (..recursive_type g!self g!dummy name body'))) _ - (failure "Wrong syntax for Rec"))) + (failure (..wrong_syntax_error (symbol ..Rec))))) _ - (failure "Wrong syntax for Rec")))) + (failure (..wrong_syntax_error (symbol ..Rec)))))) -- cgit v1.2.3