From 99d196a528804b3b136ac6c45cb872a5e7c70cde Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 24 Oct 2022 03:42:28 -0400 Subject: Added the capacity to re-bind global definitions within a scope. --- stdlib/source/library/lux/debug.lux | 2 +- .../compiler/language/lux/phase/declaration.lux | 53 +++-- .../language/lux/phase/extension/analysis/jvm.lux | 2 +- stdlib/source/library/lux/meta/global.lux | 91 +++++++++ .../source/library/lux/world/net/http/cookie.lux | 220 +++++++++++++++------ .../source/library/lux/world/net/http/header.lux | 41 +++- 6 files changed, 322 insertions(+), 87 deletions(-) create mode 100644 stdlib/source/library/lux/meta/global.lux (limited to 'stdlib/source/library') diff --git a/stdlib/source/library/lux/debug.lux b/stdlib/source/library/lux/debug.lux index 09d379e8c..2dbebbecc 100644 --- a/stdlib/source/library/lux/debug.lux +++ b/stdlib/source/library/lux/debug.lux @@ -525,7 +525,7 @@ (exception.except ..cannot_represent_value type))) (def .public private - (syntax (_ [definition .symbol]) + (syntax (_ [definition .global]) (let [[module _] definition] (in (list (` (.in_module# (, (code.text module)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux index 8d9e85ac5..dfadd0040 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux @@ -16,15 +16,14 @@ ["[0]" check]]]]] ["[0]" // ["[0]" extension] - ["[1][0]" analysis] ["/[1]" // ["/" declaration (.only Operation Phase Handler Extender)] - ["[1][0]" analysis (.only) + ["[0]" analysis (.only) ["[0]" evaluation] ["[1]/[0]" macro (.only Expander)] ["[1]/[0]" type]] [/// - ["//" phase (.use "[1]#[0]" monad)] + ["[0]" phase (.use "[1]#[0]" monad)] [reference (.only) [variable (.only)]] [meta @@ -49,10 +48,10 @@ (Operation anchor expression declaration /.Requirements))) (when expansion {.#End} - (//#in /.no_requirements) + (phase#in /.no_requirements) {.#Item head tail} - (do //.monad + (do phase.monad [head' (phase archive head) tail' (requiring phase archive tail)] (in (/.merge_requirements head' tail'))))) @@ -62,25 +61,49 @@ {#More (List Code)} {#Done /.Requirements})) +(def (macro_or_extension analysis archive whole_term function_term) + (All (_ anchor expression declaration) + (-> analysis.Phase Archive Code Code (Operation anchor expression declaration Symbol))) + (when function_term + [_ {.#Symbol it}] + (phase#in it) + + function_term + (do phase.monad + [[type analysis] (/.lifted_analysis + (analysis/type.inferring + (analysis archive function_term)))] + (when analysis + (analysis.constant definition) + (if (or (check.subsumes? .Macro type) + (check.subsumes? .Declaration type)) + (in definition) + (phase.except ..not_a_declaration [whole_term])) + + _ + (phase.except ..not_a_declaration [whole_term]))))) + (with_expansions [ (these [|form_location| {.#Form (list.partial [|text_location| {.#Symbol [..prelude "module#"]}] annotations)}])] (def .public (phase wrapper extender expander) (All (_ anchor expression declaration) - (-> //.Wrapper (Extender anchor expression declaration) Expander (Phase anchor expression declaration))) + (-> phase.Wrapper (Extender anchor expression declaration) Expander (Phase anchor expression declaration))) (function (again archive code) - (do [! //.monad] - [state //.state - .let [compiler_eval ((evaluation.evaluator (the [/.#analysis /.#phase] state) + (do [! phase.monad] + [state phase.state + .let [analysis (the [/.#analysis /.#phase] state) + compiler_eval ((evaluation.evaluator analysis [(the [/.#synthesis /.#state] state) (the [/.#synthesis /.#phase] state)] [(the [/.#generation /.#state] state) (the [/.#generation /.#phase] state)]) archive) extension_eval (as Eval (wrapper (as_expected compiler_eval)))] - _ (//.with (has [/.#analysis /.#state .#eval] extension_eval state))] + _ (phase.with (has [/.#analysis /.#state .#eval] extension_eval state))] (when code - [_ {.#Form (list.partial [_ {.#Symbol macro|extension}] inputs)}] + [_ {.#Form (list.partial term inputs)}] (do ! - [expansion|requirements (extension.application extender + [macro|extension (macro_or_extension analysis archive code term) + expansion|requirements (extension.application extender (the [/.#analysis /.#state] state) again archive .Declaration macro|extension inputs (|>> {#Done}) @@ -91,11 +114,11 @@ {.#Some macro} (/.lifted_analysis (do ! - [expansion (///analysis/macro.expansion expander macro|extension macro inputs)] + [expansion (analysis/macro.expansion expander macro|extension macro inputs)] (in {#More expansion}))) {.#None} - (//.except ..invalid_macro_call [code])))}))] + (phase.except ..invalid_macro_call [code])))}))] (when expansion|requirements {.#Left expansion} (when expansion @@ -110,4 +133,4 @@ (in requirements))) _ - (//.except ..not_a_declaration code)))))) + (phase.except ..not_a_declaration [code])))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux index 796647b7b..3cd840518 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Type Module Primitive Analysis Declaration #Default char int type) + [lux (.except Type Module Primitive Analysis Declaration Double #Default char int type) ["[0]" ffi (.only import)] [abstract ["[0]" monad (.only do)]] diff --git a/stdlib/source/library/lux/meta/global.lux b/stdlib/source/library/lux/meta/global.lux new file mode 100644 index 000000000..e26d50afd --- /dev/null +++ b/stdlib/source/library/lux/meta/global.lux @@ -0,0 +1,91 @@ +(.require + [library + [lux (.except with) + [abstract + ["[0]" monad (.only do)]] + [control + ["?" parser] + ["[0]" maybe]] + [data + ["[0]" product] + [text + ["%" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix) + ["[0]" property]]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["?[1]" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]]]]]) + +(def with_replacement + (syntax (_ [[module short] ?code.global + local ?code.local + hidden ?code.local]) + (do meta.monad + [here meta.current_module_name + _ (is (Meta Any) + (function (_ lux) + (let [lux (revised .#modules + (is (-> (property.List .Module) (property.List .Module)) + (property.revised module (is (-> .Module .Module) + (function (_ module) + (|> (do maybe.monad + [global (property.value short (the .#definitions module))] + (in (revised .#definitions + (|>> (property.has short {.#Alias [here local]}) + (property.has hidden global)) + module))) + (maybe.else module)))))) + lux)] + {.#Right [lux []]})))] + (in (list))))) + +(def without_replacement + (syntax (_ [[module short] ?code.global + hidden ?code.local]) + (do meta.monad + [_ (is (Meta Any) + (function (_ lux) + (let [lux (revised .#modules + (is (-> (property.List .Module) (property.List .Module)) + (property.revised module (is (-> .Module .Module) + (function (_ module) + (|> (do maybe.monad + [global (property.value hidden (the .#definitions module))] + (in (revised .#definitions + (|>> (property.has short global) + (property.lacks hidden)) + module))) + (maybe.else module)))))) + lux)] + {.#Right [lux []]})))] + (in (list))))) + +(def .public with + (syntax (_ [replacements (?code.tuple (?.some (?.and ?code.global ?code.any))) + declarations (?.some ?code.any)]) + (when (list.reversed replacements) + (list) + (in declarations) + + (list [global value]) + (do [! meta.monad] + [g!local (macro.symbol "g!local") + g!hidden (macro.symbol "g!hidden") + .let [[@ _] (symbol .._)]] + (in (list (` (def (, g!local) + (type_of (, (code.symbol global))) + (, value))) + (` ((.in_module# (, (code.text @)) ..with_replacement) (, (code.symbol global)) (, g!local) (, g!hidden))) + (` (these (,* declarations))) + (` ((.in_module# (, (code.text @)) ..without_replacement) (, (code.symbol global)) (, g!hidden)))))) + + (list.partial [global re_definition] tail) + (in (list (list#mix (function (_ [global re_definition] body) + (` (..with [(, (code.symbol global)) (, re_definition)] + (, body)))) + (` (..with [(, (code.symbol global)) (, re_definition)] + (,* declarations))) + tail)))))) diff --git a/stdlib/source/library/lux/world/net/http/cookie.lux b/stdlib/source/library/lux/world/net/http/cookie.lux index 5863b5bee..528da5899 100644 --- a/stdlib/source/library/lux/world/net/http/cookie.lux +++ b/stdlib/source/library/lux/world/net/http/cookie.lux @@ -1,49 +1,121 @@ +... https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Set-Cookie (.require [library - [lux (.except) - [control + [lux (.except has) + [abstract [monad (.only do)] + [equivalence (.only Equivalence)]] + [control ["[0]" try (.only Try)] - ["p" parser (.use "[1]#[0]" monad) - ["l" text (.only Parser)]]] + ["[0]" exception (.only Exception)] + ["?" parser (.use "[1]#[0]" monad)]] [data - [number - ["i" int]] - [text - ["%" \\format (.only format)]] - [format - ["[0]" context (.only Context)]] + ["[0]" text (.only) + ["%" \\format (.only format)] + ["?[1]" \\parser (.only Parser)]] [collection - ["[0]" dictionary]]] + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + [type + ["[0]" primitive (.only primitive)]]] [world - [time - ["[0]" duration (.only Duration)]]]]] - ["[0]" // (.only Header) - ["[0]" header]]) + ["[0]" time (.only) + ["[0]" day] + ["[0]" month] + ["[0]" year] + ["[0]" date] + ["[0]" instant (.only Instant)] + ["[0]" duration (.only Duration)]]]]]) + +(type .public (Cookie of) + (Record + [#name Text + #in (-> of + Text) + #out (-> Text + (Try of))])) -(type .public Directive - (-> Text Text)) +(def (digits/2 it) + (-> Nat + Text) + (if (n.< 10 it) + (format "0" (%.nat it)) + (%.nat it))) -(def (directive extension) - (-> Text Directive) - (function (_ so_far) - (format so_far "; " extension))) +... https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Date +(def (date it) + (-> Instant + Text) + (let [day (when (instant.day_of_week it) + {day.#Sunday} "Sun" + {day.#Monday} "Mon" + {day.#Tuesday} "Tue" + {day.#Wednesday} "Wed" + {day.#Thursday} "Thu" + {day.#Friday} "Fri" + {day.#Saturday} "Sat") + date (let [it (instant.date it) + day_of_month (digits/2 (date.day_of_month it)) + month (when (date.month it) + {month.#January} "Jan" + {month.#February} "Feb" + {month.#March} "Mar" + {month.#April} "Apr" + {month.#May} "May" + {month.#June} "Jun" + {month.#July} "Jul" + {month.#August} "Aug" + {month.#September} "Sep" + {month.#October} "Oct" + {month.#November} "Nov" + {month.#December} "Dec") + year (let [it (year.value (date.year it))] + (if (i.< +0 it) + (%.int it) + (%.nat (.nat it))))] + (format day_of_month " " month " " year)) + time (let [it (time.clock (instant.time it))] + (format (digits/2 (the time.#hour it)) + ":" (digits/2 (the time.#minute it)) + ":" (digits/2 (the time.#second it))))] + (format day ", " date " " time " GMT"))) -(def .public (set name value) - (-> Text Text Header) - (header.has "Set-Cookie" (format name "=" value))) +(type .public (Attribute of) + (-> (Cookie of) + (Cookie of))) + +(def separator "; ") + +(def (attribute extension it) + (-> Text + Attribute) + [#name (the #name it) + #in (function (_ value) + (format ((the #in it) value) ..separator extension)) + #out (the #out it)]) + +(def .public (expires when) + (-> Instant + Attribute) + (..attribute (format "Expires=" (date when)))) (def .public (max_age duration) - (-> Duration Directive) + (-> Duration + Attribute) (let [seconds (duration.ticks duration.second duration)] - (..directive (format "Max-Age=" (if (i.< +0 seconds) + (..attribute (format "Max-Age=" (if (i.< +0 seconds) (%.int seconds) (%.nat (.nat seconds))))))) (with_template [ ] [(def .public ( value) - (-> Text Directive) - (..directive (format "=" value)))] + (-> Text + Attribute) + (..attribute (format "=" value)))] [domain "Domain"] [path "Path"] @@ -51,41 +123,67 @@ (with_template [ ] [(def .public - Directive - (..directive ))] + Attribute + (..attribute ))] [secure "Secure"] [http_only "HttpOnly"] ) -(type .public CSRF_Policy - (Variant - {#Strict} - {#Lax})) - -(def .public (same_site policy) - (-> CSRF_Policy Directive) - (..directive (format "SameSite=" (when policy - {#Strict} "Strict" - {#Lax} "Lax")))) - -(def (cookie context) - (-> Context (Parser Context)) - (do p.monad - [key (l.slice (l.many! (l.none_of! "="))) - _ (l.this "=") - value (l.slice (l.many! (l.none_of! ";")))] - (in (dictionary.has key value context)))) - -(def (cookies context) - (-> Context (Parser Context)) - (all p.either - (do p.monad - [context' (..cookie context) - _ (l.this "; ")] - (cookies context')) - (p#in context))) - -(def .public (get header) - (-> Text (Try Context)) - (l.result header (..cookies context.empty))) +(primitive .public CSRF_Policy + Text + + (with_template [ ] + [(def .public + CSRF_Policy + (primitive.abstraction ))] + + [strict "Strict"] + [lax "Lax"] + [none "None"]) + + (def .public (same_site policy) + (-> CSRF_Policy + Attribute) + (..attribute (format "SameSite=" (primitive.representation policy)))) + ) + +(type .public Jar + (Dictionary Text Text)) + +(def .public equivalence + (Equivalence Jar) + (dictionary.equivalence text.equivalence)) + +(def .public empty + Jar + (dictionary.empty text.hash)) + +(def .public (has cookie value jar) + (All (_ of) + (-> (Cookie of) of Jar + Jar)) + (dictionary.has (the #name cookie) ((the #in cookie) value) jar)) + +(exception.def .public (unknown [cookie]) + (All (_ of) + (Exception (Cookie of))) + (exception.report + (list ["Cookie" (%.text (the #name cookie))]))) + +(def .public (value cookie jar) + (All (_ of) + (-> (Cookie of) Jar + (Try of))) + (when (dictionary.value (the #name cookie) jar) + {.#Some it} + (let [value (when (text.split_by ..separator it) + {.#Some [before after]} + before + + {.#None} + it)] + ((the #out cookie) value)) + + {.#None} + (exception.except ..unknown [cookie]))) diff --git a/stdlib/source/library/lux/world/net/http/header.lux b/stdlib/source/library/lux/world/net/http/header.lux index 81c801924..9c8a75ff0 100644 --- a/stdlib/source/library/lux/world/net/http/header.lux +++ b/stdlib/source/library/lux/world/net/http/header.lux @@ -6,26 +6,25 @@ ["[0]" try (.only Try)] ["[0]" exception (.only Exception)]] [data - [text + ["[0]" text (.only) ["%" \\format]] [collection - ["[0]" dictionary]]] + ["[0]" list (.use "[1]#[0]" mix)] + ["[0]" dictionary (.only Dictionary)]]] [math [number - ["[0]" nat]]] - [world - ["[0]" environment - ["[1]" \\parser (.only Environment)]]]]] + ["[0]" nat]]]]] [// ["[0]" mime (.only MIME)] + ["[0]" cookie] [// (.only URL)]]) (type .public Headers - Environment) + (Dictionary Text Text)) (def .public empty Headers - environment.empty) + (dictionary.empty text.hash)) ... https://developer.mozilla.org/en-US/docs/Glossary/HTTP_header (type .public (Header of) @@ -50,6 +49,8 @@ {.#None} (exception.except ..unknown [(the #name header)]))) +(def separator ",") + (def .public (has header value) (All (_ of) (-> (Header of) of Headers @@ -60,7 +61,7 @@ ((the #in header) value) previous - (%.format previous "," ((the #in header) value)))))) + (%.format previous ..separator ((the #in header) value)))))) (def .public content_length (Header Nat) @@ -79,3 +80,25 @@ [#name "Location" #in (|>>) #out (|>> {try.#Success})]) + +(def assignment "=") + +(def .public set_cookies + (Header cookie.Jar) + [#name "Set-Cookie" + #in (|>> dictionary.entries + (list#mix (function (_ [name value] previous) + (when previous + "" (%.format name ..assignment value) + _ (%.format previous ..separator name ..assignment value))) + "")) + #out (|>> (text.all_split_by ..separator) + (list#mix (function (_ cookie jar) + (when (text.split_by ..assignment cookie) + {.#Some [name value]} + (dictionary.has name value jar) + + {.#None} + jar)) + cookie.empty) + {try.#Success})]) -- cgit v1.2.3