diff options
Diffstat (limited to 'stdlib/source')
32 files changed, 789 insertions, 464 deletions
diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux index 62e88645a..432e98abd 100644 --- a/stdlib/source/lux/data/collection/list.lux +++ b/stdlib/source/lux/data/collection/list.lux @@ -316,16 +316,11 @@ (def: &equivalence (..equivalence (\ super &equivalence))) - (def: (hash value) - (case value - #.Nil - 2 - - (#.Cons head tail) - ($_ n.* 3 - (n.+ (\ super hash head) - (hash tail))) - ))) + (def: hash + (\ ..fold fold + (function (_ member hash) + (n.+ (\ super hash member) hash)) + 0))) (structure: #export monoid (All [a] (Monoid (List a))) @@ -333,8 +328,11 @@ (def: identity #.Nil) (def: (compose xs ys) (case xs - #.Nil ys - (#.Cons x xs') (#.Cons x (compose xs' ys))))) + #.Nil + ys + + (#.Cons x xs') + (#.Cons x (compose xs' ys))))) (open: "." ..monoid) @@ -343,8 +341,11 @@ (def: (map f ma) (case ma - #.Nil #.Nil - (#.Cons a ma') (#.Cons (f a) (map f ma'))))) + #.Nil + #.Nil + + (#.Cons a ma') + (#.Cons (f a) (map f ma'))))) (open: "." ..functor) @@ -389,15 +390,21 @@ (def: #export (empty? xs) (All [a] (Predicate (List a))) (case xs - #.Nil true - _ false)) + #.Nil + true + + _ + false)) (def: #export (member? eq xs x) (All [a] (-> (Equivalence a) (List a) a Bit)) (case xs - #.Nil #0 - (#.Cons x' xs') (or (\ eq = x x') - (member? eq xs' x)))) + #.Nil + #0 + + (#.Cons x' xs') + (or (\ eq = x x') + (member? eq xs' x)))) (template [<name> <output> <side> <doc>] [(def: #export (<name> xs) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux index d0341b402..ca95a7a4b 100644 --- a/stdlib/source/lux/data/collection/set.lux +++ b/stdlib/source/lux/data/collection/set.lux @@ -2,16 +2,17 @@ [lux #* [abstract [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [predicate (#+ Predicate)] - [monoid (#+ Monoid)] - ["." hash (#+ Hash)]] + [monoid (#+ Monoid)]] [data [collection - ["//" dictionary (#+ Dictionary)] ["." list ("#\." fold)]]] [math [number - ["n" nat]]]]) + ["n" nat]]]] + ["." // #_ + ["#" dictionary (#+ Dictionary)]]) (type: #export (Set a) (Dictionary a Any)) @@ -71,10 +72,10 @@ (def: &equivalence ..equivalence) - (def: (hash (^@ set [hash _])) - (list\fold (function (_ elem acc) (n.+ (\ hash hash elem) acc)) - 0 - (..to_list set)))) + (def: (hash set) + (|> set + ..to_list + (\ (list.hash (..member_hash set)) hash)))) (structure: #export (monoid hash) (All [a] (-> (Hash a) (Monoid (Set a)))) diff --git a/stdlib/source/lux/data/collection/set/multi.lux b/stdlib/source/lux/data/collection/set/multi.lux index fe5b2b8cb..6fd3a4671 100644 --- a/stdlib/source/lux/data/collection/set/multi.lux +++ b/stdlib/source/lux/data/collection/set/multi.lux @@ -130,7 +130,7 @@ (def: (hash (^:representation set)) (let [[hash _] set] (list\fold (function (_ [elem multiplicity] acc) - (|> elem (\ hash hash) (n.+ multiplicity) (n.+ acc))) + (|> elem (\ hash hash) (n.* multiplicity) (n.+ acc))) 0 (dictionary.entries set))))) ) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux index 6584eaf6a..a5a51300f 100644 --- a/stdlib/source/lux/data/maybe.lux +++ b/stdlib/source/lux/data/maybe.lux @@ -87,10 +87,10 @@ (def: (hash value) (case value #.None - 2 + 0 (#.Some value) - (.nat ("lux i64 *" (.int 3) (.int (\ super hash value))))))) + (\ super hash value)))) (structure: #export (with monad) (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux index 0d95d6e9e..2fc846e18 100644 --- a/stdlib/source/lux/host.old.lux +++ b/stdlib/source/lux/host.old.lux @@ -1634,25 +1634,29 @@ [=args (member_def_arg_bindings type_params class member)] (member_def_interop type_params kind class =args member method_prefix import_format)))) -(def: (interface? class) - (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) - ("jvm invokevirtual:java.lang.Class:isInterface:" class)) +(type: (java/lang/Class a) + (primitive "java.lang.Class" [a])) + +(def: interface? + (All [a] (-> (java/lang/Class a) Bit)) + (|>> "jvm invokevirtual:java.lang.Class:isInterface:")) (def: (load_class class_name) - (-> Text (Try (primitive "java.lang.Class" [Any]))) - (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) + (-> Text (Try (java/lang/Class Any))) + (..try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) (def: (class_kind [class_name _]) (-> Class_Declaration (Meta Class_Kind)) - (let [class_name (sanitize class_name)] - (case (load_class class_name) - (#.Right class) + (let [class_name (..sanitize class_name)] + (case (..load_class class_name) + (#try.Success class) (\ meta.monad wrap (if (interface? class) #Interface #Class)) - (#.Left _) - (meta.fail (format "Unknown class: " class_name))))) + (#try.Failure error) + (meta.fail (format "Cannot load class: " class_name text.new_line + error))))) (syntax: #export (import: {class_decl ..class_decl^} diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux index e081280be..36a2294a2 100644 --- a/stdlib/source/lux/meta.lux +++ b/stdlib/source/lux/meta.lux @@ -12,7 +12,9 @@ ["." text ("#\." monoid equivalence)] ["." name ("#\." codec equivalence)] [collection - ["." list ("#\." monoid monad)]]] + ["." list ("#\." monoid monad)] + [dictionary + ["." plist]]]] [macro ["." code]] [math @@ -74,18 +76,6 @@ (#try.Success [compiler' ma]) (ma compiler'))))) -(def: (get k plist) - (All [a] - (-> Text (List [Text a]) (Maybe a))) - (case plist - #.Nil - #.None - - (#.Cons [k' v] plist') - (if (text\= k k') - (#.Some v) - (get k plist')))) - (def: #export (run' compiler action) (All [a] (-> Lux (Meta a) (Try [Lux a]))) (action compiler)) @@ -128,7 +118,7 @@ (def: #export (find_module name) (-> Text (Meta Module)) (function (_ compiler) - (case (get name (get@ #.modules compiler)) + (case (plist.get name (get@ #.modules compiler)) (#.Some module) (#try.Success [compiler module]) @@ -178,11 +168,11 @@ (-> (List [Text Module]) Text Text Text (Maybe Macro)) (do maybe.monad - [$module (get module modules) + [$module (plist.get module modules) definition (: (Maybe Global) (|> (: Module $module) (get@ #.definitions) - (get name)))] + (plist.get name)))] (case definition (#.Alias [r_module r_name]) (find_macro' modules this_module r_module r_name) @@ -215,7 +205,7 @@ (def: #export (module_exists? module) (-> Text (Meta Bit)) (function (_ compiler) - (#try.Success [compiler (case (get module (get@ #.modules compiler)) + (#try.Success [compiler (case (plist.get module (get@ #.modules compiler)) (#.Some _) #1 @@ -286,13 +276,15 @@ {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."} (-> Name (Meta Global)) (do ..monad - [name (normalize name)] + [name (normalize name) + #let [[normal_module normal_short] name]] (function (_ compiler) (case (: (Maybe Global) (do maybe.monad - [#let [[v_prefix v_name] name] - (^slots [#.definitions]) (get v_prefix (get@ #.modules compiler))] - (get v_name definitions))) + [(^slots [#.definitions]) (|> compiler + (get@ #.modules) + (plist.get normal_module))] + (plist.get normal_short definitions))) (#.Some definition) (#try.Success [compiler definition]) @@ -302,15 +294,39 @@ (#try.Failure ($_ text\compose "Unknown definition: " (name\encode name) text.new_line " Current module: " current_module text.new_line - (case (get current_module (get@ #.modules compiler)) + (case (plist.get current_module (get@ #.modules compiler)) (#.Some this_module) - ($_ text\compose - " Imports: " (|> this_module (get@ #.imports) (text.join_with separator)) text.new_line - " Aliases: " (|> this_module (get@ #.module_aliases) (list\map (function (_ [alias real]) ($_ text\compose alias " => " real))) (text.join_with separator)) text.new_line) + (let [candidates (|> compiler + (get@ #.modules) + (list\map (function (_ [module_name module]) + (|> module + (get@ #.definitions) + (list.all (function (_ [def_name global]) + (case global + (#.Definition _) + (if (text\= normal_short def_name) + (#.Some (name\encode [module_name def_name])) + #.None) + + (#.Alias _) + #.None)))))) + list.concat + (text.join_with separator)) + imports (|> this_module + (get@ #.imports) + (text.join_with separator)) + aliases (|> this_module + (get@ #.module_aliases) + (list\map (function (_ [alias real]) ($_ text\compose alias " => " real))) + (text.join_with separator))] + ($_ text\compose + " Candidates: " candidates text.new_line + " Imports: " imports text.new_line + " Aliases: " aliases text.new_line)) _ "") - " All Known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line))))))) + " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line))))))) (def: #export (find_export name) {#.doc "Looks-up a definition's type in the available modules (including the current one)."} @@ -376,7 +392,7 @@ {#.doc "The entire list of globals in a module (including the non-exported/private ones)."} (-> Text (Meta (List [Text Global]))) (function (_ compiler) - (case (get module (get@ #.modules compiler)) + (case (plist.get module (get@ #.modules compiler)) #.None (#try.Failure ($_ text\compose "Unknown module: " module)) @@ -422,7 +438,7 @@ (do ..monad [#let [[module name] type_name] module (find_module module)] - (case (get name (get@ #.types module)) + (case (plist.get name (get@ #.types module)) (#.Some [tags _]) (wrap (#.Some tags)) @@ -473,7 +489,7 @@ =module (..find_module module) this_module_name ..current_module_name imported! (..imported? module)] - (case (get name (get@ #.tags =module)) + (case (plist.get name (get@ #.tags =module)) (#.Some [idx tag_list exported? type]) (if (or (text\= this_module_name module) (and imported! exported?)) diff --git a/stdlib/source/lux/target/python.lux b/stdlib/source/lux/target/python.lux index b71947d0b..3f0211e33 100644 --- a/stdlib/source/lux/target/python.lux +++ b/stdlib/source/lux/target/python.lux @@ -1,15 +1,12 @@ (.module: - [lux (#- Code not or and list if cond int comment) + [lux (#- Location Code not or and list if cond int comment) [abstract ["." enum]] [control [pipe (#+ new> case> cond>)] [parser - ["s" code]]] + ["<.>" code]]] [data - [number - ["n" nat] - ["f" frac]] ["." text ["%" format (#+ format)]] [collection @@ -18,15 +15,21 @@ ["." template] ["." code] [syntax (#+ syntax:)]] + [math + [number + ["n" nat] + ["f" frac]]] [type abstract]]) -(def: expression (-> Text Text) (text.enclose ["(" ")"])) +(def: expression + (-> Text Text) + (text.enclose ["(" ")"])) (def: nest (-> Text Text) - (|>> (format text.new-line) - (text.replace-all text.new-line (format text.new-line text.tab)))) + (|>> (format text.new_line) + (text.replace_all text.new_line (format text.new_line text.tab)))) (abstract: #export (Code brand) Text @@ -40,7 +43,7 @@ (|>> :representation)) (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] + [(with_expansions [<brand> (template.identifier [<type> "'"])] (`` (abstract: #export (<brand> brand) Any)) (`` (type: #export (<type> brand) (<super> (<brand> brand)))))] @@ -53,7 +56,7 @@ ) (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] + [(with_expansions [<brand> (template.identifier [<type> "'"])] (`` (abstract: #export <brand> Any)) (`` (type: #export <type> (<super> <brand>))))] @@ -108,11 +111,11 @@ (-> Frac Literal) (`` (|>> (cond> (~~ (template [<lux> <python>] [[(f.= <lux>)] - [(new> (format "float(" text.double-quote <python> text.double-quote ")") [])]] + [(new> (format "float(" text.double_quote <python> text.double_quote ")") [])]] - [f.positive-infinity "inf"] - [f.negative-infinity "-inf"] - [f.not-a-number "nan"] + [f.positive_infinity "inf"] + [f.negative_infinity "-inf"] + [f.not_a_number "nan"] )) ## else @@ -122,43 +125,43 @@ (def: sanitize (-> Text Text) (`` (|>> (~~ (template [<find> <replace>] - [(text.replace-all <find> <replace>)] + [(text.replace_all <find> <replace>)] ["\" "\\"] [text.tab "\t"] - [text.vertical-tab "\v"] + [text.vertical_tab "\v"] [text.null "\0"] - [text.back-space "\b"] - [text.form-feed "\f"] - [text.new-line "\n"] - [text.carriage-return "\r"] - [text.double-quote (format "\" text.double-quote)] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] )) ))) (def: #export string (-> Text Literal) (|>> ..sanitize - (text.enclose [text.double-quote text.double-quote]) + (text.enclose [text.double_quote text.double_quote]) :abstraction)) - (def: (composite-literal left-delimiter right-delimiter entry-serializer) + (def: (composite_literal left_delimiter right_delimiter entry_serializer) (All [a] (-> Text Text (-> a Text) (-> (List a) Literal))) (function (_ entries) (<| :abstraction ..expression - (format left-delimiter + (format left_delimiter (|> entries - (list\map entry-serializer) - (text.join-with ", ")) - right-delimiter)))) + (list\map entry_serializer) + (text.join_with ", ")) + right_delimiter)))) (template [<name> <pre> <post>] [(def: #export <name> (-> (List (Expression Any)) Literal) - (composite-literal <pre> <post> ..code))] + (composite_literal <pre> <post> ..code))] [tuple "(" ")"] [list "[" "]"] @@ -170,7 +173,7 @@ ..expression (format (:representation list) "[" (:representation from) ":" (:representation to) "]"))) - (def: #export (slice-from from list) + (def: #export (slice_from from list) (-> (Expression Any) (Expression Any) Access) (<| :abstraction ..expression @@ -178,21 +181,21 @@ (def: #export dict (-> (List [(Expression Any) (Expression Any)]) (Computation Any)) - (composite-literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v))))) + (composite_literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v))))) (def: #export (apply/* func args) (-> (Expression Any) (List (Expression Any)) (Computation Any)) (<| :abstraction ..expression - (format (:representation func) "(" (text.join-with ", " (list\map ..code args)) ")"))) + (format (:representation func) "(" (text.join_with ", " (list\map ..code args)) ")"))) (template [<name> <brand> <prefix>] [(def: (<name> var) (-> (Expression Any) Text) (format <prefix> (:representation var)))] - [splat-poly Poly "*"] - [splat-keyword Keyword "**"] + [splat_poly Poly "*"] + [splat_keyword Keyword "**"] ) (template [<name> <splat>] @@ -203,11 +206,11 @@ (format (:representation func) (format "(" (|> args (list\map (function (_ arg) (format (:representation arg) ", "))) - (text.join-with "")) + (text.join_with "")) (<splat> extra) ")"))))] - [apply-poly splat-poly] - [apply-keyword splat-keyword] + [apply_poly splat_poly] + [apply_keyword splat_keyword] ) (def: #export (the name object) @@ -224,8 +227,8 @@ (-> (Expression Any) (Computation Any))) (|>> (..the method) (<apply> args extra)))] - [do-poly apply-poly] - [do-keyword apply-keyword] + [do_poly apply_poly] + [do_keyword apply_keyword] ) (def: #export (nth idx array) @@ -257,11 +260,11 @@ [/ "/"] [% "%"] [** "**"] - [bit-or "|"] - [bit-and "&"] - [bit-xor "^"] - [bit-shl "<<"] - [bit-shr ">>"] + [bit_or "|"] + [bit_and "&"] + [bit_xor "^"] + [bit_shl "<<"] + [bit_shr ">>"] [or "or"] [and "and"] @@ -277,13 +280,13 @@ (-> (List (Var Any)) (Expression Any) (Computation Any)) (<| :abstraction ..expression - (format "lambda " (|> arguments (list\map ..code) (text.join-with ", ")) ": " + (format "lambda " (|> arguments (list\map ..code) (text.join_with ", ")) ": " (:representation body)))) (def: #export (set vars value) (-> (List (Location Any)) (Expression Any) (Statement Any)) (:abstraction - (format (|> vars (list\map ..code) (text.join-with ", ")) + (format (|> vars (list\map ..code) (text.join_with ", ")) " = " (:representation value)))) @@ -296,7 +299,7 @@ (:abstraction (format "if " (:representation test) ":" (..nest (:representation then!)) - text.new-line "else:" + text.new_line "else:" (..nest (:representation else!))))) (def: #export (when test then!) @@ -309,7 +312,7 @@ (-> (Statement Any) (Statement Any) (Statement Any)) (:abstraction (format (:representation pre!) - text.new-line + text.new_line (:representation post!)))) (template [<keyword> <0>] @@ -327,7 +330,7 @@ (format "while " (:representation test) ":" (..nest (:representation body!))))) - (def: #export (for-in var inputs body!) + (def: #export (for_in var inputs body!) (-> SVar (Expression Any) (Statement Any) Loop) (:abstraction (format "for " (:representation var) " in " (:representation inputs) ":" @@ -353,10 +356,10 @@ (..nest (:representation body!)) (|> excepts (list\map (function (_ [classes exception catch!]) - (format text.new-line "except (" (text.join-with ", " (list\map ..code classes)) + (format text.new_line "except (" (text.join_with ", " (list\map ..code classes)) ") as " (:representation exception) ":" (..nest (:representation catch!))))) - (text.join-with ""))))) + (text.join_with ""))))) (template [<name> <keyword>] [(def: #export (<name> message) @@ -373,16 +376,16 @@ (-> SVar (List (Ex [k] (Var k))) (Statement Any) (Statement Any)) (:abstraction (format "def " (:representation name) - "(" (|> args (list\map ..code) (text.join-with ", ")) "):" + "(" (|> args (list\map ..code) (text.join_with ", ")) "):" (..nest (:representation body))))) - (def: #export (import module-name) + (def: #export (import module_name) (-> Text (Statement Any)) - (:abstraction (format "import " module-name))) + (:abstraction (format "import " module_name))) (def: #export (comment commentary on) (All [brand] (-> Text (Code brand) (Code brand))) - (:abstraction (format "# " (..sanitize commentary) text.new-line + (:abstraction (format "# " (..sanitize commentary) text.new_line (:representation on)))) ) @@ -393,20 +396,20 @@ else! (list.reverse clauses))) -(syntax: (arity-inputs {arity s.nat}) +(syntax: (arity_inputs {arity <code>.nat}) (wrap (case arity 0 (.list) _ (|> (dec arity) (enum.range n.enum 0) - (list\map (|>> %.nat code.local-identifier)))))) + (list\map (|>> %.nat code.local_identifier)))))) -(syntax: (arity-types {arity s.nat}) +(syntax: (arity_types {arity <code>.nat}) (wrap (list.repeat arity (` (Expression Any))))) (template [<arity> <function>+] - [(with-expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity-inputs <arity>) - <types> (arity-types <arity>) + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) <definitions> (template.splice <function>+)] (def: #export (<apply> function <inputs>) (-> (Expression Any) <types> (Computation Any)) diff --git a/stdlib/source/lux/time/month.lux b/stdlib/source/lux/time/month.lux index ba0408e34..60d66ce28 100644 --- a/stdlib/source/lux/time/month.lux +++ b/stdlib/source/lux/time/month.lux @@ -2,6 +2,7 @@ [lux #* [abstract [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [order (#+ Order)] [enum (#+ Enum)]] [control @@ -70,7 +71,11 @@ (exception: #export (invalid_month {number Nat}) (exception.report - ["Number" (\ n.decimal encode number)])) + ["Number" (\ n.decimal encode number)] + ["Valid range" ($_ "lux text concat" + (\ n.decimal encode (..number #January)) + " ~ " + (\ n.decimal encode (..number #December)))])) (def: #export (by_number number) (-> Nat (Try Month)) @@ -81,6 +86,12 @@ _ (exception.throw ..invalid_month [number]))) ) +(structure: #export hash + (Hash Month) + + (def: &equivalence ..equivalence) + (def: hash ..number)) + (structure: #export order (Order Month) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux index 536416b9d..6c09e4123 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux @@ -1,8 +1,5 @@ (.module: - [lux #* - [data - [collection - ["." dictionary]]]] + [lux #*] ["." / #_ ["#." common] [//// diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux index 1c58fec4c..14cc5f338 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux @@ -6,10 +6,11 @@ ["." function]] [data ["." product] - [number - ["f" frac]] [collection ["." dictionary]]] + [math + [number + ["f" frac]]] [target ["_" python (#+ Expression)]]] [//// @@ -21,39 +22,34 @@ ["//" python #_ ["#." runtime (#+ Operation Phase Handler Bundle)]]]]]) -(def: lux-procs +(def: lux_procs Bundle (|> /.empty (/.install "is" (binary (product.uncurry _.is))) (/.install "try" (unary //runtime.lux//try)))) -(def: i64-procs +(def: i64_procs Bundle (<| (/.prefix "i64") (|> /.empty - (/.install "and" (binary (product.uncurry _.bit-and))) - (/.install "or" (binary (product.uncurry _.bit-or))) - (/.install "xor" (binary (product.uncurry _.bit-xor))) - (/.install "left-shift" (binary (function.compose //runtime.i64//64 (product.uncurry _.bit-shl)))) - (/.install "logical-right-shift" (binary (product.uncurry //runtime.i64//logic-right-shift))) - (/.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (/.install "and" (binary (product.uncurry _.bit_and))) + (/.install "or" (binary (product.uncurry _.bit_or))) + (/.install "xor" (binary (product.uncurry _.bit_xor))) + (/.install "left-shift" (binary (function.compose //runtime.i64//64 (product.uncurry _.bit_shl)))) + (/.install "logical-right-shift" (binary (product.uncurry //runtime.i64//logic_right_shift))) + (/.install "arithmetic-right-shift" (binary (product.uncurry _.bit_shr))) + (/.install "<" (binary (product.uncurry _.<))) (/.install "=" (binary (product.uncurry _.=))) (/.install "+" (binary (product.uncurry _.+))) (/.install "-" (binary (product.uncurry _.-))) - ))) - -(def: int-procs - Bundle - (<| (/.prefix "int") - (|> /.empty - (/.install "<" (binary (product.uncurry _.<))) (/.install "*" (binary (product.uncurry _.*))) (/.install "/" (binary (product.uncurry _./))) (/.install "%" (binary (product.uncurry _.%))) - (/.install "frac" (unary _.float/1)) - (/.install "char" (unary _.chr/1))))) + (/.install "f64" (unary _.float/1)) + (/.install "char" (unary _.chr/1)) + ))) -(def: frac-procs +(def: frac_procs Bundle (<| (/.prefix "frac") (|> /.empty @@ -76,7 +72,7 @@ (Trinary (Expression Any)) (//runtime.text//index textO partO startO)) -(def: text-procs +(def: text_procs Bundle (<| (/.prefix "text") (|> /.empty @@ -89,22 +85,21 @@ (/.install "clip" (trinary text//clip)) ))) -(def: io-procs +(def: io_procs Bundle (<| (/.prefix "io") (|> /.empty (/.install "log" (unary //runtime.io//log!)) (/.install "error" (unary //runtime.io//throw!)) (/.install "exit" (unary //runtime.io//exit!)) - (/.install "current-time" (nullary (function.constant (//runtime.io//current-time! //runtime.unit))))))) + (/.install "current-time" (nullary (function.constant (//runtime.io//current_time! //runtime.unit))))))) (def: #export bundle Bundle (<| (/.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge int-procs) - (dictionary.merge frac-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) + (|> lux_procs + (dictionary.merge i64_procs) + (dictionary.merge frac_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux index b8dbfc4ce..02197dc02 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -10,7 +10,7 @@ [runtime (#+ Phase Phase!)] ["#." primitive] ["#." structure] - ["#." reference ("#\." system)] + ["#." reference] ["#." case] ["#." loop] ["#." function] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux index 3a828bbb9..4ba85c9b5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -41,6 +41,7 @@ (do ///////phase.monad [valueO (generate archive valueS) bodyO (generate archive bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. (wrap (_.apply/* (_.closure (list (..register register)) (_.return bodyO)) (list valueO))))) @@ -258,7 +259,7 @@ (#.Cons cons))] (wrap (_.cond clauses ..fail_pm!))) - (^template [<tag> <format> <type>] + (^template [<tag> <format>] [(<tag> cons) (do {! ///////phase.monad} [cases (monad.map ! (function (_ [match then]) @@ -267,8 +268,8 @@ (wrap (_.switch ..peek_cursor cases (#.Some ..fail_pm!))))]) - ([#/////synthesis.F64_Fork //primitive.f64 Frac] - [#/////synthesis.Text_Fork //primitive.text Text]) + ([#/////synthesis.F64_Fork //primitive.f64] + [#/////synthesis.Text_Fork //primitive.text]) (#/////synthesis.Then bodyS) (statement expression archive bodyS) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux index 0d47e9fe8..89fd86bb6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -2,8 +2,6 @@ [lux (#- function) [abstract ["." monad (#+ do)]] - [control - pipe] [data ["." product] [text @@ -24,9 +22,9 @@ ["#." generation (#+ Context)] ["//#" /// #_ [arity (#+ Arity)] + ["#." phase ("#\." monad)] [reference - [variable (#+ Register Variable)]] - ["#." phase ("#\." monad)]]]]]) + [variable (#+ Register Variable)]]]]]]) (def: #export (apply generate archive [functionS argsS+]) (Generator (Application Synthesis)) @@ -51,12 +49,14 @@ (_.return (_.function @self (list) function_body))) (_.apply/* @self inits)]))) -(def: @curried (_.var "curried")) +(def: @curried + (_.var "curried")) (def: input (|>> inc //case.register)) -(def: @@arguments (_.var "arguments")) +(def: @@arguments + (_.var "arguments")) (def: (@scope function_name) (-> Context Text) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index a6cc85b10..c0f697584 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -5,8 +5,8 @@ ["." monad (#+ do)]] [control ["." function] - ["p" parser - ["s" code]]] + ["<>" parser + ["<.>" code]]] [data ["." product] ["." text ("#\." hash) @@ -32,7 +32,7 @@ ["#." reference] ["//#" /// #_ ["#." synthesis (#+ Synthesis)] - ["#." generation (#+ Buffer)] + ["#." generation] ["//#" /// (#+ Output) ["#." phase] [reference @@ -73,7 +73,9 @@ (let [mask (dec (i64.left_shift 32 1))] (|>> (i64.and mask)))) -(def: #export unit Computation (_.string /////synthesis.unit)) +(def: #export unit + Computation + (_.string /////synthesis.unit)) (def: #export (flag value) (-> Bit Computation) @@ -85,7 +87,7 @@ (-> Var (-> Var Expression) Statement) (_.define name (definition name))) -(syntax: #export (with_vars {vars (s.tuple (p.some s.local_identifier))} +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} body) (do {! meta.monad} [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] @@ -105,9 +107,9 @@ [(` (_.var (~ (code.text identifier)))) (code.local_identifier identifier)])) -(syntax: (runtime: {declaration (p.or s.local_identifier - (s.form (p.and s.local_identifier - (p.some s.local_identifier))))} +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} code) (case declaration (#.Left name) @@ -786,7 +788,7 @@ (def: #export artifact Text - prefix) + ..prefix) (def: #export generate (Operation [Registry Output]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux index d7e02b980..93300a02d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux @@ -6,16 +6,20 @@ [runtime (#+ Phase)] ["#." primitive] ["#." structure] - ["#." reference ("#\." system)] + ["#." reference] ["#." function] ["#." case] ["#." loop] - ["//#" /// #_ - ["#." extension] + ["/#" // #_ + ["#." reference] ["/#" // #_ - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]]) + ["#." extension] + ["/#" // #_ + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) (def: #export (generate archive synthesis) Phase @@ -35,7 +39,7 @@ (/structure.tuple generate archive members) (#////synthesis.Reference value) - (/reference\reference archive value) + (//reference.reference /reference.system archive value) (^ (////synthesis.branch/case case)) (/case.case generate archive case) @@ -46,6 +50,9 @@ (^ (////synthesis.branch/if if)) (/case.if generate archive if) + (^ (////synthesis.branch/get get)) + (/case.get generate archive get) + (^ (////synthesis.loop/scope scope)) (/loop.scope generate archive scope) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux index 4d5fc7f06..36700cf0c 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux @@ -1,22 +1,24 @@ (.module: [lux (#- case let if) [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control - ["ex" exception (#+ exception:)]] + [exception (#+ exception:)]] [data ["." text ["%" format (#+ format)]] - [number - ["n" nat] - ["i" int]] [collection ["." list ("#\." functor fold)] ["." set]]] + [math + [number + ["n" nat] + ["i" int]]] [target ["_" python (#+ Expression SVar Statement)]]] ["." // #_ ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] ["#." primitive] ["/#" // #_ ["#." reference] @@ -24,19 +26,22 @@ [synthesis ["." case]] ["/#" // #_ - ["#." synthesis (#+ Synthesis Path)] + ["#." synthesis (#+ Member Synthesis Path)] ["#." generation] ["//#" /// #_ - ["#." reference (#+ Register)] + [reference + ["#." variable (#+ Register)]] ["#." phase ("#\." monad)] [meta [archive (#+ Archive)]]]]]]]) (def: #export register - (///reference.local _.var)) + (-> Register SVar) + (|>> (///reference.local //reference.system) :assume)) (def: #export capture - (///reference.foreign _.var)) + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) (def: #export (let generate archive [valueS register bodyS]) (Generator [Synthesis Register Synthesis]) @@ -48,8 +53,16 @@ bodyO) (list valueO))))) -(def: #export (record-get generate archive [valueS pathP]) - (Generator [Synthesis (List (Either Nat Nat))]) +(def: #export (if generate archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (generate archive testS) + thenO (generate archive thenS) + elseO (generate archive elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: #export (get generate archive [pathP valueS]) + (Generator [(List Member) Synthesis]) (do ///////phase.monad [valueO (generate archive valueS)] (wrap (list\fold (function (_ side source) @@ -63,14 +76,6 @@ valueO pathP)))) -(def: #export (if generate archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (generate archive testS) - thenO (generate archive thenS) - elseO (generate archive elseS)] - (wrap (_.? testO thenO elseO)))) - (def: @savepoint (_.var "lux_pm_savepoint")) (def: @cursor (_.var "lux_pm_cursor")) (def: @temp (_.var "lux_pm_temp")) @@ -79,13 +84,13 @@ (-> (Expression Any) (Statement Any)) (_.statement (|> @cursor (_.do "append" (list value))))) -(def: peek-and-pop +(def: peek_and_pop (Expression Any) (|> @cursor (_.do "pop" (list)))) (def: pop! (Statement Any) - (_.statement ..peek-and-pop)) + (_.statement ..peek_and_pop)) (def: peek (Expression Any) @@ -93,18 +98,18 @@ (def: save! (Statement Any) - (.let [cursor (_.slice-from (_.int +0) @cursor)] + (.let [cursor (_.slice_from (_.int +0) @cursor)] (_.statement (|> @savepoint (_.do "append" (list cursor)))))) (def: restore! (Statement Any) (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) -(def: fail-pm! _.break) +(def: fail_pm! _.break) -(def: (multi-pop! pops) +(def: (multi_pop! pops) (-> Nat (Statement Any)) - (_.delete (_.slice-from (_.int (i.* -1 (.int pops))) @cursor))) + (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor))) (template [<name> <flag> <prep>] [(def: (<name> simple? idx) @@ -113,14 +118,14 @@ (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) (.if simple? (_.when (_.= _.none @temp) - fail-pm!) + fail_pm!) (_.if (_.= _.none @temp) - fail-pm! + fail_pm! (..push! @temp)) )))] - [left-choice _.none (<|)] - [right-choice (_.string "") inc] + [left_choice _.none (<|)] + [right_choice (_.string "") inc] ) (def: (alternation pre! post!) @@ -134,79 +139,114 @@ ..restore! post!))) -(def: (pattern-matching' generate archive pathP) +(def: (pattern_matching' generate archive) (-> Phase Archive Path (Operation (Statement Any))) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (///////phase\map _.return (generate archive bodyS)) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set (list (..register register)) ..peek)) - - (^template [<tag> <format>] - [(^ (<tag> value)) - (///////phase\wrap (_.when (|> value <format> (_.= ..peek) _.not) - fail-pm!))]) - ([/////synthesis.path/bit //primitive.bit] - [/////synthesis.path/i64 //primitive.i64] - [/////synthesis.path/f64 //primitive.f64] - [/////synthesis.path/text //primitive.text]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - (pattern-matching' generate archive) - (///////phase\map (_.then (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] - [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind-top register thenP)) - (do ///////phase.monad - [then! (pattern-matching' generate archive thenP)] - (///////phase\wrap ($_ _.then - (_.set (list (..register register)) ..peek-and-pop) - then!))) - - (^ (/////synthesis.!multi-pop nextP)) - (.let [[extra-pops nextP'] (case.count-pops nextP)] + (function (recur pathP) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (///////phase\map _.return (generate archive bodyS)) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set (list (..register register)) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail_pm!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (#/////synthesis.I64_Fork cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(_.= (//primitive.i64 (.int match)) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses + ..fail_pm!))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (\ ! map + (|>> [(_.= (<format> match) + ..peek)]) + (recur then))) + (#.Cons cons))] + (wrap (_.cond clauses + ..fail_pm!)))]) + ([#/////synthesis.F64_Fork //primitive.f64] + [#/////synthesis.Text_Fork //primitive.text]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (///////phase\map (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) (do ///////phase.monad - [next! (pattern-matching' generate archive nextP')] + [then! (recur thenP)] (///////phase\wrap ($_ _.then - (..multi-pop! (n.+ 2 extra-pops)) - next!)))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (pattern-matching' generate archive preP) - post! (pattern-matching' generate archive postP)] - (wrap (<combinator> pre! post!)))]) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt ..alternation]))) - -(def: (pattern-matching generate archive pathP) + (_.set (list (..register register)) ..peek_and_pop) + then!))) + + (^ (/////synthesis.!multi_pop nextP)) + (.let [[extra_pops nextP'] (case.count_pops nextP)] + (do ///////phase.monad + [next! (recur nextP')] + (///////phase\wrap ($_ _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (^template [<tag> <combinator>] + [(^ (<tag> preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def: (pattern_matching generate archive pathP) (-> Phase Archive Path (Operation (Statement Any))) (do ///////phase.monad - [pattern-matching! (pattern-matching' generate archive pathP)] + [pattern_matching! (pattern_matching' generate archive pathP)] (wrap ($_ _.then (_.while (_.bool true) - pattern-matching!) - (_.raise (_.Exception/1 (_.string case.pattern-matching-error))))))) + pattern_matching!) + (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) (def: (gensym prefix) (-> Text (Operation SVar)) @@ -216,24 +256,24 @@ (Generator [Synthesis Path]) (do ///////phase.monad [initG (generate archive valueS) - pattern-matching! (pattern-matching generate archive pathP) + pattern_matching! (pattern_matching generate archive pathP) @case (..gensym "case") @init (..gensym "init") #let [@dependencies+ (|> (case.storage pathP) (get@ #case.dependencies) - set.to-list + set.to_list (list\map (function (_ variable) (.case variable - (#///////reference.Local register) + (#///////variable.Local register) (..register register) - (#///////reference.Foreign register) + (#///////variable.Foreign register) (..capture register)))))] #let [directive (_.def @case (list& @init @dependencies+) ($_ _.then (_.set (list @cursor) (_.list (list @init))) (_.set (list @savepoint) (_.list (list))) - pattern-matching!))] + pattern_matching!))] _ (/////generation.execute! directive) _ (/////generation.save! (_.code @case) directive)] (wrap (_.apply/* @case (list& initG @dependencies+))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux index 5ce811dfd..a4149f120 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux @@ -2,14 +2,14 @@ [lux (#- function) [abstract ["." monad (#+ do)]] - [control - pipe] [data ["." product] + [text + ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)]]] [target - ["_" python (#+ Expression Statement)]]] + ["_" python (#+ SVar Expression Statement)]]] ["." // #_ [runtime (#+ Operation Phase Generator)] ["#." reference] @@ -19,11 +19,12 @@ ["//#" /// #_ [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] [synthesis (#+ Synthesis)] - ["#." generation] + ["#." generation (#+ Context)] ["//#" /// #_ - [reference (#+ Register Variable)] [arity (#+ Arity)] - ["#." phase]]]]]) + ["#." phase] + [reference + [variable (#+ Register Variable)]]]]]]) (def: #export (apply generate archive [functionS argsS+]) (Generator (Application Synthesis)) @@ -33,16 +34,17 @@ (wrap (_.apply/* functionO argsO+)))) (def: #export capture - (///reference.foreign _.var)) + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) -(def: (with-closure function-name inits function-definition) +(def: (with_closure function_name inits function_definition) (-> Text (List (Expression Any)) (Statement Any) (Operation (Expression Any))) (case inits #.Nil (do ///////phase.monad - [_ (/////generation.execute! function-definition) - _ (/////generation.save! function-name function-definition)] - (wrap (_.apply/* (_.var function-name) inits))) + [_ (/////generation.execute! function_definition) + _ (/////generation.save! function_name function_definition)] + (wrap (_.apply/* (_.var function_name) inits))) _ (do {! ///////phase.monad} @@ -51,60 +53,63 @@ (|> (list.enumeration inits) (list\map (|>> product.left ..capture))) ($_ _.then - function-definition - (_.return (_.var function-name))))] - _ (/////generation.execute! function-definition) + function_definition + (_.return (_.var function_name))))] + _ (/////generation.execute! function_definition) _ (/////generation.save! (_.code @closure) directive)] (wrap (_.apply/* @closure inits))))) (def: input (|>> inc //case.register)) +(def: (@scope function_name) + (-> Context Text) + (format (///reference.artifact function_name) "_scope")) + (def: #export (function generate archive [environment arity bodyS]) (Generator (Abstraction Synthesis)) (do {! ///////phase.monad} - [[function-name bodyO] (/////generation.with-new-context + [[function_name bodyO] (/////generation.with_new_context archive (do ! - [function-name (\ ! map ///reference.artifact-name - /////generation.context)] - (/////generation.with-anchor (_.var function-name) + [function_name (\ ! map ..@scope + (/////generation.context archive))] + (/////generation.with_anchor (_.var function_name) (generate archive bodyS)))) - closureO+ (: (Operation (List (Expression Any))) - (monad.map ! (\ //reference.system variable) environment)) - #let [function-name (///reference.artifact-name function-name) + environment (monad.map ! (generate archive) environment) + #let [function_name (///reference.artifact function_name) @curried (_.var "curried") arityO (|> arity .int _.int) - @num-args (_.var "num_args") - @self (_.var function-name) - apply-poly (.function (_ args func) - (_.apply-poly (list) args func)) - initialize-self! (_.set (list (//case.register 0)) @self) + @num_args (_.var "num_args") + @self (_.var function_name) + apply_poly (.function (_ args func) + (_.apply_poly (list) args func)) + initialize_self! (_.set (list (//case.register 0)) @self) initialize! (list\fold (.function (_ post pre!) ($_ _.then pre! (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) - initialize-self! + initialize_self! (list.indices arity))]] - (with-closure function-name closureO+ + (with_closure function_name environment (_.def @self (list (_.poly @curried)) ($_ _.then - (_.set (list @num-args) (_.len/1 @curried)) - (_.cond (list [(|> @num-args (_.= arityO)) + (_.set (list @num_args) (_.len/1 @curried)) + (_.cond (list [(|> @num_args (_.= arityO)) ($_ _.then initialize! (_.return bodyO))] - [(|> @num-args (_.> arityO)) - (let [arity-inputs (_.slice (_.int +0) arityO @curried) - extra-inputs (_.slice arityO @num-args @curried)] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (_.slice (_.int +0) arityO @curried) + extra_inputs (_.slice arityO @num_args @curried)] (_.return (|> @self - (apply-poly arity-inputs) - (apply-poly extra-inputs))))]) - ## (|> @num-args (_.< arityO)) + (apply_poly arity_inputs) + (apply_poly extra_inputs))))]) + ## (|> @num_args (_.< arityO)) (let [@next (_.var "next") @missing (_.var "missing")] ($_ _.then (_.def @next (list (_.poly @missing)) - (_.return (|> @self (apply-poly (|> @curried (_.+ @missing)))))) + (_.return (|> @self (apply_poly (|> @curried (_.+ @missing)))))) (_.return @next) ))) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux index 14868757d..d8914d1e6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux @@ -4,12 +4,13 @@ ["." monad (#+ do)]] [data ["." product] - [number - ["n" nat]] [text ["%" format (#+ format)]] [collection ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] [target ["_" python (#+ Expression SVar)]]] ["." // #_ @@ -21,16 +22,16 @@ ["//#" /// #_ ["#." phase]]]]) -(def: loop-name +(def: loop_name (-> Nat SVar) (|>> %.nat (format "loop") _.var)) (def: #export (scope generate archive [start initsS+ bodyS]) (Generator (Scope Synthesis)) (do {! ///////phase.monad} - [@loop (\ ! map ..loop-name /////generation.next) + [@loop (\ ! map ..loop_name /////generation.next) initsO+ (monad.map ! (generate archive) initsS+) - bodyO (/////generation.with-anchor @loop + bodyO (/////generation.with_anchor @loop (generate archive bodyS)) #let [directive (_.def @loop (|> initsS+ list.enumeration diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux index 41ff5a802..0f7629614 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux @@ -2,11 +2,11 @@ [lux #* [target ["_" python (#+ Expression)]]] - ["." /// #_ - ["#." reference]]) + [/// + [reference (#+ System)]]) -(def: #export system - (let [constant (: (-> Text (Expression Any)) - _.var) - variable constant] - (///reference.system constant variable))) +(structure: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux index 7469aaa7d..876fab6a9 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -1,32 +1,39 @@ (.module: [lux (#- inc) + ["." meta] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." function] - ["p" parser - ["s" code]]] + ["<>" parser + ["<.>" code]]] [data - [number (#+ hex) - ["." i64]] - ["." text - ["%" format (#+ format)]] + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] [collection - ["." list ("#\." functor)]]] + ["." list ("#\." functor)] + ["." row]]] ["." macro - ["." code] - [syntax (#+ syntax:)]] + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] [target ["_" python (#+ Expression SVar Computation Literal Statement)]]] ["." /// #_ ["#." reference] ["//#" /// #_ + ["$" version] ["#." synthesis] - ["#." generation (#+ Buffer)] - ["//#" /// #_ + ["#." generation] + ["//#" /// (#+ Output) ["#." phase] [meta - [archive (#+ Archive)]]]]]) + [archive (#+ Archive) + ["." artifact (#+ Registry)]]]]]]) (template [<name> <base>] [(type: #export <name> @@ -77,74 +84,78 @@ (-> (Expression Any) Literal) (..variant 1 #1)) -(def: runtime-name +(def: (runtime_name name) (-> Text SVar) - (|>> ///reference.sanitize - (format ..prefix "_") - _.var)) + (let [identifier (format ..prefix + "_" (%.nat $.version) + "_" (%.nat (text\hash name)))] + (_.var identifier))) (def: (feature name definition) (-> SVar (-> SVar (Statement Any)) (Statement Any)) (definition name)) -(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} body) - (wrap (list (` (let [(~+ (|> vars - (list\map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (///reference.sanitize var)))))))) - list.concat))] - (~ body)))))) - -(syntax: (runtime: {declaration (p.or s.local-identifier - (s.form (p.and s.local-identifier - (p.some s.local-identifier))))} + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} code) (case declaration (#.Left name) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name))))] - (wrap (list (` (def: #export (~ nameC) SVar (~ runtime-nameC))) - (` (def: (~ code-nameC) + (macro.with_gensyms [g!_] + (let [nameC (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + runtime_nameC (` (runtime_name (~ (code.text name))))] + (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC))) + (` (def: (~ code_nameC) (Statement Any) - (..feature (~ runtime-nameC) + (..feature (~ runtime_nameC) (function ((~ g!_) (~ nameC)) (~ code))))))))) (#.Right [name inputs]) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name)))) - inputsC (list\map code.local-identifier inputs) - inputs-typesC (list\map (function.constant (` (_.Expression Any))) + (macro.with_gensyms [g!_] + (let [nameC (code.local_identifier name) + code_nameC (code.local_identifier (format "@" name)) + runtime_nameC (` (runtime_name (~ (code.text name)))) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` (_.Expression Any))) inputs)] (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs-typesC) (Computation Any)) - (_.apply/* (~ runtime-nameC) (list (~+ inputsC))))) - (` (def: (~ code-nameC) + (-> (~+ inputs_typesC) (Computation Any)) + (_.apply/* (~ runtime_nameC) (list (~+ inputsC))))) + (` (def: (~ code_nameC) (Statement Any) - (..feature (~ runtime-nameC) + (..feature (~ runtime_nameC) (function ((~ g!_) (~ g!_)) - (..with-vars [(~+ inputsC)] + (..with_vars [(~+ inputsC)] (_.def (~ g!_) (list (~+ inputsC)) (~ code))))))))))))) (runtime: (lux//try op) - (with-vars [error value] + (with_vars [error value] (_.try ($_ _.then (_.set (list value) (_.apply/* op (list unit))) (_.return (right value))) (list [(list (_.var "Exception")) error (_.return (left (_.str/1 error)))])))) -(runtime: (lux//program-args program-args) - (with-vars [inputs value] +(runtime: (lux//program_args program_args) + (with_vars [inputs value] ($_ _.then (_.set (list inputs) none) - (<| (_.for-in value program-args) + (<| (_.for_in value program_args) (_.set (list inputs) (some (_.tuple (list value inputs))))) (_.return inputs)))) @@ -153,7 +164,7 @@ (Statement Any) ($_ _.then @lux//try - @lux//program-args + @lux//program_args )) (runtime: (io//log! message) @@ -172,7 +183,7 @@ (_.statement (|> (_.var "sys") (_.do "exit" (list code)))) (_.return ..unit))) -(runtime: (io//current-time! _) +(runtime: (io//current_time! _) ($_ _.then (_.import "time") (_.return (|> (_.var "time") @@ -186,63 +197,63 @@ @io//log! @io//throw! @io//exit! - @io//current-time! + @io//current_time! )) -(def: last-index +(def: last_index (|>> _.len/1 (_.- (_.int +1)))) -(with-expansions [<recur> (as-is ($_ _.then - (_.set (list lefts) (_.- last-index-right lefts)) - (_.set (list tuple) (_.nth last-index-right tuple))))] +(with_expansions [<recur> (as_is ($_ _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (_.nth last_index_right tuple))))] (runtime: (tuple//left lefts tuple) - (with-vars [last-index-right] + (with_vars [last_index_right] (<| (_.while (_.bool true)) ($_ _.then - (_.set (list last-index-right) (..last-index tuple)) - (_.if (_.> lefts last-index-right) + (_.set (list last_index_right) (..last_index tuple)) + (_.if (_.> lefts last_index_right) ## No need for recursion (_.return (_.nth lefts tuple)) ## Needs recursion <recur>))))) (runtime: (tuple//right lefts tuple) - (with-vars [last-index-right right-index] + (with_vars [last_index_right right_index] (<| (_.while (_.bool true)) ($_ _.then - (_.set (list last-index-right) (..last-index tuple)) - (_.set (list right-index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last-index-right right-index) - (_.return (_.nth right-index tuple))] - [(_.> last-index-right right-index) + (_.set (list last_index_right) (..last_index tuple)) + (_.set (list right_index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= last_index_right right_index) + (_.return (_.nth right_index tuple))] + [(_.> last_index_right right_index) ## Needs recursion. <recur>]) - (_.return (_.slice-from right-index tuple))) + (_.return (_.slice_from right_index tuple))) ))))) (runtime: (sum//get sum wantsLast wantedTag) - (let [no-match! (_.return _.none) - sum-tag (_.nth (_.int +0) sum) - sum-flag (_.nth (_.int +1) sum) - sum-value (_.nth (_.int +2) sum) - is-last? (_.= (_.string "") sum-flag) - test-recursion! (_.if is-last? + (let [no_match! (_.return _.none) + sum_tag (_.nth (_.int +0) sum) + sum_flag (_.nth (_.int +1) sum) + sum_value (_.nth (_.int +2) sum) + is_last? (_.= (_.string "") sum_flag) + test_recursion! (_.if is_last? ## Must recurse. - (_.return (sum//get sum-value wantsLast (_.- sum-tag wantedTag))) - no-match!)] - (_.cond (list [(_.= sum-tag wantedTag) - (_.if (_.= wantsLast sum-flag) - (_.return sum-value) - test-recursion!)] + (_.return (sum//get sum_value wantsLast (_.- sum_tag wantedTag))) + no_match!)] + (_.cond (list [(_.= sum_tag wantedTag) + (_.if (_.= wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] - [(_.> sum-tag wantedTag) - test-recursion!] + [(_.> sum_tag wantedTag) + test_recursion!] - [(_.and (_.< sum-tag wantedTag) + [(_.and (_.< sum_tag wantedTag) (_.= (_.string "") wantsLast)) - (_.return (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) + (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - no-match!))) + no_match!))) (def: runtime//adt (Statement Any) @@ -252,14 +263,14 @@ @sum//get )) -(def: full-64-bits +(def: full_64_bits Literal (_.manual "0xFFFFFFFFFFFFFFFF")) (runtime: (i64//64 input) - (with-vars [capped] - (_.cond (list [(|> input (_.> full-64-bits)) - (_.return (|> input (_.bit-and full-64-bits) i64//64))] + (with_vars [capped] + (_.cond (list [(|> input (_.> full_64_bits)) + (_.return (|> input (_.bit_and full_64_bits) i64//64))] [(|> input (_.> (: Literal (_.manual "0x7FFFFFFFFFFFFFFF")))) ($_ _.then (_.set (list capped) @@ -270,23 +281,23 @@ (_.return (: Literal (_.manual "-9223372036854775808L")))))]) (_.return input)))) -(runtime: (i64//logic-right-shift param subject) +(runtime: (i64//logic_right_shift param subject) (let [mask (|> (_.int +1) - (_.bit-shl (_.- param (_.int +64))) + (_.bit_shl (_.- param (_.int +64))) (_.- (_.int +1)))] (_.return (|> subject - (_.bit-shr param) - (_.bit-and mask))))) + (_.bit_shr param) + (_.bit_and mask))))) (def: runtime//i64 (Statement Any) ($_ _.then @i64//64 - @i64//logic-right-shift + @i64//logic_right_shift )) (runtime: (frac//decode input) - (with-vars [ex] + (with_vars [ex] (_.try (_.return (..some (_.float/1 input))) (list [(list (_.var "Exception")) ex @@ -299,7 +310,7 @@ )) (runtime: (text//index subject param start) - (with-vars [idx] + (with_vars [idx] ($_ _.then (_.set (list idx) (|> subject (_.do "find" (list param start)))) (_.if (_.= (_.int -1) idx) @@ -340,14 +351,19 @@ runtime//io )) -(def: #export artifact ..prefix) +(def: #export artifact + ..prefix) (def: #export generate - (Operation (Buffer (Statement Any))) - (/////generation.with-buffer + (Operation [Registry Output]) + (/////generation.with_buffer (do ///////phase.monad - [#let [directive (<| (_.comment "-*- coding: utf-8 -*-") - ..runtime)] - _ (/////generation.execute! directive) - _ (/////generation.save! ..prefix directive)] - /////generation.buffer))) + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..prefix ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row ["0" + (|> ..runtime + _.code + (\ encoding.utf8 encode))])])))) diff --git a/stdlib/source/program/aedifex/artifact/build.lux b/stdlib/source/program/aedifex/artifact/build.lux new file mode 100644 index 000000000..d9a8b729e --- /dev/null +++ b/stdlib/source/program/aedifex/artifact/build.lux @@ -0,0 +1,43 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["<>" parser + ["<.>" xml (#+ Parser)] + ["<.>" text]]] + [data + [text + ["%" format]] + [format + ["." xml (#+ XML)]]] + [math + [number + ["." nat]]]]) + +(type: #export Build + Nat) + +(def: #export equivalence + (Equivalence Build) + nat.equivalence) + +(def: tag + xml.Tag + ["" "buildNumber"]) + +(def: #export format + (-> Build XML) + (|>> %.nat + #xml.Text + list + (#xml.Node ..tag xml.attributes))) + +(def: #export parser + (Parser Build) + (do <>.monad + [_ (<xml>.node ..tag)] + (<text>.embed (<>.codec nat.decimal + (<text>.many <text>.decimal)) + (<xml>.children <xml>.text)))) diff --git a/stdlib/source/test/aedifex/artifact/build.lux b/stdlib/source/test/aedifex/artifact/build.lux new file mode 100644 index 000000000..d0920b44c --- /dev/null +++ b/stdlib/source/test/aedifex/artifact/build.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [control + ["." try ("#\." functor)] + [parser + ["<.>" xml]]] + [math + ["." random]]] + {#program + ["." /]}) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Build] + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence random.nat)) + + (do random.monad + [expected random.nat] + (_.cover [/.format /.parser] + (|> expected + /.format + (<xml>.run /.parser) + (try\map (\ /.equivalence = expected)) + (try.default false)))) + )))) diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux index 9fd3986b8..b31c10617 100644 --- a/stdlib/source/test/lux/abstract.lux +++ b/stdlib/source/test/lux/abstract.lux @@ -8,6 +8,7 @@ ["#/." cofree]] ["#." enum] ["#." equivalence] + ["#." hash] ["#." fold] ["#." functor ["#/." contravariant]] @@ -46,6 +47,7 @@ /codec.test /enum.test /equivalence.test + /hash.test /fold.test /interval.test /monoid.test diff --git a/stdlib/source/test/lux/abstract/hash.lux b/stdlib/source/test/lux/abstract/hash.lux new file mode 100644 index 000000000..c527fb9c9 --- /dev/null +++ b/stdlib/source/test/lux/abstract/hash.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + [functor + ["$." contravariant]]]}] + [data + ["." bit ("#\." equivalence)]] + [math + ["." random] + [number + ["." nat]]]] + {1 + ["." / (#+ Hash) + [// + [equivalence (#+ Equivalence)]]]}) + +(def: #export test + Test + (do random.monad + [leftN random.nat + rightN random.nat + #let [hash (: (Equivalence (/.Hash Nat)) + (structure + (def: (= (^open "left\.") (^open "right\.")) + (and (bit\= (left\= (left\hash leftN) (left\hash leftN)) + (right\= (right\hash leftN) (right\hash leftN))) + (bit\= (left\= (left\hash rightN) (left\hash rightN)) + (right\= (right\hash rightN) (right\hash rightN))) + (bit\= (left\= (left\hash leftN) (left\hash rightN)) + (right\= (right\hash leftN) (right\hash rightN)))))))]] + (<| (_.covering /._) + ($_ _.and + (_.for [/.functor] + ($contravariant.spec hash nat.hash /.functor)) + )))) diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux index 6306f62fc..3efc42254 100644 --- a/stdlib/source/test/lux/data/collection/list.lux +++ b/stdlib/source/test/lux/data/collection/list.lux @@ -7,6 +7,7 @@ {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." monoid] ["$." fold] ["$." functor] @@ -49,6 +50,10 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec (/.equivalence n.equivalence) ..random)) + (_.for [/.hash] + (|> random.nat + (\ random.monad map (|>> list)) + ($hash.spec (/.hash n.hash)))) (_.for [/.monoid] ($monoid.spec (/.equivalence n.equivalence) /.monoid ..random)) (_.for [/.fold] diff --git a/stdlib/source/test/lux/data/collection/set.lux b/stdlib/source/test/lux/data/collection/set.lux index 6f981af91..282749f5e 100644 --- a/stdlib/source/test/lux/data/collection/set.lux +++ b/stdlib/source/test/lux/data/collection/set.lux @@ -7,6 +7,7 @@ {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." monoid]]}] [data ["." bit ("#\." equivalence)] @@ -33,6 +34,10 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec /.equivalence (random.set n.hash size random.nat))) + (_.for [/.hash] + (|> random.nat + (\ random.monad map (|>> list (/.from_list n.hash))) + ($hash.spec /.hash))) (_.for [/.monoid] ($monoid.spec /.equivalence (/.monoid n.hash) (random.set n.hash size random.nat))) diff --git a/stdlib/source/test/lux/data/collection/set/multi.lux b/stdlib/source/test/lux/data/collection/set/multi.lux index 9d9572795..718c971c3 100644 --- a/stdlib/source/test/lux/data/collection/set/multi.lux +++ b/stdlib/source/test/lux/data/collection/set/multi.lux @@ -7,7 +7,8 @@ ["." predicate] {[0 #spec] [/ - ["$." equivalence]]}] + ["$." equivalence] + ["$." hash]]}] [data ["." bit ("#\." equivalence)] [collection @@ -50,6 +51,11 @@ (`` ($_ _.and (_.for [/.equivalence] ($equivalence.spec /.equivalence (..random diversity n.hash ..count random.nat))) + (_.for [/.hash] + (|> random.nat + (\ random.monad map (function (_ single) + (/.add 1 single (/.new n.hash)))) + ($hash.spec /.hash))) (_.cover [/.to_list /.from_list] (|> sample diff --git a/stdlib/source/test/lux/data/maybe.lux b/stdlib/source/test/lux/data/maybe.lux index 64f9b5ff5..017d0799b 100644 --- a/stdlib/source/test/lux/data/maybe.lux +++ b/stdlib/source/test/lux/data/maybe.lux @@ -6,6 +6,7 @@ {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." monoid] ["$." functor] ["$." apply] @@ -31,6 +32,10 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec (/.equivalence n.equivalence) (random.maybe random.nat))) + (_.for [/.hash] + (|> random.nat + (\ random.monad map (|>> #.Some)) + ($hash.spec (/.hash n.hash)))) (_.for [/.monoid] ($monoid.spec (/.equivalence n.equivalence) /.monoid (random.maybe random.nat))) (_.for [/.functor] diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux index 7912994c3..f68a58d9a 100644 --- a/stdlib/source/test/lux/data/name.lux +++ b/stdlib/source/test/lux/data/name.lux @@ -6,6 +6,7 @@ {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." order] ["$." codec]]}] [control @@ -45,6 +46,10 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec /.equivalence (..random sizeM1 sizeS1))) + (_.for [/.hash] + (|> (random.ascii 2) + (\ ! map (|>> [""])) + ($hash.spec /.hash))) (_.for [/.order] ($order.spec /.order (..random sizeM1 sizeS1))) (_.for [/.codec] diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux index a5d11685f..c89ca97ba 100644 --- a/stdlib/source/test/lux/data/text.lux +++ b/stdlib/source/test/lux/data/text.lux @@ -6,6 +6,7 @@ {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." order] ["$." monoid]]}] [control @@ -238,6 +239,9 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec /.equivalence (random.ascii 2))) + (_.for [/.hash] + (|> (random.ascii 2) + ($hash.spec /.hash))) (_.for [/.order] ($order.spec /.order (random.ascii 2))) (_.for [/.monoid] diff --git a/stdlib/source/test/lux/locale.lux b/stdlib/source/test/lux/locale.lux index 5693eb2c4..23cb63a97 100644 --- a/stdlib/source/test/lux/locale.lux +++ b/stdlib/source/test/lux/locale.lux @@ -5,7 +5,8 @@ [monad (#+ do)] {[0 #spec] [/ - ["$." equivalence]]}] + ["$." equivalence] + ["$." hash]]}] [math ["." random (#+ Random) ("#\." monad)]] [data @@ -51,6 +52,25 @@ ($_ _.and (_.for [/.equivalence] ($equivalence.spec /.equivalence ..random_locale)) + (_.for [/.hash] + (do {! random.monad} + [fixed_language ..random_language + fixed_territory ..random_territory + fixed_encoding ..random_encoding] + ($_ _.and + (|> ..random_language + (\ ! map (function (_ language) + (/.locale language (#.Some fixed_territory) (#.Some fixed_encoding)))) + ($hash.spec /.hash)) + (|> ..random_territory + (\ ! map (function (_ territory) + (/.locale fixed_language (#.Some territory) (#.Some fixed_encoding)))) + ($hash.spec /.hash)) + (|> ..random_encoding + (\ ! map (function (_ encoding) + (/.locale fixed_language (#.Some fixed_territory) (#.Some encoding)))) + ($hash.spec /.hash)) + ))) (do random.monad [language ..random_language diff --git a/stdlib/source/test/lux/time/month.lux b/stdlib/source/test/lux/time/month.lux index d7078fa65..2cecfced6 100644 --- a/stdlib/source/test/lux/time/month.lux +++ b/stdlib/source/test/lux/time/month.lux @@ -1,38 +1,89 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract + [monad (#+ do)] + ["." predicate] {[0 #spec] [/ ["$." equivalence] + ["$." hash] ["$." order] ["$." enum]]}] + [control + ["." try ("#\." functor)] + ["." exception]] + [data + [collection + ["." set] + ["." list ("#\." functor fold)]]] [math - ["r" random (#+ Random) ("#\." monad)]]] + ["." random (#+ Random)] + [number + ["n" nat]]]] {1 - ["." / (#+ Month)]}) + ["." / + [// + ["." duration]]]}) -(def: #export month - (Random Month) - (r.either (r.either (r.either (r\wrap #/.January) - (r.either (r\wrap #/.February) - (r\wrap #/.March))) - (r.either (r\wrap #/.April) - (r.either (r\wrap #/.May) - (r\wrap #/.June)))) - (r.either (r.either (r\wrap #/.July) - (r.either (r\wrap #/.August) - (r\wrap #/.September))) - (r.either (r\wrap #/.October) - (r.either (r\wrap #/.November) - (r\wrap #/.December)))))) +(def: #export random + (Random /.Month) + (let [december (/.number #/.December)] + (|> random.nat + (\ random.monad map (|>> (n.% december) inc)) + (random.one (|>> /.by_number try.to_maybe))))) (def: #export test Test - (<| (_.context (%.name (name_of /._))) + (<| (_.covering /._) + (_.for [/.Month]) ($_ _.and - ($equivalence.spec /.equivalence ..month) - ($order.spec /.order ..month) - ($enum.spec /.enum ..month) + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + (_.for [/.hash] + ($hash.spec /.hash ..random)) + (_.for [/.order] + ($order.spec /.order ..random)) + (_.for [/.enum] + ($enum.spec /.enum ..random)) + + (do random.monad + [expected ..random + invalid (random.filter (predicate.unite (n.< (/.number #/.January)) + (n.> (/.number #/.December))) + random.nat)] + ($_ _.and + (_.cover [/.number /.by_number] + (|> expected + /.number + /.by_number + (try\map (\ /.equivalence = expected)) + (try.default false))) + (_.cover [/.invalid_month] + (case (/.by_number invalid) + (#try.Failure error) + (exception.match? /.invalid_month error) + + (#try.Success _) + false)) + (_.cover [/.year] + (let [all (list.size /.year) + uniques (set.size (set.from_list /.hash /.year))] + (and (n.= (/.number #/.December) + all) + (n.= all + uniques)))) + (_.cover [/.days] + (let [expected (.nat (duration.query duration.day duration.normal_year))] + (|> /.year + (list\map /.days) + (list\fold n.+ 0) + (n.= expected)))) + (_.cover [/.leap_year_days] + (let [expected (.nat (duration.query duration.day duration.leap_year))] + (|> /.year + (list\map /.leap_year_days) + (list\fold n.+ 0) + (n.= expected)))) + )) ))) |