diff options
Diffstat (limited to 'stdlib/source/library')
18 files changed, 876 insertions, 667 deletions
diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index 535b103c8..17d7d3160 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -1776,6 +1776,33 @@ (in {#Item y ys}))} xs))) +(def' .private (monad#each#meta $ items) + (All (_ input output) + (-> (-> input + ($ Meta output)) + (-> ($ List input) + ($ Meta ($ List output))))) + (function' [lux] + ((.is# (All (_ input output) + (-> Lux (-> input ($ Meta output)) ($ List input) ($ List output) + ($ Either Text (And Lux ($ List output))))) + (function' again [lux $ items output] + ({{#End} + {#Right [lux (list#reversed output)]} + + {#Item head tail} + ({{#Right [lux head]} + (again lux $ tail {#Item head output}) + + {#Left failure} + {#Left failure}} + ($ head lux))} + items))) + lux + $ + items + {#End}))) + (def' .private (monad#mix m f y xs) (All (_ m a b) (-> ($ Monad m) @@ -2172,7 +2199,7 @@ |#End| (list#reversed elements)) (do meta#monad - [=elements (monad#each meta#monad (untemplated replace? subst) elements)] + [=elements (monad#each#meta (untemplated replace? subst) elements)] (in (untemplated_list =elements)))) .let' [[_ output'] (with_location ..dummy_location (variant$ (list (symbol$ [..prelude tag]) output)))]] @@ -2418,6 +2445,42 @@ (failure (wrong_syntax_error [..prelude "<|"]))} (list#reversed tokens)))) +(def' .private meta#failure + Macro + (macro (_ tokens) + ({{#Item 'error {#End}} + (meta#in (list (` {.#Left (, 'error)}))) + + _ + (failure (..wrong_syntax_error [..prelude "meta#failure"]))} + tokens))) + +(def' .private meta#return + Macro + (macro (_ tokens) + ({{#Item 'lux {#Item 'term {#End}}} + (meta#in (list (` {.#Right [(, 'lux) (, 'term)]}))) + + _ + (failure (..wrong_syntax_error [..prelude "meta#return"]))} + tokens))) + +(def' .private meta#let + Macro + (macro (_ tokens) + ({{#Item 'lux {#Item [_ {#Tuple {#Item 'binding {#Item 'term {#End}}}}] + {#Item 'body {#End}}}} + (meta#in (list (` ({{.#Right [(, 'lux) (, 'binding)]} + (, 'body) + + {.#Left (, 'lux)} + {.#Left (, 'lux)}} + ((, 'term) (, 'lux)))))) + + _ + (failure (..wrong_syntax_error [..prelude "meta#let"]))} + tokens))) + (def' .private (function#composite f g) (All (_ a b c) (-> (-> b c) (-> a b) (-> a c))) @@ -2658,26 +2721,24 @@ (def' .private (named_macro full_name) (-> Symbol ($ Meta ($ Maybe Macro))) - (do meta#monad - [current_module current_module_name] - (let' [[module name] full_name] - (function' [state] - ({[..#info info ..#source source ..#current_module _ ..#modules modules - ..#scopes scopes ..#type_context types ..#host host - ..#seed seed ..#expected expected - ..#location location ..#extensions extensions - ..#scope_type_vars scope_type_vars ..#eval _eval] - {#Right state (named_macro' modules current_module module name)}} - state))))) + (<| (function' [lux]) + (meta#let lux [current_module current_module_name]) + (let' [[module name] full_name + [..#info info ..#source source ..#current_module _ ..#modules modules + ..#scopes scopes ..#type_context types ..#host host + ..#seed seed ..#expected expected + ..#location location ..#extensions extensions + ..#scope_type_vars scope_type_vars ..#eval _eval] lux]) + (meta#return lux (named_macro' modules current_module module name)))) (def' .private (macro? name) (-> Symbol ($ Meta Bit)) - (do meta#monad - [name (normal name) - output (named_macro name)] - (in ({{#Some _} #1 - {#None} #0} - output)))) + (<| (function' [lux]) + (meta#let lux [name (normal name)]) + (meta#let lux [output (named_macro name)]) + (meta#return lux ({{#Some _} #1 + {#None} #0} + output)))) (def' .private (list#interposed sep xs) (All (_ a) @@ -2692,18 +2753,67 @@ (list#partial x sep (list#interposed sep xs'))} xs)) +(def' .private (text#encoded original) + (-> Text Text) + (all text#composite ..double_quote original ..double_quote)) + +(def' .private (code#encoded code) + (-> Code Text) + ({[_ {#Bit value}] + (bit#encoded value) + + [_ {#Nat value}] + (nat#encoded value) + + [_ {#Int value}] + (int#encoded value) + + [_ {#Rev value}] + (.error# "@code#encoded Undefined behavior.") + + [_ {#Frac value}] + (frac#encoded value) + + [_ {#Text value}] + (text#encoded value) + + [_ {#Symbol [module name]}] + (symbol#encoded [module name]) + + [_ {#Form xs}] + (all text#composite "(" (|> xs + (list#each code#encoded) + (list#interposed " ") + list#reversed + (list#mix text#composite "")) ")") + + [_ {#Tuple xs}] + (all text#composite "[" (|> xs + (list#each code#encoded) + (list#interposed " ") + list#reversed + (list#mix text#composite "")) "]") + + [_ {#Variant xs}] + (all text#composite "{" (|> xs + (list#each code#encoded) + (list#interposed " ") + list#reversed + (list#mix text#composite "")) "}")} + code)) + (def' .private (single_expansion token) (-> Code ($ Meta ($ List Code))) ({[_ {#Form {#Item [_ {#Symbol name}] args}}] - (do meta#monad - [name' (normal name) - ?macro (named_macro name')] - ({{#Some macro} - ((.as# Macro' macro) args) - - {#None} - (in (list token))} - ?macro)) + (<| (function' [lux]) + (meta#let lux [name' (normal name)]) + (meta#let lux [?macro (named_macro name')]) + ({{#Some macro} + (((.as# Macro' macro) args) lux) + + {#None} + (meta#return lux (list token))} + ?macro)) _ (meta#in (list token))} @@ -2712,39 +2822,51 @@ (def' .private (complete_expansion token) (-> Code ($ Meta ($ List Code))) ({[_ {#Form {#Item [_ {#Symbol name}] args}}] - (do meta#monad - [name' (normal name) - ?macro (named_macro name')] - ({{#Some macro} - (do meta#monad - [top_level_expansion ((.as# Macro' macro) args) - recursive_expansion (monad#each meta#monad complete_expansion top_level_expansion)] - (in (list#conjoint recursive_expansion))) - - {#None} - (in (list token))} - ?macro)) + (<| (function' [lux]) + (meta#let lux [name' (normal name)]) + (meta#let lux [?macro (named_macro name')]) + ({{#Some macro} + (<| (meta#let lux [top_level_expansion ((.as# Macro' macro) args)]) + (meta#let lux [recursive_expansion (monad#each#meta complete_expansion top_level_expansion)]) + (meta#return lux (list#conjoint recursive_expansion))) + + {#None} + (meta#return lux (list token))} + ?macro)) _ (meta#in (list token))} token)) +(def' .public exec + Macro + (macro (_ tokens) + ({{#Item value actions} + (let' [dummy (local$ "")] + (meta#in (list (list#mix (.is# (-> Code Code Code) + (function' [pre post] (` ({(, dummy) (, post)} (, pre))))) + value + actions)))) + + _ + (failure (..wrong_syntax_error (symbol ..exec)))} + (list#reversed tokens)))) + (def' .private (total_expansion' total_expansion @name name args) - (-> (-> Code ($ Meta ($ List Code))) Location Symbol ($ List Code) ($ Meta ($ List Code))) - (do meta#monad - [name' (normal name) - ?macro (named_macro name')] - ({{#Some macro} - (do meta#monad - [expansion ((.as# Macro' macro) args) - expansion' (monad#each meta#monad total_expansion expansion)] - (in (list#conjoint expansion'))) - - {#None} - (do meta#monad - [args' (monad#each meta#monad total_expansion args)] - (in (list (form$ {#Item [@name {#Symbol name}] (list#conjoint args')}))))} - ?macro))) + (-> (-> Code ($ Meta ($ List Code))) Location Symbol ($ List Code) + ($ Meta ($ List Code))) + (<| (function' [lux]) + (meta#let lux [name' (normal name)]) + (meta#let lux [?macro (named_macro name')]) + ({{#Some macro} + (<| (meta#let lux [expansion ((.as# Macro' macro) args)]) + (meta#let lux [expansion' (monad#each#meta total_expansion expansion)]) + (meta#return lux (list#conjoint expansion'))) + + {#None} + (<| (meta#let lux [args' (monad#each#meta total_expansion args)]) + (meta#return lux (list (form$ {#Item [@name {#Symbol name}] (list#conjoint args')}))))} + ?macro))) (def' .private (in_module module meta) (All (_ a) @@ -2792,93 +2914,44 @@ (..total_expansion' total_expansion @name name tail) _ - (do meta#monad - [members' (monad#each meta#monad total_expansion {#Item head tail})] - (in (list (form$ (list#conjoint members')))))} + (<| (function' [lux]) + (meta#let lux [members' (monad#each#meta total_expansion {#Item head tail})]) + (meta#return lux (list (form$ (list#conjoint members')))))} head) [_ {#Variant members}] - (do meta#monad - [members' (monad#each meta#monad total_expansion members)] - (in (list (variant$ (list#conjoint members'))))) + (<| (function' [lux]) + (meta#let lux [members' (monad#each#meta total_expansion members)]) + (meta#return lux (list (variant$ (list#conjoint members'))))) [_ {#Tuple members}] - (do meta#monad - [members' (monad#each meta#monad total_expansion members)] - (in (list (tuple$ (list#conjoint members'))))) + (<| (function' [lux]) + (meta#let lux [members' (monad#each#meta total_expansion members)]) + (meta#return lux (list (tuple$ (list#conjoint members'))))) _ (meta#in (list syntax))} syntax)) -(def' .private (text#encoded original) - (-> Text Text) - (all text#composite ..double_quote original ..double_quote)) - -(def' .private (code#encoded code) - (-> Code Text) - ({[_ {#Bit value}] - (bit#encoded value) - - [_ {#Nat value}] - (nat#encoded value) - - [_ {#Int value}] - (int#encoded value) - - [_ {#Rev value}] - (.error# "@code#encoded Undefined behavior.") - - [_ {#Frac value}] - (frac#encoded value) - - [_ {#Text value}] - (text#encoded value) - - [_ {#Symbol [module name]}] - (symbol#encoded [module name]) - - [_ {#Form xs}] - (all text#composite "(" (|> xs - (list#each code#encoded) - (list#interposed " ") - list#reversed - (list#mix text#composite "")) ")") - - [_ {#Tuple xs}] - (all text#composite "[" (|> xs - (list#each code#encoded) - (list#interposed " ") - list#reversed - (list#mix text#composite "")) "]") - - [_ {#Variant xs}] - (all text#composite "{" (|> xs - (list#each code#encoded) - (list#interposed " ") - list#reversed - (list#mix text#composite "")) "}")} - code)) - (def' .private (normal_type type) (-> Code ($ Meta Code)) ({[_ {#Variant {#Item [_ {#Symbol symbol}] parts}}] - (do meta#monad - [parts (monad#each meta#monad normal_type parts)] - (in (` {(, (symbol$ symbol)) (,* parts)}))) + (<| (function' [lux]) + (meta#let lux [parts (monad#each#meta normal_type parts)]) + (meta#return lux (` {(, (symbol$ symbol)) (,* parts)}))) [_ {#Tuple members}] - (do meta#monad - [members (monad#each meta#monad normal_type members)] - (in (` (Tuple (,* members))))) + (<| (function' [lux]) + (meta#let lux [members (monad#each#meta normal_type members)]) + (meta#return lux (` (Tuple (,* members))))) [_ {#Form {#Item [_ {#Symbol ["library/lux" "in_module#"]}] {#Item [_ {#Text module}] {#Item type' {#End}}}}}] - (do meta#monad - [type' (normal_type type')] - (in (` (.in_module# (, (text$ module)) (, type'))))) + (<| (function' [lux]) + (meta#let lux [type' (normal_type type')]) + (meta#return lux (` (.in_module# (, (text$ module)) (, type'))))) [_ {#Form {#Item [_ {#Symbol ["" ","]}] {#Item expression {#End}}}}] (meta#in expression) @@ -2886,33 +2959,33 @@ [_0 {#Form {#Item [_1 {#Variant {#Item binding {#Item body {#End}}}}] {#Item value {#End}}}}] - (do meta#monad - [body (normal_type body)] - (in [_0 {#Form {#Item [_1 {#Variant {#Item binding {#Item body {#End}}}}] - {#Item value - {#End}}}}])) + (<| (function' [lux]) + (meta#let lux [body (normal_type body)]) + (meta#return lux [_0 {#Form {#Item [_1 {#Variant {#Item binding {#Item body {#End}}}}] + {#Item value + {#End}}}}])) [_0 {#Form {#Item [_1 {#Symbol ["library/lux" "__adjusted_quantified_type__"]}] {#Item _permission {#Item _level {#Item body {#End}}}}}}] - (do meta#monad - [body (normal_type body)] - (in [_0 {#Form {#Item [_1 {#Symbol [..prelude "__adjusted_quantified_type__"]}] - {#Item _permission - {#Item _level - {#Item body - {#End}}}}}}])) + (<| (function' [lux]) + (meta#let lux [body (normal_type body)]) + (meta#return lux [_0 {#Form {#Item [_1 {#Symbol [..prelude "__adjusted_quantified_type__"]}] + {#Item _permission + {#Item _level + {#Item body + {#End}}}}}}])) [_ {#Form {#Item type_fn args}}] - (do meta#monad - [type_fn (normal_type type_fn) - args (monad#each meta#monad normal_type args)] - (in (list#mix (.is# (-> Code Code Code) - (function' [arg type_fn] (` {.#Apply (, arg) (, type_fn)}))) - type_fn - args))) + (<| (function' [lux]) + (meta#let lux [type_fn (normal_type type_fn)]) + (meta#let lux [args (monad#each#meta normal_type args)]) + (meta#return lux (list#mix (.is# (-> Code Code Code) + (function' [arg type_fn] (` {.#Apply (, arg) (, type_fn)}))) + type_fn + args))) _ (meta#in type)} @@ -2988,24 +3061,21 @@ Macro (macro (type_literal tokens) ({{#Item type {#End}} - (do meta#monad - [initialized_quantification? (function' [lux] {#Right [lux (initialized_quantification? lux)]})] - (if initialized_quantification? - (do meta#monad - [type+ (total_expansion type)] - ({{#Item type' {#End}} - (do meta#monad - [type'' (normal_type type')] - (in (list type''))) + (<| (function' [lux]) + (let' [initialized_quantification? (initialized_quantification? lux)]) + (if initialized_quantification? + (<| (meta#let lux [type+ (total_expansion type)]) + ({{#Item type' {#End}} + (<| (meta#let lux [type'' (normal_type type')]) + (meta#return lux (list type''))) - _ - (failure "The expansion of the type-syntax had to yield a single element.")} - type+)) - (do meta#monad - [it (with_quantification' - (one_expansion - (type_literal tokens)))] - (in (list (..quantified it)))))) + _ + (meta#failure "The expansion of the type-syntax had to yield a single element.")} + type+)) + (<| (meta#let lux [it (with_quantification' + (one_expansion + (type_literal tokens)))]) + (meta#return lux (list (..quantified it)))))) _ (failure (..wrong_syntax_error (symbol ..type_literal)))} @@ -3065,20 +3135,6 @@ (local$ (all text#composite "__gensym__" prefix (nat#encoded seed)))}} state)) -(def' .public exec - Macro - (macro (_ tokens) - ({{#Item value actions} - (let' [dummy (local$ "")] - (meta#in (list (list#mix (.is# (-> Code Code Code) - (function' [pre post] (` ({(, dummy) (, post)} (, pre))))) - value - actions)))) - - _ - (failure (..wrong_syntax_error (symbol ..exec)))} - (list#reversed tokens)))) - (with_template [<name> <tag>] [(def' .private (<name> type) (type_literal (-> Type (List Type))) @@ -3221,17 +3277,17 @@ [meta {#Form parts}] (do meta#monad - [=parts (monad#each meta#monad (literal only_global?) parts)] + [=parts (monad#each#meta (literal only_global?) parts)] (in [meta {#Form =parts}])) [meta {#Variant parts}] (do meta#monad - [=parts (monad#each meta#monad (literal only_global?) parts)] + [=parts (monad#each#meta (literal only_global?) parts)] (in [meta {#Variant =parts}])) [meta {#Tuple parts}] (do meta#monad - [=parts (monad#each meta#monad (literal only_global?) parts)] + [=parts (monad#each#meta (literal only_global?) parts)] (in [meta {#Tuple =parts}])) _ @@ -3401,8 +3457,10 @@ (def' .private Parser Type {#Named [..prelude "Parser"] - (..type_literal (All (_ a) - (-> (List Code) (Maybe [(List Code) a]))))}) + (type_literal + (All (_ a) + (-> (List Code) + (Maybe [(List Code) a]))))}) (def' .private (parsed parser tokens) (type_literal (All (_ a) (-> (Parser a) (List Code) (Maybe a)))) @@ -3990,7 +4048,7 @@ (def .public implementation (macro (_ tokens) (do meta#monad - [tokens' (monad#each meta#monad complete_expansion tokens) + [tokens' (monad#each#meta complete_expansion tokens) implementation_type ..expected_type tags+type (record_slots implementation_type) tags (is (Meta (List Symbol)) @@ -4007,21 +4065,20 @@ [(product#right tag) (symbol$ tag)]) tags))] - members (monad#each meta#monad - (is (-> Code (Meta (List Code))) - (function (_ token) - (when token - [_ {#Form (list [_ {#Symbol [..prelude "def#"]}] [_ {#Symbol ["" slot_name]}] value export_policy)}] - (when (property#value slot_name tag_mappings) - {#Some tag} - (in (list tag value)) - - _ - (failure (text#composite "Unknown implementation member: " slot_name))) - - _ - (failure "Invalid implementation member.")))) - (list#conjoint tokens'))] + members (monad#each#meta (is (-> Code (Meta (List Code))) + (function (_ token) + (when token + [_ {#Form (list [_ {#Symbol [..prelude "def#"]}] [_ {#Symbol ["" slot_name]}] value export_policy)}] + (when (property#value slot_name tag_mappings) + {#Some tag} + (in (list tag value)) + + _ + (failure (text#composite "Unknown implementation member: " slot_name))) + + _ + (failure "Invalid implementation member.")))) + (list#conjoint tokens'))] (in (list (tuple$ (list#conjoint members))))))) (def (text#interposed separator parts) @@ -4392,72 +4449,71 @@ (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 - (is (-> Code (Meta (List Importation))) - (function (_ token) - (when token - ... Nested - [_ {#Tuple (list#partial [_ {#Symbol ["" module_name]}] extra)}] - (do meta#monad - [absolute_module_name (when (normal_parallel_path relative_root module_name) - {#Some parallel_path} - (in parallel_path) - - {#None} - (..absolute_module_name nested? relative_root module_name)) - extra,referral (when (referrals_parser #0 extra) - {#Some extra,referral} - (in extra,referral) - - {#None} - (failure "")) - .let [[extra referral] extra,referral] - sub_imports (imports_parser #1 absolute_module_name context extra)] - (in (when referral - {#End} - sub_imports - - _ - (list#partial [#import_name absolute_module_name - #import_alias {#None} - #import_referrals referral] - sub_imports)))) - - [_ {#Tuple (list#partial [_ {#Text alias}] [_ {#Symbol ["" module_name]}] extra)}] - (do meta#monad - [absolute_module_name (when (normal_parallel_path relative_root module_name) - {#Some parallel_path} - (in parallel_path) - - {#None} - (..absolute_module_name nested? relative_root module_name)) - extra,referral (when (referrals_parser #1 extra) - {#Some extra,referral} - (in extra,referral) - - {#None} - (failure "")) - .let [[extra referral] extra,referral] - .let [module_alias (..module_alias {#Item module_name context} alias)] - sub_imports (imports_parser #1 absolute_module_name {#Item module_alias context} extra)] - (in (when referral - {#End} - sub_imports - - _ - (list#partial [#import_name absolute_module_name - #import_alias {#Some module_alias} - #import_referrals referral] - sub_imports)))) - - ... Unrecognized syntax. - _ - (do meta#monad - [current_module current_module_name] - (failure (all text#composite - "Wrong syntax for import @ " current_module - \n (code#encoded token))))))) - imports)] + [imports' (monad#each#meta (is (-> Code (Meta (List Importation))) + (function (_ token) + (when token + ... Nested + [_ {#Tuple (list#partial [_ {#Symbol ["" module_name]}] extra)}] + (do meta#monad + [absolute_module_name (when (normal_parallel_path relative_root module_name) + {#Some parallel_path} + (in parallel_path) + + {#None} + (..absolute_module_name nested? relative_root module_name)) + extra,referral (when (referrals_parser #0 extra) + {#Some extra,referral} + (in extra,referral) + + {#None} + (failure "")) + .let [[extra referral] extra,referral] + sub_imports (imports_parser #1 absolute_module_name context extra)] + (in (when referral + {#End} + sub_imports + + _ + (list#partial [#import_name absolute_module_name + #import_alias {#None} + #import_referrals referral] + sub_imports)))) + + [_ {#Tuple (list#partial [_ {#Text alias}] [_ {#Symbol ["" module_name]}] extra)}] + (do meta#monad + [absolute_module_name (when (normal_parallel_path relative_root module_name) + {#Some parallel_path} + (in parallel_path) + + {#None} + (..absolute_module_name nested? relative_root module_name)) + extra,referral (when (referrals_parser #1 extra) + {#Some extra,referral} + (in extra,referral) + + {#None} + (failure "")) + .let [[extra referral] extra,referral] + .let [module_alias (..module_alias {#Item module_name context} alias)] + sub_imports (imports_parser #1 absolute_module_name {#Item module_alias context} extra)] + (in (when referral + {#End} + sub_imports + + _ + (list#partial [#import_name absolute_module_name + #import_alias {#Some module_alias} + #import_referrals referral] + sub_imports)))) + + ... Unrecognized syntax. + _ + (do meta#monad + [current_module current_module_name] + (failure (all text#composite + "Wrong syntax for import @ " current_module + \n (code#encoded token))))))) + imports)] (in (list#conjoint imports')))) (def (exported_definitions module state) @@ -4529,13 +4585,12 @@ (def (test_referrals current_module imported_module all_defs referred_defs) (-> Text Text (List Text) (List Text) (Meta (List Any))) - (monad#each meta#monad - (is (-> Text (Meta Any)) - (function (_ _def) - (if (is_member? all_defs _def) - (meta#in []) - (failure (all text#composite _def " is not defined in module " imported_module " @ " current_module))))) - referred_defs)) + (monad#each#meta (is (-> Text (Meta Any)) + (function (_ _def) + (if (is_member? all_defs _def) + (meta#in []) + (failure (all text#composite _def " is not defined in module " imported_module " @ " current_module))))) + referred_defs)) (def (alias_definition imported_module def) (-> Text Text Code) @@ -4742,16 +4797,15 @@ (def (open_layer alias [tags members]) (-> Text Implementation_Interface (Meta [Code (List [Symbol Implementation_Interface])])) (do meta#monad - [pattern (monad#each meta#monad - (function (_ [slot slot_type]) - (do meta#monad - [.let [[_ slot_name] slot - local ["" (..module_alias (list slot_name) alias)]] - implementation (record_slots slot_type)] - (in [(list (symbol$ slot) - (symbol$ local)) - [local implementation]]))) - (zipped_2 tags members))] + [pattern (monad#each#meta (function (_ [slot slot_type]) + (do meta#monad + [.let [[_ slot_name] slot + local ["" (..module_alias (list slot_name) alias)]] + implementation (record_slots slot_type)] + (in [(list (symbol$ slot) + (symbol$ local)) + [local implementation]]))) + (zipped_2 tags members))] (in [(|> pattern (list#each product#left) list#conjoint @@ -4765,7 +4819,7 @@ (def (open_layers alias interfaces body) (-> Text (List Implementation_Interface) Code (Meta [Code Code])) (do meta#monad - [layer (monad#each meta#monad (open_layer alias) interfaces) + [layer (monad#each#meta (open_layer alias) interfaces) .let [pattern (tuple$ (list#each product#left layer)) next (|> layer (list#each product#right) @@ -4923,11 +4977,10 @@ (when output {#Some [tags' members']} (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))) - (enumeration (zipped_2 tags' members')))] + [decls' (monad#each#meta (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))) + (enumeration (zipped_2 tags' members')))] (in (list#conjoint decls'))) _ @@ -4944,10 +4997,10 @@ {#Some [slots terms]} (do meta#monad [.let [g!implementation (symbol$ implementation)] - 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)))] + declarations (monad#each#meta (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)))] (in (list#conjoint declarations))) _ @@ -4988,7 +5041,7 @@ (do meta#monad [declarations (|> implementations (list#each (localized imported_module)) - (monad#each meta#monad (implementation_declarations import_alias alias)))] + (monad#each#meta (implementation_declarations import_alias alias)))] (in (list#conjoint declarations))) {#Right implementations} @@ -5108,13 +5161,12 @@ {.#Some [lefts right? family]} (do meta#monad - [pattern' (monad#each meta#monad - (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) - (function (_ [r_idx r_slot_name]) - (do meta#monad - [g!slot (..generated_symbol "")] - (in [r_slot_name r_idx g!slot])))) - (enumeration family)) + [pattern' (monad#each#meta (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) + (function (_ [r_idx r_slot_name]) + (do meta#monad + [g!slot (..generated_symbol "")] + (in [r_slot_name r_idx g!slot])))) + (enumeration family)) .let [pattern (|> pattern' (list#each (is (-> [Symbol Nat Code] (List Code)) (function (_ [r_slot_name r_idx r_var]) @@ -5141,10 +5193,9 @@ _ (do meta#monad - [bindings (monad#each meta#monad - (is (-> Code (Meta Code)) - (function (_ _) (..generated_symbol "temp"))) - slots) + [bindings (monad#each#meta (is (-> Code (Meta Code)) + (function (_ _) (..generated_symbol "temp"))) + slots) .let [pairs (zipped_2 slots bindings) update_expr (list#mix (is (-> [Code Code] Code Code) (function (_ [s b] v) @@ -5193,13 +5244,12 @@ {.#Some [lefts right? family]} (do meta#monad - [pattern' (monad#each meta#monad - (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) - (function (_ [r_idx r_slot_name]) - (do meta#monad - [g!slot (..generated_symbol "")] - (in [r_slot_name r_idx g!slot])))) - (enumeration family)) + [pattern' (monad#each#meta (is (-> [Nat Symbol] (Meta [Symbol Nat Code])) + (function (_ [r_idx r_slot_name]) + (do meta#monad + [g!slot (..generated_symbol "")] + (in [r_slot_name r_idx g!slot])))) + (enumeration family)) .let [pattern (|> pattern' (list#each (is (-> [Symbol Nat Code] (List Code)) (function (_ [r_slot_name r_idx r_var]) @@ -5357,7 +5407,7 @@ (when (monad#each maybe#monad symbol_name inits) {#Some inits'} (meta#in inits') {#None} (failure (..wrong_syntax_error (symbol ..loop))))) - init_types (monad#each meta#monad type_definition inits') + init_types (monad#each#meta type_definition inits') expected ..expected_type] (meta#in (list (` ((.is# (-> (,* (list#each type_code init_types)) (, (type_code expected))) @@ -5365,10 +5415,9 @@ (, body))) (,* inits)))))) (do meta#monad - [aliases (monad#each meta#monad - (is (-> Code (Meta Code)) - (function (_ _) (..generated_symbol ""))) - inits)] + [aliases (monad#each#meta (is (-> Code (Meta Code)) + (function (_ _) (..generated_symbol ""))) + inits)] (meta#in (list (` (..let [(,* (..interleaved aliases inits))] (..loop ((, name) [(,* (..interleaved vars aliases))]) (, body))))))))) @@ -5687,7 +5736,7 @@ (def aggregate_embedded_expansions (template (_ embedded_expansions <@> <tag> <*>) [(do meta#monad - [<*>' (monad#each meta#monad embedded_expansions <*>)] + [<*>' (monad#each#meta embedded_expansions <*>)] (in [(|> <*>' list#reversed (list#each product#left) @@ -5779,7 +5828,7 @@ (def .public Interface (macro (_ tokens) (do meta#monad - [methods' (monad#each meta#monad complete_expansion tokens)] + [methods' (monad#each#meta complete_expansion tokens)] (when (everyP methodP (list#conjoint methods')) {#Some methods} (in (list (` (..Tuple (,* (list#each product#right methods)))) diff --git a/stdlib/source/library/lux/data/text.lux b/stdlib/source/library/lux/data/text.lux index 5732efe88..a2fe70b35 100644 --- a/stdlib/source/library/lux/data/text.lux +++ b/stdlib/source/library/lux/data/text.lux @@ -187,7 +187,7 @@ (macro (_ tokens lux) (when tokens (list it) - {.#Right [lux (list (` (.when ("js type-of" ("js constant" (, it))) + {.#Right [lux (list (` (.when (.js_type_of# (.js_constant# (, it))) "undefined" .false @@ -238,7 +238,7 @@ (..if_nashorn <default> (as Text - ("js object do" "replaceAll" template [pattern replacement]))) + (.js_object_do# "replaceAll" template [pattern replacement]))) @.python (as Text (.python_object_do# "replace" template [pattern replacement])) @@ -365,7 +365,7 @@ (as (Nominal "java.lang.String") value))) @.js (as Text - ("js object do" "toLowerCase" value [])) + (.js_object_do# "toLowerCase" value [])) @.python (as Text (.python_object_do# "lower" value [])) @@ -388,7 +388,7 @@ (as (Nominal "java.lang.String") value))) @.js (as Text - ("js object do" "toUpperCase" value [])) + (.js_object_do# "toUpperCase" value [])) @.python (as Text (.python_object_do# "upper" value [])) diff --git a/stdlib/source/library/lux/data/text/encoding/utf8.lux b/stdlib/source/library/lux/data/text/encoding/utf8.lux index c6b8d80a5..e6db26578 100644 --- a/stdlib/source/library/lux/data/text/encoding/utf8.lux +++ b/stdlib/source/library/lux/data/text/encoding/utf8.lux @@ -76,7 +76,7 @@ @.js (cond ffi.on_nashorn? - (as Binary ("js object do" "getBytes" value ["utf8"])) + (as Binary (.js_object_do# "getBytes" value ["utf8"])) ffi.on_node_js? (|> (Buffer::from|encoded value "utf8") @@ -118,7 +118,7 @@ @.js (cond ffi.on_nashorn? - (|> ("js object new" ("js constant" "java.lang.String") [value "utf8"]) + (|> (.js_object_new# (.js_constant# "java.lang.String") [value "utf8"]) (as Text) {try.#Success}) diff --git a/stdlib/source/library/lux/debug.lux b/stdlib/source/library/lux/debug.lux index a763188ad..2b076858a 100644 --- a/stdlib/source/library/lux/debug.lux +++ b/stdlib/source/library/lux/debug.lux @@ -194,19 +194,19 @@ ["undefined" [JSON::stringify]]) "object" - (let [variant_tag ("js object get" "_lux_tag" value) - variant_flag ("js object get" "_lux_flag" value) - variant_value ("js object get" "_lux_value" value)] - (cond (not (or ("js object undefined?" variant_tag) - ("js object undefined?" variant_flag) - ("js object undefined?" variant_value))) + (let [variant_tag (.js_object_get# "_lux_tag" value) + variant_flag (.js_object_get# "_lux_flag" value) + variant_value (.js_object_get# "_lux_value" value)] + (cond (not (or (.js_object_undefined?# variant_tag) + (.js_object_undefined?# variant_flag) + (.js_object_undefined?# variant_value))) (|> (%.format (JSON::stringify variant_tag) - " " (%.bit (not ("js object null?" variant_flag))) + " " (%.bit (not (.js_object_null?# variant_flag))) " " (inspection variant_value)) (text.enclosed ["{" "}"])) - (not (or ("js object undefined?" ("js object get" "_lux_low" value)) - ("js object undefined?" ("js object get" "_lux_high" value)))) + (not (or (.js_object_undefined?# (.js_object_get# "_lux_low" value)) + (.js_object_undefined?# (.js_object_get# "_lux_high" value)))) (|> value (as .Int) %.int) (Array::isArray value) diff --git a/stdlib/source/library/lux/ffi.lux b/stdlib/source/library/lux/ffi.lux index c515749a9..e55e55271 100644 --- a/stdlib/source/library/lux/ffi.lux +++ b/stdlib/source/library/lux/ffi.lux @@ -186,22 +186,22 @@ ... else (these)) -(with_expansions [<constant> (for @.js "js constant" +(with_expansions [<constant> (for @.js .js_constant# @.python .python_constant# @.lua .lua_constant# @.ruby .ruby_constant#) - <apply> (for @.js "js apply" + <apply> (for @.js .js_apply# @.python .python_apply# @.lua .lua_apply# @.ruby .ruby_apply#) - <new> (for @.js "js object new" + <new> (for @.js .js_object_new# @.python .python_apply# (these)) - <do> (for @.js "js object do" + <do> (for @.js .js_object_do# @.python .python_object_do# @.lua .lua_object_do# @.ruby .ruby_object_do#) - <get> (for @.js "js object get" + <get> (for @.js .js_object_get# @.python .python_object_get# @.lua .lua_object_get# @.ruby .ruby_object_get# @@ -213,7 +213,7 @@ @.lua .lua_import# @.ruby .ruby_import# (these)) - <function> (for @.js "js function" + <function> (for @.js .js_function# @.python .python_function# @.lua .lua_function# (these))] @@ -460,8 +460,8 @@ (, g!it') (.panic! "Invalid output."))))))))))] - (,, (for @.js [null "js object null" - null? "js object null?"] + (,, (for @.js [null .js_object_null# + null? .js_object_null?#] @.python [none .python_object_none# none? .python_object_none?#] @.lua [nil .lua_object_nil# @@ -828,13 +828,13 @@ (for @.js (these (def .public type_of (template (type_of object) - [("js type-of" object)])) + [(.js_type_of# object)])) (def .public global (syntax (_ [type <code>.any [head tail] (<code>.tuple (<>.and <code>.local (<>.some <code>.local)))]) (with_symbols [g!_] - (let [global (` ("js constant" (, (code.text head))))] + (let [global (` (.js_constant# (, (code.text head))))] (when tail {.#End} (in (list (` (is (.Maybe (, type)) @@ -878,7 +878,7 @@ Bit (|> (..global (Object Any) [process]) (maybe#each (|>> [] - ("js apply" ("js constant" "Object.prototype.toString.call")) + (.js_apply# (.js_constant# "Object.prototype.toString.call")) (as Text) (text#= "[object process]"))) (maybe.else false)))) diff --git a/stdlib/source/library/lux/ffi/export.js.lux b/stdlib/source/library/lux/ffi/export.js.lux index 0ca0d157f..0b9fa4241 100644 --- a/stdlib/source/library/lux/ffi/export.js.lux +++ b/stdlib/source/library/lux/ffi/export.js.lux @@ -11,11 +11,8 @@ [collection ["[0]" list (.use "[1]#[0]" monad mix)] ["[0]" set]]] - [math - ["[0]" random]] ["[0]" meta (.only) [extension (.only declaration)] - ["[0]" static] ["[0]" code (.only) ["<[1]>" \\parser]] [macro @@ -47,10 +44,9 @@ <code>.any))) meta.of_try)) -(with_expansions [<extension> (static.random (|>> %.nat (%.format "js export ") code.text) - random.nat)] - (declaration (<extension> self phase archive [name <code>.text - term <code>.any]) +(def .public export_one + (declaration (_ phase archive [name <code>.text + term <code>.any]) (do [! phase.monad] [next declaration.analysis [_ term] (<| declaration.of_analysis @@ -83,15 +79,15 @@ _ (translation.execute! definition) _ (translation.save! @self {.#None} code)] (translation.log! (%.format "Export " (%.text name)))))] - (in declaration.no_requirements))) + (in declaration.no_requirements)))) - (def .public export - (syntax (_ [exports (<>.many <code>.any)]) - (let [! meta.monad] - (|> exports - (monad.each ! expansion.complete) - (at ! each (|>> list#conjoint - (monad.each ! ..definition))) - (at ! conjoint) - (at ! each (list#each (function (_ [name term]) - (` (<extension> (, (code.text name)) (, term))))))))))) +(def .public export + (syntax (_ [exports (<>.many <code>.any)]) + (let [! meta.monad] + (|> exports + (monad.each ! expansion.complete) + (at ! each (|>> list#conjoint + (monad.each ! ..definition))) + (at ! conjoint) + (at ! each (list#each (function (_ [name term]) + (` (..export_one (, (code.text name)) (, term)))))))))) diff --git a/stdlib/source/library/lux/math/number/frac.lux b/stdlib/source/library/lux/math/number/frac.lux index 228de8764..0c6f59c71 100644 --- a/stdlib/source/library/lux/math/number/frac.lux +++ b/stdlib/source/library/lux/math/number/frac.lux @@ -120,7 +120,7 @@ (-> Frac Frac) (|>> [] - ("js apply" ("js constant" <method>)) + (.js_apply# (.js_constant# <method>)) (as Frac)))] [cos "Math.cos"] @@ -144,7 +144,7 @@ (def .public (pow param subject) (-> Frac Frac Frac) - (as Frac ("js apply" ("js constant" "Math.pow") [subject param])))) + (as Frac (.js_apply# (.js_constant# "Math.pow") [subject param])))) @.python (these (with_template [<name> <method>] diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux index 45289a754..30c217bf3 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux @@ -11,7 +11,7 @@ ["[0]" array] ["[0]" dictionary] ["[0]" list]]] - [meta + ["[0]" meta (.only) ["@" target (.only) ["_" js]] ["[0]" code @@ -20,16 +20,16 @@ ["[0]" check]]]]] [// ["/" lux (.only custom)] - [// - ["[0]" bundle] - [/// + [/// + ["[0]" extension] + [// ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) ["[1]/[0]" type]] [/// ["[0]" phase]]]]]) (def array::new - Handler + (-> Text Handler) (custom [<code>.any (function (_ extension phase archive lengthC) @@ -40,11 +40,13 @@ (do phase.monad [lengthA (analysis/type.expecting Nat (phase archive lengthC)) - _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] - (in {analysis.#Extension extension (list lengthA)}))))])) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:))) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list lengthA)}]))))])) (def array::length - Handler + (-> Text Handler) (custom [<code>.any (function (_ extension phase archive arrayC) @@ -55,11 +57,13 @@ (do phase.monad [arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) (phase archive arrayC)) - _ (analysis/type.inference Nat)] - (in {analysis.#Extension extension (list arrayA)}))))])) + _ (analysis/type.inference Nat) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list arrayA)}]))))])) (def array::read - Handler + (-> Text Handler) (custom [(<>.and <code>.any <code>.any) (function (_ extension phase archive [indexC arrayC]) @@ -72,11 +76,13 @@ (phase archive indexC)) arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) (phase archive arrayC)) - _ (analysis/type.inference :read:)] - (in {analysis.#Extension extension (list indexA arrayA)}))))])) + _ (analysis/type.inference :read:) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list indexA arrayA)}]))))])) (def array::write - Handler + (-> Text Handler) (custom [(all <>.and <code>.any <code>.any <code>.any) (function (_ extension phase archive [indexC valueC arrayC]) @@ -91,11 +97,13 @@ (phase archive valueC)) arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) (phase archive arrayC)) - _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] - (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:))) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list indexA valueA arrayA)}]))))])) (def array::delete - Handler + (-> Text Handler) (custom [(all <>.and <code>.any <code>.any) (function (_ extension phase archive [indexC arrayC]) @@ -108,22 +116,22 @@ (phase archive indexC)) arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) (phase archive arrayC)) - _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] - (in {analysis.#Extension extension (list indexA arrayA)}))))])) - -(def bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:))) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list indexA arrayA)}]))))])) + +(def with_array_extensions + (-> Bundle Bundle) + (|>> (/.install "js_array_new#" array::new) + (/.install "js_array_length#" array::length) + (/.install "js_array_read#" array::read) + (/.install "js_array_write#" array::write) + (/.install "js_array_delete#" array::delete) + )) (def object::new - Handler + (-> Text Handler) (custom [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) (function (_ extension phase archive [constructorC inputsC]) @@ -131,23 +139,27 @@ [constructorA (analysis/type.expecting Any (phase archive constructorC)) inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) - _ (analysis/type.inference .Any)] - (in {analysis.#Extension extension (list.partial constructorA inputsA)})))])) + _ (analysis/type.inference .Any) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list.partial constructorA inputsA)}])))])) (def object::get - Handler + (-> Text Handler) (custom [(all <>.and <code>.text <code>.any) (function (_ extension phase archive [fieldC objectC]) (do phase.monad [objectA (analysis/type.expecting Any (phase archive objectC)) - _ (analysis/type.inference .Any)] - (in {analysis.#Extension extension (list (analysis.text fieldC) - objectA)})))])) + _ (analysis/type.inference .Any) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list (analysis.text @ fieldC) + objectA)}])))])) (def object::do - Handler + (-> Text Handler) (custom [(all <>.and <code>.text <code>.any (<code>.tuple (<>.some <code>.any))) (function (_ extension phase archive [methodC objectC inputsC]) @@ -155,35 +167,39 @@ [objectA (analysis/type.expecting Any (phase archive objectC)) inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) - _ (analysis/type.inference .Any)] - (in {analysis.#Extension extension (list.partial (analysis.text methodC) - objectA - inputsA)})))])) - -(def bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "new" object::new) - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "null" (/.nullary Any)) - (bundle.install "null?" (/.unary Any Bit)) - (bundle.install "undefined" (/.nullary Any)) - (bundle.install "undefined?" (/.unary Any Bit)) - ))) + _ (analysis/type.inference .Any) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list.partial (analysis.text @ methodC) + objectA + inputsA)}])))])) + +(def with_object_extensions + (-> Bundle Bundle) + (|>> (/.install "js_object_new#" object::new) + (/.install "js_object_get#" object::get) + (/.install "js_object_do#" object::do) + + (/.install "js_object_null#" (/.nullary Any)) + (/.install "js_object_null?#" (/.unary Any Bit)) + + (/.install "js_object_undefined#" (/.nullary Any)) + (/.install "js_object_undefined?#" (/.unary Any Bit)) + )) (def js::constant - Handler + (-> Text Handler) (custom [<code>.text (function (_ extension phase archive name) (do phase.monad - [_ (analysis/type.inference Any)] - (in {analysis.#Extension extension (list (analysis.text name))})))])) + [_ (analysis/type.inference Any) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list (analysis.text @ name))}])))])) (def js::apply - Handler + (-> Text Handler) (custom [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) (function (_ extension phase archive [abstractionC inputsC]) @@ -191,22 +207,26 @@ [abstractionA (analysis/type.expecting Any (phase archive abstractionC)) inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) - _ (analysis/type.inference Any)] - (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + _ (analysis/type.inference Any) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list.partial abstractionA inputsA)}])))])) (def js::type_of - Handler + (-> Text Handler) (custom [<code>.any (function (_ extension phase archive objectC) (do phase.monad [objectA (analysis/type.expecting Any (phase archive objectC)) - _ (analysis/type.inference .Text)] - (in {analysis.#Extension extension (list objectA)})))])) + _ (analysis/type.inference .Text) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list objectA)}])))])) (def js::function - Handler + (-> Text Handler) (custom [(all <>.and <code>.nat <code>.any) (function (_ extension phase archive [arity abstractionC]) @@ -215,19 +235,20 @@ abstractionA (analysis/type.expecting (-> inputT Any) (phase archive abstractionC)) _ (analysis/type.inference (for @.js ffi.Function - Any))] - (in {analysis.#Extension extension (list (analysis.nat arity) - abstractionA)})))])) + Any)) + @ meta.location] + (in [@ {analysis.#Extension (/.translation extension) + (list (analysis.nat @ arity) + abstractionA)}])))])) (def .public bundle Bundle - (<| (bundle.prefix "js") - (|> bundle.empty - (dictionary.composite bundle::array) - (dictionary.composite bundle::object) - - (bundle.install "constant" js::constant) - (bundle.install "apply" js::apply) - (bundle.install "type-of" js::type_of) - (bundle.install "function" js::function) - ))) + (|> extension.empty + with_array_extensions + with_object_extensions + + (/.install "js_constant#" js::constant) + (/.install "js_apply#" js::apply) + (/.install "js_type_of#" js::type_of) + (/.install "js_function#" js::function) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/common.lux index d8f690b45..3dbaa594b 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/common.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/common.lux @@ -5,11 +5,12 @@ ["[0]" monad (.only do)]] [control ["<>" parser] + ["|" pipe] ["[0]" try]] [data ["[0]" product] [collection - ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" list (.use "[1]#[0]" functor mix)] ["[0]" dictionary]]] [math [number @@ -18,27 +19,41 @@ ["@" target (.only) ["_" js (.only Literal Expression Statement)]] [macro - ["^" pattern]]]]] - ["[0]" //// - ["/" bundle] - ["/[1]" // - ["[0]" extension] - [translation - [extension (.only Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js - ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Translator)] - ["[1][0]" primitive] - ["[1][0]" structure] - ["[1][0]" reference] - ["[1][0]" when] - ["[1][0]" loop] - ["[1][0]" function]]] - [// - ["[0]" synthesis (.only %synthesis) - ["<s>" \\parser (.only Parser)]] - [/// - ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + ["^" pattern]] + [compiler + [meta + [archive (.only Archive)]]]]]] + [///// + ["[0]" extension] + [translation + [extension (.only Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["//" js + ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Translator)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" when] + ["[1][0]" loop] + ["[1][0]" function]]] + [// + ["[0]" synthesis (.only %synthesis) + ["?[1]" \\parser (.only Parser)]] + [/// + ["[0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Phase Archive s (Operation Expression))] + Handler)) + (function (_ phase archive input) + (when (?synthesis.result parser input) + {try.#Success input'} + (handler phase archive input') + + {try.#Failure error} + (phase.failure error)))) ... [Procedures] ... [[Bits]] @@ -67,9 +82,21 @@ (_.apply (_.var "String.fromCharCode")))) ... [[Text]] -(def (text//concat [leftG rightG]) - (Binary Expression) - (|> leftG (_.do "concat" (list rightG)))) +(def text//composite + (Variadic Expression) + (|>> (|.when + (list) + (_.string "") + + (list single) + single + + (list.partial left rights) + ... (|> left (_.do "concat" rights)) + (list#mix (function (_ right left) + (|> left (_.do "concat" (list right)))) + left + rights)))) (def (text//clip [startG endG subjectG]) (Trinary Expression) @@ -90,14 +117,15 @@ Phase! (when synthesis ... TODO: Get rid of this ASAP - {synthesis.#Extension [.prelude "when_char#|translation"] parameters} - (do /////.monad + [@ {synthesis.#Extension [.prelude "when_char#|translation"] parameters}] + (do phase.monad [body (expression archive synthesis)] (in (as Statement body))) (^.with_template [<tag>] - [(<tag> value) - (/////#each _.return (expression archive synthesis))]) + [(<tag> @ value) + (phase#each _.return + (expression archive synthesis))]) ([synthesis.bit] [synthesis.i64] [synthesis.f64] @@ -108,43 +136,44 @@ [synthesis.function/apply]) (^.with_template [<tag>] - [{<tag> value} - (/////#each _.return (expression archive synthesis))]) + [[@ {<tag> value}] + (phase#each _.return + (expression archive synthesis))]) ([synthesis.#Reference] [synthesis.#Extension]) - (synthesis.branch/when when) + (synthesis.branch/when @ when) (//when.when! statement expression archive when) - (synthesis.branch/exec it) + (synthesis.branch/exec @ it) (//when.exec! statement expression archive it) - (synthesis.branch/let let) + (synthesis.branch/let @ let) (//when.let! statement expression archive let) - (synthesis.branch/if if) + (synthesis.branch/if @ if) (//when.if! statement expression archive if) - (synthesis.loop/scope scope) + (synthesis.loop/scope @ scope) (//loop.scope! statement expression archive scope) - (synthesis.loop/again updates) + (synthesis.loop/again @ updates) (//loop.again! statement expression archive updates) - (synthesis.function/abstraction abstraction) - (/////#each _.return (//function.function statement expression archive abstraction)) + (synthesis.function/abstraction @ abstraction) + (phase#each _.return (//function.function statement expression archive abstraction)) )) ... TODO: Get rid of this ASAP (def lux::syntax_char_case! (..custom [(all <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple (all <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do [! /////.monad] + ?synthesis.any + ?synthesis.any + (<>.some (?synthesis.tuple (all <>.and + (?synthesis.tuple (<>.many ?synthesis.i64)) + ?synthesis.any)))) + (function (_ phase archive [input else conditionals]) + (do [! phase.monad] [inputG (phase archive input) else! (..statement phase archive else) conditionals! (is (Operation (List [(List Literal) @@ -167,74 +196,76 @@ {.#Some else!})))))])) ... [Bundles] -(def lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurried _.=))) - (/.install "try" (unary //runtime.lux//try)))) +(def with_basic_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "when_char#|translation" lux::syntax_char_case!) + (dictionary.has "is?#|translation" (binary (product.uncurried _.=))) + (dictionary.has "try#|translation" (unary //runtime.lux//try)))) -(def i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurried //runtime.i64::and))) - (/.install "or" (binary (product.uncurried //runtime.i64::or))) - (/.install "xor" (binary (product.uncurried //runtime.i64::xor))) - (/.install "left-shift" (binary i64::left_shifted)) - (/.install "right-shift" (binary i64::right_shifted)) - (/.install "=" (binary (product.uncurried //runtime.i64::=))) - (/.install "<" (binary (product.uncurried //runtime.i64::<))) - (/.install "+" (binary (product.uncurried //runtime.i64::+))) - (/.install "-" (binary (product.uncurried //runtime.i64::-))) - (/.install "*" (binary (product.uncurried //runtime.i64::*))) - (/.install "/" (binary (product.uncurried //runtime.i64::/))) - (/.install "%" (binary (product.uncurried //runtime.i64::%))) - (/.install "f64" (unary //runtime.i64::number)) - (/.install "char" (unary i64::char)) - ))) - -(def f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurried _.+))) - (/.install "-" (binary (product.uncurried _.-))) - (/.install "*" (binary (product.uncurried _.*))) - (/.install "/" (binary (product.uncurried _./))) - (/.install "%" (binary (product.uncurried _.%))) - (/.install "=" (binary (product.uncurried _.=))) - (/.install "<" (binary (product.uncurried _.<))) - (/.install "i64" (unary //runtime.i64::of_number)) - (/.install "encode" (unary (_.do "toString" (list)))) - (/.install "decode" (unary f64//decode))))) - -(def text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurried _.=))) - (/.install "<" (binary (product.uncurried _.<))) - (/.install "concat" (binary text//concat)) - (/.install "index" (trinary text//index)) - (/.install "size" (unary (|>> (_.the "length") //runtime.i64::of_number))) - (/.install "char" (binary (product.uncurried //runtime.text//char))) - (/.install "clip" (trinary text//clip)) - ))) - -(def io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary io//log)) - (/.install "error" (unary //runtime.io//error))))) +(def with_i64_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "i64_and#|translation" (binary (product.uncurried //runtime.i64::and))) + (dictionary.has "i64_or#|translation" (binary (product.uncurried //runtime.i64::or))) + (dictionary.has "i64_xor#|translation" (binary (product.uncurried //runtime.i64::xor))) + (dictionary.has "i64_left#|translation" (binary i64::left_shifted)) + (dictionary.has "i64_right#|translation" (binary i64::right_shifted)) + (dictionary.has "i64_=#|translation" (binary (product.uncurried //runtime.i64::=))) + (dictionary.has "i64_+#|translation" (binary (product.uncurried //runtime.i64::+))) + (dictionary.has "i64_-#|translation" (binary (product.uncurried //runtime.i64::-))) + )) + +(def with_int_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "int_<#|translation" (binary (product.uncurried //runtime.i64::<))) + + (dictionary.has "int_*#|translation" (binary (product.uncurried //runtime.i64::*))) + (dictionary.has "int_/#|translation" (binary (product.uncurried //runtime.i64::/))) + (dictionary.has "int_%#|translation" (binary (product.uncurried //runtime.i64::%))) + + (dictionary.has "int_f64#|translation" (unary //runtime.i64::number)) + (dictionary.has "int_char#|translation" (unary i64::char)) + )) + +(def with_f64_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "f64_+#|translation" (binary (product.uncurried _.+))) + (dictionary.has "f64_-#|translation" (binary (product.uncurried _.-))) + (dictionary.has "f64_*#|translation" (binary (product.uncurried _.*))) + (dictionary.has "f64_/#|translation" (binary (product.uncurried _./))) + (dictionary.has "f64_%#|translation" (binary (product.uncurried _.%))) + + (dictionary.has "f64_=#|translation" (binary (product.uncurried _.=))) + (dictionary.has "f64_<#|translation" (binary (product.uncurried _.<))) + + (dictionary.has "f64_int#|translation" (unary //runtime.i64::of_number)) + (dictionary.has "f64_encoded#|translation" (unary (_.do "toString" (list)))) + (dictionary.has "f64_decoded#|translation" (unary f64//decode)) + )) + +(def with_text_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "text_=#|translation" (binary (product.uncurried _.=))) + (dictionary.has "text_<#|translation" (binary (product.uncurried _.<))) + + (dictionary.has "text_composite#|translation" (variadic text//composite)) + (dictionary.has "text_index#|translation" (trinary text//index)) + (dictionary.has "text_size#|translation" (unary (|>> (_.the "length") //runtime.i64::of_number))) + (dictionary.has "text_char#|translation" (binary (product.uncurried //runtime.text//char))) + (dictionary.has "text_clip#|translation" (trinary text//clip)) + )) + +(def with_io_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "log!#|translation" (unary io//log)) + (dictionary.has "error#|translation" (unary //runtime.io//error)))) (def .public bundle Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.composite i64_procs) - (dictionary.composite f64_procs) - (dictionary.composite text_procs) - (dictionary.composite io_procs) - ))) + (|> extension.empty + with_basic_extensions + with_i64_extensions + with_int_extensions + with_f64_extensions + with_text_extensions + with_io_extensions + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/host.lux index dc17f8960..0f8fab9bc 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/host.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/translation/js/host.lux @@ -13,62 +13,58 @@ [meta [target ["_" js (.only Var Expression)]]]]] - ["[0]" // - ["[1][0]" common (.only custom)] - ["//[1]" /// - ["/" bundle] - ["/[1]" // - ["[0]" extension] - [translation - [extension (.only Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js - ["[1][0]" runtime (.only Operation Phase Handler Bundle - with_vars)]]] - ["/[1]" // - ["[0]" translation] - [synthesis - ["<s>" \\parser (.only Parser)]] - ["//[1]" /// - ["[1][0]" phase]]]]]]) + [// + [common (.only custom)] + [//// + ["[0]" extension] + [translation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + [js + ["[0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + [// + ["[0]" translation] + [synthesis + ["<s>" \\parser (.only Parser)]] + [/// + ["[0]" phase]]]]]) (def array::new (Unary Expression) - (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array")))) + (|>> (_.the runtime.i64_low_field) list (_.new (_.var "Array")))) (def array::length (Unary Expression) - (|>> (_.the "length") //runtime.i64::of_number)) + (|>> (_.the "length") runtime.i64::of_number)) (def (array::read [indexG arrayG]) (Binary Expression) - (_.at (_.the //runtime.i64_low_field indexG) + (_.at (_.the runtime.i64_low_field indexG) arrayG)) (def (array::write [indexG valueG arrayG]) (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) + (runtime.array//write indexG valueG arrayG)) (def (array::delete [indexG arrayG]) (Binary Expression) - (//runtime.array//delete indexG arrayG)) + (runtime.array//delete indexG arrayG)) -(def array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) +(def with_array_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "js_array_new#|translation" (unary array::new)) + (dictionary.has "js_array_length#|translation" (unary array::length)) + (dictionary.has "js_array_read#|translation" (binary array::read)) + (dictionary.has "js_array_write#|translation" (trinary array::write)) + (dictionary.has "js_array_delete#|translation" (binary array::delete)) + )) (def object::new (custom [(all <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [constructorS inputsS]) - (do [! ////////phase.monad] + (function (_ phase archive [constructorS inputsS]) + (do [! phase.monad] [constructorG (phase archive constructorS) inputsG (monad.each ! (phase archive) inputsS)] (in (_.new constructorG inputsG))))])) @@ -77,8 +73,8 @@ Handler (custom [(all <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad + (function (_ phase archive [fieldS objectS]) + (do phase.monad [objectG (phase archive objectS)] (in (_.the fieldS objectG))))])) @@ -86,8 +82,8 @@ Handler (custom [(all <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do [! ////////phase.monad] + (function (_ phase archive [methodS objectS inputsS]) + (do [! phase.monad] [objectG (phase archive objectS) inputsG (monad.each ! (phase archive) inputsS)] (in (_.do methodS inputsG objectG))))])) @@ -100,30 +96,30 @@ [object::undefined object::undefined? _.undefined] ) -(def object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "new" object::new) - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "null" (nullary object::null)) - (/.install "null?" (unary object::null?)) - (/.install "undefined" (nullary object::undefined)) - (/.install "undefined?" (unary object::undefined?)) - ))) +(def with_object_extensions + (-> Bundle Bundle) + (|>> (dictionary.has "js_object_new#|translation" object::new) + (dictionary.has "js_object_get#|translation" object::get) + (dictionary.has "js_object_do#|translation" object::do) + + (dictionary.has "js_object_null#|translation" (nullary object::null)) + (dictionary.has "js_object_null?#|translation" (unary object::null?)) + + (dictionary.has "js_object_undefined#|translation" (nullary object::undefined)) + (dictionary.has "js_object_undefined?#|translation" (unary object::undefined?)) + )) (def js::constant (custom [<s>.text - (function (_ extension phase archive name) - (at ////////phase.monad in (_.var name)))])) + (function (_ phase archive name) + (at phase.monad in (_.var name)))])) (def js::apply (custom [(all <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do [! ////////phase.monad] + (function (_ phase archive [abstractionS inputsS]) + (do [! phase.monad] [abstractionG (phase archive abstractionS) inputsG (monad.each ! (phase archive) inputsS)] (in (_.apply abstractionG inputsG))))])) @@ -131,8 +127,8 @@ (def js::function (custom [(all <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do [! ////////phase.monad] + (function (_ phase archive [arity abstractionS]) + (do [! phase.monad] [abstractionG (phase archive abstractionS) .let [variable (is (-> Text (Operation Var)) (|>> translation.symbol @@ -144,19 +140,18 @@ (all _.then (_.define g!abstraction abstractionG) (_.return (when (.nat arity) - 0 (_.apply_1 g!abstraction //runtime.unit) + 0 (_.apply_1 g!abstraction runtime.unit) 1 (_.apply g!abstraction g!inputs) _ (_.apply_1 g!abstraction (_.array g!inputs)))))))))])) (def .public bundle Bundle - (<| (/.prefix "js") - (|> /.empty - (dictionary.composite ..array) - (dictionary.composite ..object) - - (/.install "constant" js::constant) - (/.install "apply" js::apply) - (/.install "type-of" (unary _.type_of)) - (/.install "function" js::function) - ))) + (|> extension.empty + with_array_extensions + with_object_extensions + + (dictionary.has "js_constant#|translation" js::constant) + (dictionary.has "js_apply#|translation" js::apply) + (dictionary.has "js_type_of#|translation" (unary _.type_of)) + (dictionary.has "js_function#|translation" js::function) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js.lux index b8e01bea6..cd0145243 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js.lux @@ -35,56 +35,56 @@ (exception.def .public cannot_recur_as_an_expression) -(def (expression archive synthesis) - Phase - (when synthesis - (^.with_template [<tag> <translator>] - [(<tag> value) - (//////phase#in (<translator> value))]) - ([synthesis.bit /primitive.bit] - [synthesis.i64 /primitive.i64] - [synthesis.f64 /primitive.f64] - [synthesis.text /primitive.text]) +(def .public (expression extender lux) + (-> ///extension.Extender Lux + Phase) + (function (expression archive synthesis) + (when synthesis + (^.with_template [<tag> <translator>] + [(<tag> @ value) + (//////phase#in (<translator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) - (synthesis.variant variantS) - (/structure.variant expression archive variantS) + (synthesis.variant @ variantS) + (/structure.variant expression archive variantS) - (synthesis.tuple members) - (/structure.tuple expression archive members) + (synthesis.tuple @ members) + (/structure.tuple expression archive members) - {synthesis.#Reference value} - (//reference.reference /reference.system archive value) + [@ {synthesis.#Reference value}] + (//reference.reference /reference.system archive value) - (synthesis.branch/when when) - (/when.when ///extension/common.statement expression archive when) + (synthesis.branch/when @ when) + (/when.when ///extension/common.statement expression archive when) - (synthesis.branch/exec it) - (/when.exec expression archive it) + (synthesis.branch/exec @ it) + (/when.exec expression archive it) - (synthesis.branch/let let) - (/when.let expression archive let) + (synthesis.branch/let @ let) + (/when.let expression archive let) - (synthesis.branch/if if) - (/when.if expression archive if) + (synthesis.branch/if @ if) + (/when.if expression archive if) - (synthesis.branch/get get) - (/when.get expression archive get) + (synthesis.branch/get @ get) + (/when.get expression archive get) - (synthesis.loop/scope scope) - (/loop.scope ///extension/common.statement expression archive scope) + (synthesis.loop/scope @ scope) + (/loop.scope ///extension/common.statement expression archive scope) - (synthesis.loop/again updates) - (//////phase.except ..cannot_recur_as_an_expression []) + (synthesis.loop/again @ updates) + (//////phase.except ..cannot_recur_as_an_expression []) - (synthesis.function/abstraction abstraction) - (/function.function ///extension/common.statement expression archive abstraction) + (synthesis.function/abstraction @ abstraction) + (/function.function ///extension/common.statement expression archive abstraction) - (synthesis.function/apply application) - (/function.apply expression archive application) + (synthesis.function/apply @ application) + (/function.apply expression archive application) - {synthesis.#Extension extension} - (///extension.apply archive expression extension))) - -(def .public translate - Phase - ..expression) + [@ {synthesis.#Extension [name parameters]}] + (///extension.application extender lux expression archive .Translation false name parameters + (|>>) + (function (_ _) {.#None}))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/function.lux index 6c88699b5..cc88108bb 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/function.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/function.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except function) + [lux (.except Analysis Synthesis function) [abstract ["[0]" monad (.only do)]] [data diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/loop.lux index 8ad637f31..6c3fd4772 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/loop.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/loop.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Scope) + [lux (.except Scope Synthesis) [abstract ["[0]" monad (.only do)]] [data diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/structure.lux index fef967449..32e0a9034 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/structure.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/structure.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except Variant Tuple) + [lux (.except Variant Tuple Synthesis) [abstract ["[0]" monad (.only do)]] [meta diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/when.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/when.lux index 44ea85f03..e7205b9ff 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/when.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/when.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except when exec let if) + [lux (.except Synthesis when exec let if) [abstract ["[0]" monad (.only do)]] [control diff --git a/stdlib/source/library/lux/world/money.lux b/stdlib/source/library/lux/world/money.lux new file mode 100644 index 000000000..33764e812 --- /dev/null +++ b/stdlib/source/library/lux/world/money.lux @@ -0,0 +1,88 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" equivalence (.only Equivalence)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format]]] + [math + [number + ["n" nat]]] + [meta + ["[0]" static] + [type + ["[0]" nominal]]]]] + [/ + ["/" currency]]) + +(nominal.def .public (Money currency) + (Record + [#currency (/.Currency currency) + #amount Nat]) + + (def .public (money currency amount) + (All (_ currency) + (-> (/.Currency currency) Nat + (Money currency))) + (nominal.abstraction + [#currency currency + #amount amount])) + + (with_template [<name> <slot> <type>] + [(def .public <name> + (All (_ currency) + (-> (Money currency) + <type>)) + (|>> nominal.representation + (the <slot>)))] + + [currency #currency (/.Currency currency)] + [amount #amount Nat] + ) + + (def .public equivalence + (All (_ of) + (Equivalence (Money of))) + (at equivalence.functor each + (|>> nominal.representation) + (all product.equivalence + /.equivalence + n.equivalence + ))) + + (def .public (+ parameter subject) + (All (_ currency) + (-> (Money currency) (Money currency) + (Money currency))) + (|> subject + nominal.representation + (revised #amount (n.+ (|> parameter nominal.representation (the #amount)))) + nominal.abstraction)) + + (def .public (- parameter subject) + (All (_ currency) + (-> (Money currency) (Money currency) + (Maybe (Money currency)))) + (let [parameter (nominal.representation parameter) + subject (nominal.representation subject)] + (if (n.< (the #amount parameter) + (the #amount subject)) + {.#None} + {.#Some (nominal.abstraction + [#currency (the #currency subject) + #amount (n.- (the #amount parameter) + (the #amount subject))])}))) + + (def .public (format it) + (All (_ currency) + (%.Format (Money currency))) + (let [[currency amount] (nominal.representation it) + [macro micro] (n./% (/.subdivisions currency) amount)] + (%.format (%.nat macro) + (when micro + 0 "" + _ (%.format "." (%.nat micro))) + " " (/.alphabetic_code currency)))) + ) diff --git a/stdlib/source/library/lux/world/money/currency.lux b/stdlib/source/library/lux/world/money/currency.lux index 93b92be1f..fdb3ef16b 100644 --- a/stdlib/source/library/lux/world/money/currency.lux +++ b/stdlib/source/library/lux/world/money/currency.lux @@ -2,6 +2,14 @@ (.require [library [lux (.except type all try) + [abstract + ["[0]" equivalence (.only Equivalence)]] + [data + ["[0]" product] + ["[0]" text]] + [math + [number + ["n" nat]]] [meta [type ["[0]" nominal]]]]]) @@ -10,16 +18,16 @@ (Record [#alphabetic_code Text #numeric_code Nat - #decimals Nat]) + #subdivisions Nat]) - (def .public (currency [alphabetic_code numeric_code decimals]) + (def .public (currency [alphabetic_code numeric_code subdivisions]) (Ex (_ of) (-> [Text Nat Nat] (Currency of))) (nominal.abstraction [#alphabetic_code alphabetic_code #numeric_code numeric_code - #decimals decimals])) + #subdivisions subdivisions])) (with_template [<name> <slot> <type>] [(def .public <name> @@ -31,8 +39,18 @@ [alphabetic_code #alphabetic_code Text] [numeric_code #numeric_code Nat] - [decimals #decimals Nat] + [subdivisions #subdivisions Nat] ) + + (def .public equivalence + (Equivalence (Currency Any)) + (at equivalence.functor each + (|>> nominal.representation) + (.all product.equivalence + text.equivalence + n.equivalence + n.equivalence + ))) ) (def .public type @@ -47,10 +65,21 @@ _ (undefined))])) +(def (power parameter subject) + (-> Nat Nat + Nat) + (when parameter + 0 1 + _ (|> subject + (power (-- parameter)) + (n.* subject)))) + ... https://en.wikipedia.org/wiki/ISO_4217 (with_template [<short> <type> <alphabetic_code> <numeric_code> <decimals> <long>] [(def .public <short> - (..currency [<alphabetic_code> <numeric_code> <decimals>])) + (..currency [<alphabetic_code> + <numeric_code> + (power <decimals> 10)])) (def .public <type> Type diff --git a/stdlib/source/library/lux/world/time/instant.lux b/stdlib/source/library/lux/world/time/instant.lux index 5f25e1d50..eb50f13e5 100644 --- a/stdlib/source/library/lux/world/time/instant.lux +++ b/stdlib/source/library/lux/world/time/instant.lux @@ -163,8 +163,8 @@ .jvm_object_cast# (is (Nominal "java.lang.Long")) (as Int)) - @.js (let [date ("js object new" ("js constant" "Date") [])] - (|> ("js object do" "getTime" date []) + @.js (let [date (.js_object_new# (.js_constant# "Date") [])] + (|> (.js_object_do# "getTime" date []) (as Frac) .f64_int#)) @.python (let [time (.python_import# "time")] |